;;;; s3.lisp

(in-package #:quicklisp-client-uploader)

(defun s3-components (url)
  (setf url (url url))
  (values (hostname url)
          (string-left-trim "/" (path url))))

(defun s3-object-exists (bucket key)
  (let ((http-status (nth-value 1 (zs3:head :bucket bucket :key key))))
    (<= 200 http-status 299)))

(defun put-to-s3-url (file url &key (if-exists :error)
                      (content-type "binary/octet-stream")
                      content-disposition)
  (multiple-value-bind (bucket key)
      (s3-components url)
    (flet ((upload ()
             (zs3:put-file file bucket key
                      :public t
                      :content-type content-type
                      :content-disposition content-disposition)
             t))
      (ecase if-exists
        ((:overwrite)
         (upload))
        ((nil :error)
         (let ((exists (s3-object-exists bucket key)))
           (cond (exists
                  (case if-exists
                    (:error (error "Object already exists at ~A" url))
                    ((nil) nil)))
                 (t
                  (upload)))))))))

Add an OVERWRITE restart in PUT-TO-S3-URL.

;;;; s3.lisp

(in-package #:quicklisp-client-uploader)

(defun s3-components (url)
  (setf url (url url))
  (values (hostname url)
          (string-left-trim "/" (path url))))

(defun s3-object-exists (bucket key)
  (let ((http-status (nth-value 1 (zs3:head :bucket bucket :key key))))
    (<= 200 http-status 299)))

(defun put-to-s3-url (file url &key (if-exists :error)
                      (content-type "binary/octet-stream")
                      content-disposition)
  (multiple-value-bind (bucket key)
      (s3-components url)
    (flet ((upload ()
             (zs3:put-file file bucket key
                      :public t
                      :content-type content-type
                      :content-disposition content-disposition)
             t))
      (ecase if-exists
        ((:overwrite)
         (upload))
        ((nil :error)
         (let ((exists (s3-object-exists bucket key)))
           (cond (exists
                  (case if-exists
                    (:error
                     (restart-case
                         (error "Object already exists at ~A" url)
                       (overwrite ()
                         :report "Overwrite it"
                         (upload))))
                    ((nil) nil)))
                 (t
                  (upload)))))))))


(cl:in-package #:sicl-extrinsic-hir-compiler)

(defun rp (filename)
  (asdf:system-relative-pathname :sicl-extrinsic-hir-compiler filename))

(load (rp "../../Evaluation-and-compilation/lambda.lisp"))
(load (rp "../../Environment/multiple-value-bind.lisp"))
(load (rp "../../Data-and-control-flow/setf.lisp"))
(load (rp "../../Environment/defun.lisp"))
(load (rp "../../Data-and-control-flow/fboundp.lisp"))
(load (rp "../../Data-and-control-flow/fdefinition.lisp"))

Load the definition of (SETF CL:FDEFINITION).

(cl:in-package #:sicl-extrinsic-hir-compiler)

(defun rp (filename)
  (asdf:system-relative-pathname :sicl-extrinsic-hir-compiler filename))

(load (rp "../../Evaluation-and-compilation/lambda.lisp"))
(load (rp "../../Environment/multiple-value-bind.lisp"))
(load (rp "../../Data-and-control-flow/setf.lisp"))
(load (rp "../../Environment/defun.lisp"))
(load (rp "../../Data-and-control-flow/fboundp.lisp"))
(load (rp "../../Data-and-control-flow/fdefinition.lisp"))
(load (rp "../../Data-and-control-flow/setf-fdefinition.lisp"))


(asdf:defsystem #:birch
  :serial t
  :description "A simple Common Lisp IRC client library"
  :author "Joram Schrijver <i@joram.io>"
  :license "LLGPL"
  :depends-on (#:split-sequence #:usocket #:flexi-streams)
  :components ((:file "package")
	       (:file "replies")
	       (:file "parse")
	       (:file "ctcp")
	       (:file "connection")
	       (:file "commands")
	       (:file "events")
	       (:file "birch")))

Fix license in system definition

(asdf:defsystem #:birch
  :serial t
  :description "A simple Common Lisp IRC client library"
  :author "Joram Schrijver <i@joram.io>"
  :license "MIT"
  :depends-on (#:split-sequence #:usocket #:flexi-streams)
  :components ((:file "package")
	       (:file "replies")
	       (:file "parse")
	       (:file "ctcp")
	       (:file "connection")
	       (:file "commands")
	       (:file "events")
	       (:file "birch")))


(cl:in-package #:sicl-extrinsic-environment)

(defun find-variable-entry (symbol env)
  (loop for entry in (dynamic-environment env)
	do (when (and (typep entry 'variable-binding)
		      (eq (symbol entry) symbol))
	     (return entry))))

(defun symbol-value (symbol env)
  (let ((entry (find-variable-entry symbol env))
	(unbound-value (sicl-global-environment:variable-unbound symbol env))
	(global-value-cell (sicl-global-environment:variable-cell symbol env)))
    (if (null entry)
	(if (eq (car global-value-cell) unbound-value)
	    (error "unbound variable ~s" symbol)
	    (car global-value-cell))
	(if (eq (value entry) unbound-value)
	    (error "unbound variable ~s" symbol)
	    (value entry)))))

(defun (setf symbol-value) (new-value symbol env)
  (let ((entry (find-variable-entry symbol env))
	(global-value-cell (sicl-global-environment:variable-cell symbol env)))
    (if (null entry)
	(setf (car global-value-cell) new-value)
	(setf (value entry) new-value))))

Modify according to new way of transmitting the dynamic environment.

(cl:in-package #:sicl-extrinsic-environment)

(defun find-variable-entry (symbol dynamic-environment)
  (loop for entry in dynamic-environment
	do (when (and (typep entry 'variable-binding)
		      (eq (symbol entry) symbol))
	     (return entry))))

(defun symbol-value (symbol env)
  (let* ((dynamic-environment *dynamic-environment*)
	 (entry (find-variable-entry symbol dynamic-environment))
	 (unbound-value (sicl-global-environment:variable-unbound symbol env))
	 (global-value-cell (sicl-global-environment:variable-cell symbol env)))
    (if (null entry)
	(if (eq (car global-value-cell) unbound-value)
	    (error "unbound variable ~s" symbol)
	    (car global-value-cell))
	(if (eq (value entry) unbound-value)
	    (error "unbound variable ~s" symbol)
	    (value entry)))))

(defun (setf symbol-value) (new-value symbol env)
  (let* ((dynamic-environment *dynamic-environment*)
	 (entry (find-variable-entry symbol dynamic-environment))
	 (global-value-cell (sicl-global-environment:variable-cell symbol env)))
    (if (null entry)
	(setf (car global-value-cell) new-value)
	(setf (value entry) new-value))))


; tré – Copyright (c) 2014 Sven Michael Klose <pixel@copei.de>

(defun cl-packages ()
  `((defpackage :tre-core
      (:export :nil :t :setq :labels
                ,@(make-keywords (+ (carlist +cl-renamed-imports+)
                                    *cl-builtins*))))
    (defpackage :tre
      (:use :tre-core))))

(defun cl-symbol (x)
  (make-symbol (symbol-name x) "COMMON-LISP"))

(defun cl-wrapper (x)
  (format nil "(cl:defun ~A (cl:&rest x) (cl:apply #'cl:~A x))~%"
              (symbol-name x.) (symbol-name .x.)))

(defun cl-wrappers ()
  (filter #'cl-wrapper
          (+ (filter [list _ _] +cl-direct-imports+)
             +cl-renamed-imports+)))

(alet (copy-transpiler *cl-transpiler*)
  (= (transpiler-save-sources? !) nil)
  (with-output-file o "tre.lisp"
    (filter [late-print _ o]
            (let c (compile-sections (list (. 'core *cl-base*))
                                     :transpiler !)
              (+ (cl-packages)
                 '((in-package :tre-core))
                 c)))
    (adolist ((cl-wrappers))
      (princ ! o))))

(quit)

Convert lambda expressions. Fix DEFPACKAGE.

; tré – Copyright (c) 2014 Sven Michael Klose <pixel@copei.de>

(defun cl-packages ()
  `((defpackage :tre-core
      (:export :nil :t :setq :labels
                ,@(make-keywords (+ +cl-direct-imports+
                                    (carlist +cl-renamed-imports+)
                                    *cl-builtins*))))
    (defpackage :tre
      (:use :tre-core))))

(defun cl-symbol (x)
  (make-symbol (symbol-name x) "COMMON-LISP"))

(defun cl-wrapper (x)
  (format nil "(cl:defun ~A (cl:&rest x) (cl:apply #'cl:~A x))~%"
              (symbol-name x.) (symbol-name .x.)))

(defun cl-wrappers ()
  (filter #'cl-wrapper
          (+ (filter [list _ _] +cl-direct-imports+)
             +cl-renamed-imports+)))

(alet (copy-transpiler *cl-transpiler*)
  (= (transpiler-save-sources? !) nil)
  (with-output-file o "tre.lisp"
    (filter [late-print _ o]
            (let c (compile-sections (list (. 'core *cl-base*))
                                     :transpiler !)
              (+ (cl-packages)
                 '((in-package :tre-core))
                 (make-lambdas c))))
    (adolist ((cl-wrappers))
      (princ ! o))))

(quit)


(in-package #:utils)

(define-condition simple-style-warning (style-warning simple-condition)
  ())

(defmacro simple-style-warning (fmt-ctrl &rest args)
  `(warn 'simple-style-warning
	 :format-control ,fmt-ctrl
	 :format-arguments (list ,@args)))

(define-condition simple-program-error (program-error simple-condition)
  ())

(defmacro simple-program-error (fmt-ctrl &rest args)
  `(error 'simple-program-error
	  :format-control ,fmt-ctrl
	  :format-arguments (list ,@args)))

(defgeneric format-condition (condition stream)
  (:method ((condition simple-condition) (stream stream))
    (format stream (simple-condition-format-control condition)
            (simple-condition-format-arguments condition))))

Define method CONDITION SYMBOL such as to interpret SYMBOL as an output stream designator

(in-package #:utils)

(define-condition simple-style-warning (style-warning simple-condition)
  ())

(defmacro simple-style-warning (fmt-ctrl &rest args)
  `(warn 'simple-style-warning
	 :format-control ,fmt-ctrl
	 :format-arguments (list ,@args)))

(define-condition simple-program-error (program-error simple-condition)
  ())

(defmacro simple-program-error (fmt-ctrl &rest args)
  `(error 'simple-program-error
	  :format-control ,fmt-ctrl
	  :format-arguments (list ,@args)))

(defgeneric format-condition (condition stream)
  (:method ((condition condition) (stream symbol))
    (format-condition condition
                      (ecase stream
                        ((t) *terminal-io*)
                        ((nil) *standard-output*))))
  (:method ((condition simple-condition) (stream stream))
    (format stream (simple-condition-format-control condition)
            (simple-condition-format-arguments condition))))


;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
;;;
;;; --- Wrappers for socket-related C macros.
;;;

(in-package :net.sockets)

(c "#if defined(__linux__)")
(define "_XOPEN_SOURCE" 600)
(define "_LARGEFILE_SOURCE")
(define "_LARGEFILE64_SOURCE")
(define "_FILE_OFFSET_BITS" 64)
(c "#endif")

(include "sys/socket.h")

(defwrapper* ("cmsg_space" %cmsg-space) :unsigned-int
  ((data-size :unsigned-int))
  "return CMSG_SPACE(data_size);")

(defwrapper* ("cmsg_len" %cmsg-len) :unsigned-int
  ((data-size :unsigned-int))
  "return CMSG_LEN(data_size);")

(defwrapper* ("cmsg_firsthdr" %cmsg-firsthdr) :pointer
  ((msg ("struct msghdr*" :pointer)))
  "return CMSG_FIRSTHDR(msg);")

(defwrapper* ("cmsg_data" %cmsg-data) :pointer
  ((cmsg ("struct cmsghdr*" :pointer)))
  "return CMSG_DATA(cmsg);")

Add back (include "stdlib.h") to fix compilation on FreeBSD.

;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
;;;
;;; --- Wrappers for socket-related C macros.
;;;

(in-package :net.sockets)

(c "#if defined(__linux__)")
(define "_XOPEN_SOURCE" 600)
(define "_LARGEFILE_SOURCE")
(define "_LARGEFILE64_SOURCE")
(define "_FILE_OFFSET_BITS" 64)
(c "#endif")

(include "stdlib.h") ; needed on FreeBSD to define NULL
(include "sys/socket.h")

(defwrapper* ("cmsg_space" %cmsg-space) :unsigned-int
  ((data-size :unsigned-int))
  "return CMSG_SPACE(data_size);")

(defwrapper* ("cmsg_len" %cmsg-len) :unsigned-int
  ((data-size :unsigned-int))
  "return CMSG_LEN(data_size);")

(defwrapper* ("cmsg_firsthdr" %cmsg-firsthdr) :pointer
  ((msg ("struct msghdr*" :pointer)))
  "return CMSG_FIRSTHDR(msg);")

(defwrapper* ("cmsg_data" %cmsg-data) :pointer
  ((cmsg ("struct cmsghdr*" :pointer)))
  "return CMSG_DATA(cmsg);")


(import base (defun defmacro progn for while if when unless and or
              get-idx set-idx! format print! pretty error! empty-struct gensym
              == ~= < <= > >= + - * % ^ .. !))

(import binders ())
(import list ())
(import types ())
(import partial ())
(import table ())

(defun fail (msg) (error! msg 0))

(defun between? (val min max) (and (>= val min) (<= val max)))

(defun symbol->string (x) (if (symbol? x) (get-idx x "contents") nil))
(defun bool->string (x) (if x "true" "false"))

(define-native number->string)

;; TODO: Fix up the resolver
(defun /= (x y) (~= x y))
(defun = (x y) (== x y))

(defmacro case (x &cases)
  (let* ((name (gensym))
         (transform-case (lambda (case)
                           (if (list? case)
                             `((,@(car case) ,name) ,@(cdr case))
                             `(true)))))
    `((lambda (,name) (cond ,@(map transform-case cases))) ,x)))

(defun succ (x) (+ 1 x))
(defun pred (x) (- x 1))

(defmacro inc! (x) `(set! ,x (+ ,x 1)))
(defmacro dec! (x) `(set! ,x (- ,x 1)))

Add support for constant tests in `(case)`

(import base (defun defmacro progn for while if when unless and or
              get-idx set-idx! format print! pretty error! empty-struct gensym
              == ~= < <= > >= + - * % ^ .. !))

(import binders ())
(import list ())
(import types ())
(import partial ())
(import table ())

(defun fail (msg) (error! msg 0))

(defun between? (val min max) (and (>= val min) (<= val max)))

(defun symbol->string (x) (if (symbol? x) (get-idx x "contents") nil))
(defun bool->string (x) (if x "true" "false"))

(define-native number->string)

(defun /= (x y) (~= x y))
(defun = (x y) (== x y))

(defmacro case (x &cases)
  (let* ((name (gensym))
         (transform-case (lambda (case)
                           (if (list? case)
                             (if (list? (car case))
                               `((,@(car case) ,name) ,@(cdr case))
                               `(,(car case) ,@(cdr case)))
                             `(true)))))
    `((lambda (,name) (cond ,@(map transform-case cases))) ,x)))

(defun succ (x) (+ 1 x))
(defun pred (x) (- x 1))

(defmacro inc! (x) `(set! ,x (+ ,x 1)))
(defmacro dec! (x) `(set! ,x (- ,x 1)))


(cl:in-package #:common-lisp-user)

(asdf:defsystem :sicl-data-and-control-flow
  :depends-on (:sicl-environment
	       :cleavir-internationalization)
  :serial t
  :components
  ((:file "packages")
   (:file "conditions")
   (:file "condition-reporters-english")))

Define ASDF system in the package ASDF-USER.

(cl:in-package #:asdf-user)

(defsystem :sicl-data-and-control-flow
  :depends-on (:sicl-environment
	       :cleavir-internationalization)
  :serial t
  :components
  ((:file "packages")
   (:file "conditions")
   (:file "condition-reporters-english")))


;;;; cl-stripe.asd

(asdf:defsystem #:cl-stripe
  :serial t
  :depends-on (#:st-json
               #:drakma
               #:alexandria)
  :components ((:file "package")
               (:file "variables")
               (:file "sstruct")
               (:file "cl-stripe")))

Add a :description to the .asd file.

;;;; cl-stripe.asd

(asdf:defsystem #:cl-stripe
  :serial t
  :description "An interface to the stripe.com API"
  :depends-on (#:st-json
               #:drakma
               #:alexandria)
  :components ((:file "package")
               (:file "variables")
               (:file "sstruct")
               (:file "cl-stripe")))


(cl:in-package #:clump-2-3-tree)

;;; This generic function can be used only on an empty tree.
(defgeneric insert (object tree))

(defmethod insert :before (object (tree tree))
  (unless (null (contents tree))
    (error "Do this error message better.")))

(defmethod insert (object (tree tree))
  (setf (contents tree)
	(make-instance (leaf-class tree)
	  :contents object
	  :parent tree
	  :tree tree)))

;;; In NODE, split child node OLD-CHILD into two child nodes,
;;; NEW-CHILD-1 and NEW-CHILD-2.
(defgeneric split (node old-child new-child-1 new-child-2))

;; In NODE, replace child OLD-CHILD with the node NEW-CHILD.
(defgeneric replace (node old-child new-child))

(defmethod replace ((node 2-node) old-child new-child)
  (if (eq old-child (left node))
      (setf (left node) new-child)
      (setf (right node) new-child)))

Define method on REPLACE specialized to 3-NODE.

(cl:in-package #:clump-2-3-tree)

;;; This generic function can be used only on an empty tree.
(defgeneric insert (object tree))

(defmethod insert :before (object (tree tree))
  (unless (null (contents tree))
    (error "Do this error message better.")))

(defmethod insert (object (tree tree))
  (setf (contents tree)
	(make-instance (leaf-class tree)
	  :contents object
	  :parent tree
	  :tree tree)))

;;; In NODE, split child node OLD-CHILD into two child nodes,
;;; NEW-CHILD-1 and NEW-CHILD-2.
(defgeneric split (node old-child new-child-1 new-child-2))

;; In NODE, replace child OLD-CHILD with the node NEW-CHILD.
(defgeneric replace (node old-child new-child))

(defmethod replace ((node 2-node) old-child new-child)
  (if (eq old-child (left node))
      (setf (left node) new-child)
      (setf (right node) new-child)))

(defmethod replace ((node 3-node) old-child new-child)
  (if (eq old-child (left node))
      (setf (left node) new-child)
      (if (eq old-child (middle node))
	  (setf (middle node) new-child)
	  (setf (right node) new-child))))


;; See the file LICENCE for licence information.
(in-package :ucw-standard)

;;;; *** Cookie session

(defvar +ucw-session-cookie-name+ "ucw-session-id"
  "Name of the cookie used when storing the session id.")

(defclass cookie-session-application-mixin ()
  ()
  (:documentation "Class for applications which use cookies for sesion tracking.

Cookie session applications work exactly like
standard-applications except that when the session is not found
using the standard mechanisms the id is looked for in a cookie."))

(defmethod request-context-class list ((app cookie-session-application-mixin))
  'cookie-session-request-context-mixin)

(defclass cookie-session-request-context-mixin ()
  ())

(defmethod (setf context.session) :after ((session basic-session)
                                          (context cookie-session-request-context-mixin))
  ;; TODO not sure if this is the best place. why not add unconditionally to be more bullet-proof?

  (add-cookie (make-cookie +ucw-session-cookie-name+
			   (session.id session)
			   :path (application.url-prefix
				  (context.application context)))))

(defmethod find-session-id :around ((context cookie-session-request-context-mixin))
  (or (call-next-method)
      (cookie-value +ucw-session-cookie-name+)))

Allow applications to specify the name of the session id cookie. This allows multiple cookie session UCW applications on a single hostname without stomping the sessions.

;; See the file LICENCE for licence information.
(in-package :ucw-standard)

;;;; *** Cookie session

(defvar +ucw-session-cookie-name+ "ucw-session-id"
  "Name of the cookie used when storing the session id.")

(defclass cookie-session-application-mixin ()
  ((ucw-session-cookie-name :accessor ucw-session-cookie-name :initarg :ucw-session-cookie-name :initform +ucw-session-cookie-name+))
  (:documentation "Class for applications which use cookies for sesion tracking.

Cookie session applications work exactly like
standard-applications except that when the session is not found
using the standard mechanisms the id is looked for in a cookie."))

(defmethod request-context-class list ((app cookie-session-application-mixin))
  'cookie-session-request-context-mixin)

(defclass cookie-session-request-context-mixin ()
  ())

(defmethod (setf context.session) :after ((session basic-session)
                                          (context cookie-session-request-context-mixin))
  ;; TODO not sure if this is the best place. why not add unconditionally to be more bullet-proof?

  (add-cookie (make-cookie (ucw-session-cookie-name (context.application context))
			   (session.id session)
			   :path (application.url-prefix
				  (context.application context)))))

(defmethod find-session-id :around ((context cookie-session-request-context-mixin))
  (or (call-next-method)
      (cookie-value (ucw-session-cookie-name (context.application context)))))


;;;;; tré – Copyright (C) 2005-2009,2011–2012 Sven Michael Klose <pixel@copei.de>

(defun %=-function? (x)
  (function? (eval `(function ,x))))

Use SYMBOL-FUNCTION instead of EVAL.

;;;;; tré – Copyright (C) 2005-2009,2011–2012 Sven Michael Klose <pixel@copei.de>

(defun %=-function? (x)
  (function? (symbol-function x)))


(cl:in-package #:sicl-boot-phase1)

(defun fill-environment (linkage-environment)
  (declare (ignore linkage-environment))
  nil)

Define function LD for loading files.

(cl:in-package #:sicl-boot-phase1)

(defun ld (filename environment)
  (format *trace-output* "Loading file ~a~%" filename)
  (finish-output *trace-output*)
  (sicl-extrinsic-environment:load-source-with-environments
   filename (compilation-environment environment) environment))

(defun fill-environment (environment)
  (ld "../../CLOS/ensure-generic-function-using-class-defgenerics.lisp"
      environment))


(cl:in-package #:sicl-boot-phase1)

(defun ld (filename environment)
  (format *trace-output* "Loading file ~a~%" filename)
  (finish-output *trace-output*)
  (sicl-extrinsic-environment:load-source-with-environments
   filename (compilation-environment environment) environment))

(defun fill-environment (environment)
  (sicl-genv:fmakunbound 'sicl-clos:ensure-generic-function-using-class
			 environment)
  (ld "../../CLOS/ensure-generic-function-using-class-defgenerics.lisp"
      environment))

Load file containing definitions of methods on ENSURE-GENERIC-FUNCTION-USING-CLASS.

(cl:in-package #:sicl-boot-phase1)

(defun ld (filename environment)
  (format *trace-output* "Loading file ~a~%" filename)
  (finish-output *trace-output*)
  (sicl-extrinsic-environment:load-source-with-environments
   filename (compilation-environment environment) environment))

(defun fill-environment (environment)
  (sicl-genv:fmakunbound 'sicl-clos:ensure-generic-function-using-class
			 environment)
  (ld "../../CLOS/ensure-generic-function-using-class-defgenerics.lisp"
      environment)
  (ld "../../CLOS/ensure-generic-function-using-class-defmethods.lisp"
      environment))


(cl:in-package #:clump-binary-tree)

(defgeneric left (node))
(defgeneric right (node))
(defgeneric (setf left) (new-left node))
(defgeneric (setf right) (new-right node))

(defclass node ()
  ((%left :initarg :left :initform nil :accessor left)
   (%right :initarg :right :initform nil :accessor right)))

(defgeneric node-p (tree)
  (:method (tree) nil)
  (:method ((tree node)) t))

(defmethod initialize-instance :before ((object node) &key left right)
  (unless (or (null left) (node-p left))
    (error 'invalid-binary-tree :tree left))
  (unless (or (null right) (node-p right))
    (error 'invalid-binary-tree :tree right)))

(defclass simple-node (node)
  ())

(defclass node-with-parent (node)
  ((%parent :initarg :parent :initform nil :accessor parent)))

Add an :AFTER method on (SETF LEFT) specialized to NODE-WITH-PARENT.

(cl:in-package #:clump-binary-tree)

(defgeneric left (node))
(defgeneric right (node))
(defgeneric (setf left) (new-left node))
(defgeneric (setf right) (new-right node))

(defclass node ()
  ((%left :initarg :left :initform nil :accessor left)
   (%right :initarg :right :initform nil :accessor right)))

(defgeneric node-p (tree)
  (:method (tree) nil)
  (:method ((tree node)) t))

(defmethod initialize-instance :before ((object node) &key left right)
  (unless (or (null left) (node-p left))
    (error 'invalid-binary-tree :tree left))
  (unless (or (null right) (node-p right))
    (error 'invalid-binary-tree :tree right)))

(defclass simple-node (node)
  ())

(defclass node-with-parent (node)
  ((%parent :initarg :parent :initform nil :accessor parent)))

(defmethod (setf left) :after
    ((new-left node-with-parent) (node node-with-parent))
  (setf (parent new-left) node))


;;; -*- Mode: Lisp; Package: INSPECTOR -*-

;;;  (c) copyright 2005 by
;;;           Robert Strandh (strandh@labri.fr)

;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA  02111-1307  USA.

;;; CLIM inspector application

(asdf:defsystem clouseau
    :depends-on (:mcclim)
    :serial t
    :components
    ((:file "package")
     (:file "disassembly")
     (:file "inspector")))

Make Clouseau's system definition inter-file dependencies explicit, just for good measure.

;;; -*- Mode: Lisp; Package: INSPECTOR -*-

;;;  (c) copyright 2005 by
;;;           Robert Strandh (strandh@labri.fr)

;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA  02111-1307  USA.

;;; CLIM inspector application

(asdf:defsystem clouseau
    :depends-on (:mcclim)
    :serial t
    :components
    ((:file "package")
     (:file "disassembly" :depends-on ("package"))
     (:file "inspector" :depends-on ("disassembly"))))


(in-package #:roo-site)

(defvar *day-names*
  '("Maandag" "Dinsdag" "Woensdag" "Donderdag" "Vrijdag" "Zaterdag" "Zondag"))

(defgeneric name-of-day (date))

(defmethod name-of-day ((date local-time:timestamp))
  (nth (local-time:timestamp-day-of-week date)
       *day-names*))

(defmethod name-of-day (date)
  (name-of-day (roo-parser:datestring->timestamp date)))

(defgeneric pretty-date-string (date))

(defmethod pretty-date-string ((date local-time:timestamp))
  (local-time:format-timestring NIL date
                                :format '(:year "-" :month "-" :day)))

(defmethod pretty-date-string ((date roo-parser:appointment))
  (pretty-date-string (roo-parser:date date)))

(defmethod pretty-date-string (date)
  (pretty-date-string (roo-parser:datestring->timestamp date)))

Fix names of days, broken because of timezone change

(in-package #:roo-site)

(defvar *day-names*
  '("Maandag" "Dinsdag" "Woensdag" "Donderdag" "Vrijdag" "Zaterdag" "Zondag"))

(defgeneric name-of-day (date))

(defmethod name-of-day ((date local-time:timestamp))
  (nth (1- (local-time:timestamp-day-of-week date))
       *day-names*))

(defmethod name-of-day (date)
  (name-of-day (roo-parser:datestring->timestamp date)))

(defgeneric pretty-date-string (date))

(defmethod pretty-date-string ((date local-time:timestamp))
  (local-time:format-timestring NIL date
                                :format '(:year "-" :month "-" :day)))

(defmethod pretty-date-string ((date roo-parser:appointment))
  (pretty-date-string (roo-parser:date date)))

(defmethod pretty-date-string (date)
  (pretty-date-string (roo-parser:datestring->timestamp date)))


;;;;; TRE environment
;;;;; Copyright (c) 2005-2011 Sven Klose <pixel@copei.de>

(defun copy-while (pred x)
  (when (and x (funcall pred (car x)))
	(cons (car x)
		  (copy-while pred (cdr x)))))

(define-test "COPY-WHILE"
  ((copy-while #'number? '(1 2 3 a)))
  '(1 2 3))

(defun collect (pred x)
  (values (copy-while pred x)
		  (remove-if pred x)))

(defmacro with (alst &rest body)
  (unless body
	(error "body expected"))
  ; Make new WITH for rest of assignment list.
  (labels ((sub (x)
             (? (cddr x)
                `((with ,(cddr x)
					,@body))
                body)))

	; Get first pair.
    (let* ((plc (car alst))
           (val (cadr alst)))
      (?
	    ; MULTIPLE-VALUE-BIND if place is a cons.
	    (cons? plc)
          `(multiple-value-bind ,plc ,val
		     ,@(sub alst))

	    ; Place function is set of value is a function.
		(lambda? val)
		  (multiple-value-bind (funs followers) (collect (fn lambda? (cadr _)) (group alst 2))
		    `(labels ,(mapcar (fn `(,(car _) ,@(past-lambda (cadr _)))) funs)
			   ,@(sub (apply #'append followers))))

		; Value assignment to variable.
        `(let ,plc ,val
		   ,@(sub alst))))))

; XXX tests missing

Fix horrible bug that skipped the first assignment after accumulating functions.

;;;;; tré - Copyright (c) 2005-2011 Sven Klose <pixel@copei.de>

(defun copy-while (pred x)
  (when (and x (funcall pred (car x)))
	(cons (car x)
		  (copy-while pred (cdr x)))))

(define-test "COPY-WHILE"
  ((copy-while #'number? '(1 2 3 a)))
  '(1 2 3))

(defun separate (pred x)
  (values (copy-while pred x)
		  (remove-if pred x)))

(defmacro with (alst &rest body)
  (unless body
	(error "body expected"))
  (labels ((sub (x)
             (? x
                `((with ,x
					,@body))
                body)))
    (let* ((plc (car alst))
           (val (cadr alst)))
      (?
	    (cons? plc) `(multiple-value-bind ,plc ,val
		               ,@(sub (cddr alst)))

	    ; Accumulate this and all following functions into a LABEL,
        ; so they can call each other.
		(lambda? val) (multiple-value-bind (funs others) (separate (fn lambda? (cadr _)) (group alst 2))
		                `(labels ,(mapcar (fn `(,(car _) ,@(past-lambda (cadr _)))) funs)
			               ,@(sub (apply #'append others))))

        `(let ,plc ,val
		   ,@(sub (cddr alst)))))))

; XXX tests missing


(cl:in-package #:cleavir-hir-transformations)

(defun hir-transformations (initial-instruction implementation processor os)
  (type-inference initial-instruction)
  (eliminate-typeq initial-instruction)
  (introduce-immediates initial-instruction implementation processor os)
  (segregate-lexicals initial-instruction))

Replace segregation only by complete processing of captured variables.

(cl:in-package #:cleavir-hir-transformations)

(defun hir-transformations (initial-instruction implementation processor os)
  (type-inference initial-instruction)
  (eliminate-typeq initial-instruction)
  (introduce-immediates initial-instruction implementation processor os)
  (process-captured-variables initial-instruction))


(in-package #:laap)

(defvar *thread-pool* nil)
(defvar *loop* nil)

(defmacro with-event-loop (&body body)
  `(let* ((*thread-pool* (make-instance 'thread-pool))
	  (*loop* (make-instance 'event-loop))
	  (bt:*default-special-bindings* `((*thread-pool* . ,*thread-pool*)
					   (*loop* . ,*loop*))))
     (add-reporter (lambda (err)
		     (format t "A thread died with error: ~a~%" err)))
     (unwind-protect
	  (progn ,@body)
       (let ((thread-pool-thread (start-thread-pool)))
	 (start-event-loops)
	 (bt:join-thread thread-pool-thread)
	 (maphash (lambda (thread props)
		    (declare (ignore props))
		    (bt:join-thread thread))
		  (threads *thread-pool*))))))

(defun noop (err res)
  (declare (ignore err res)))

Fix startup by blocking threads.

(in-package #:laap)

(defvar *thread-pool* nil)
(defvar *loop* nil)

(defmacro with-event-loop (&body body)
  (let ((err (gensym))
	(res (gensym)))
    `(let* ((*thread-pool* (make-instance 'thread-pool))
	    (*loop* (make-instance 'event-loop))
	    (bt:*default-special-bindings* `((*thread-pool* . ,*thread-pool*)
					     (*loop* . ,*loop*))))
       (add-reporter (lambda (err)
		       (format t "A thread died with error: ~a~%" err)))
       (unwind-protect
	    ;; We're immediately adding to the event loop,
	    ;; so that if it starts with a blocking thread,
	    ;; it will first go through the event loop, making
	    ;; sure both the thread pool and the event loop
	    ;; threads are started.
	    (spawn (lambda (,err ,res)
		     (declare (ignore ,err ,res))
		     ,@body))
	 (let ((thread-pool-thread (start-thread-pool)))
	   (start-event-loops)
	   (bt:join-thread thread-pool-thread)
	   (maphash (lambda (thread props)
		      (declare (ignore props))
		      (bt:join-thread thread))
		    (threads *thread-pool*)))))))

(defun noop (err res)
  (declare (ignore err res)))


(in-package #:cl-user)

;;;; Copyright (c) 2008 - 2013
;;;;
;;;;     Robert Strandh (robert.strandh@gmail.com)
;;;;
;;;; all rights reserved.
;;;;
;;;; Permission is hereby granted to use this software for any
;;;; purpose, including using, modifying, and redistributing it.
;;;;
;;;; The software is provided "as-is" with no warranty.  The user of
;;;; this software assumes any responsibility of the consequences.

;;;; This file is part of the cons-high module of the SICL project.
;;;; See the file SICL.text for a description of the project.
;;;; See the file cons-high.text for a description of the module.

(asdf:defsystem :sicl-cons-high-test
  :depends-on (:sicl-cons-high)
  :components
  ((:file "test" :depends-on ())))

Define ASDF system in package ASDF-USER.

(in-package #:asdf-user)

;;;; Copyright (c) 2008 - 2013
;;;;
;;;;     Robert Strandh (robert.strandh@gmail.com)
;;;;
;;;; all rights reserved.
;;;;
;;;; Permission is hereby granted to use this software for any
;;;; purpose, including using, modifying, and redistributing it.
;;;;
;;;; The software is provided "as-is" with no warranty.  The user of
;;;; this software assumes any responsibility of the consequences.

;;;; This file is part of the cons-high module of the SICL project.
;;;; See the file SICL.text for a description of the project.
;;;; See the file cons-high.text for a description of the module.

(defsystem :sicl-cons-high-test
  :depends-on (:sicl-cons-high)
  :components
  ((:file "test" :depends-on ())))


; find the minimax analysis of a game of nim
; nim is a game where players take turns dividing a pile of discrete size
; where the player that makes an even division loses
; assume that min starts
; hence an odd number of piles mean it is min's turn

(defun play (piles)
  (when (lostp piles) ; is losing state
    (if (oddp (length piles)) ; is min's move
        1
        0)) ; is max's move
  )

; a losing state is a pile containing one or more 2's and some number of 1's
(defun lostp (piles)
  (remove-if #'(lambda (pile) (or (= 1 pile) (= 2 pile))) piles))

Check for losing state not undecided state

; find the minimax analysis of a game of nim
; nim is a game where players take turns dividing a pile of discrete size
; where the player that makes an even division loses
; assume that min starts
; hence an odd number of piles mean it is min's turn

(defun play (piles)
  (when (lostp piles) ; is losing state
    (if (oddp (length piles)) ; is min's move
        1
        0)) ; is max's move
  )

; a losing state is a pile containing one or more 2's and some number of 1's
(defun lostp (piles)
  (not (remove-if #'(lambda (pile) (or (= 1 pile) (= 2 pile))) piles)))


; bender – Copyright (c) 2014–2016 Sven Michael Klose <pixel@hugbox.org>

(def-instruction write-instruction-operand (instruction out)
  (alet operand
    (dotimes (i (instruction-operand-size instruction))
      (write-byte (mod ! 256) out)
      (= ! (>> ! 8)))))

(defun write-instruction (instruction out)
  (= *pc* (instruction-address instruction))
  (= *cycles* (instruction-cycles instruction))
  (write-byte (instruction-opcode instruction) out)
  (write-instruction-operand instruction out))

(defun write-assembled-expression (x out)
  (?
    (string? x)         (princ x out)
    (number? x)         (write-byte x out)
    (& (cons? x)
       (number? x.))    (adolist x (write-byte ! out))
    (instruction? x)    (write-instruction x out)
    (| (not x)
       (label? x)
       (assignment? x)
       (directive? x))  nil
    (write-assembled-expressions x out)))

(defun write-assembled-expressions (x out)
  (adolist x
    (with-temporary *assembler-current-line* !
      (adolist (.!)
        (let bytes (with-string-stream sout
                     (write-assembled-expression ! sout))
          (princ bytes out)
          (assemble-dump-line *pc* bytes))))))

Update program counter for data.

; bender – Copyright (c) 2014–2016 Sven Michael Klose <pixel@hugbox.org>

(def-instruction write-instruction-operand (instruction out)
  (alet operand
    (dotimes (i (instruction-operand-size instruction))
      (write-byte (mod ! 256) out)
      (= ! (>> ! 8)))))

(defun write-instruction (instruction out)
  (= *pc* (instruction-address instruction))
  (= *cycles* (instruction-cycles instruction))
  (write-byte (instruction-opcode instruction) out)
  (write-instruction-operand instruction out))

(defun write-assembled-expression (x out)
  (?
    (string? x)         (prog1 (princ x out)
                          (+! *pc* (length x)))
    (number? x)         (prog1 (write-byte x out)
                          (++! *pc*))
    (& (cons? x)
       (number? x.))    (prog1 (adolist x (write-byte ! out))
                          (+! *pc* (length x)))
    (instruction? x)    (write-instruction x out)
    (| (not x)
       (label? x)
       (assignment? x)
       (directive? x))  nil
    (write-assembled-expressions x out)))

(defun write-assembled-expressions (x out)
  (adolist x
    (with-temporary *assembler-current-line* !
      (adolist (.!)
        (let bytes (with-string-stream sout
                     (write-assembled-expression ! sout))
          (princ bytes out)
          (assemble-dump-line *pc* bytes))))))


(in-package :toolbox)
(annot:enable-annot-syntax)

@export
(defun map-positive-byte-regions (value)
  (declare (type integer value))
  (iterate
    (for i from 0 below (integer-length value))
    (for current-bit = (ldb (byte 1 i) value))
    (for prev-bit previous current-bit initially 0)
    (with start = 0)
    (cond ((and (= current-bit 0)
                (= prev-bit 1))
           (collect (list* start (- i start)) into result))
          ((= current-bit 1)
           (setf start i)))
    (finally (return result))))

@export
(defun move-byte-regions (byte-specifers moved-value)
  (declare (type (unsigned-byte 32) moved-value)
           (type byte-specifer-list byte-specifers))
  (reduce (lambda (prev next)
            (let ((starting-region (byte (- 32 (car next)) 0))
                  (shift (- (cdr next) (car next))))
              (+ (ldb starting-region prev)
                 (dpb 0 starting-region (ash prev shift)))))
          byte-specifers
          :initial-value moved-value))

@export
(defun print-as-binary (data &optional (stream t))
  (declare (type integer data))
  (format stream "~b" data)
  (terpri)
  data)

Move byte regions accepts integer.

(in-package :toolbox)
(annot:enable-annot-syntax)

@export
(defun map-positive-byte-regions (value)
  (declare (type integer value))
  (iterate
    (for i from 0 below (integer-length value))
    (for current-bit = (ldb (byte 1 i) value))
    (for prev-bit previous current-bit initially 0)
    (with start = 0)
    (cond ((and (= current-bit 0)
                (= prev-bit 1))
           (collect (list* start (- i start)) into result))
          ((= current-bit 1)
           (setf start i)))
    (finally (return result))))

@export
(defun move-byte-regions (byte-specifers moved-value)
  (declare (type integer moved-value)
           (type byte-specifer-list byte-specifers))
  (let ((length (integer-length moved-value)))
    (reduce (lambda (prev next)
              (let ((starting-region (byte (- length (car next)) 0))
                    (shift (- (cdr next) (car next))))
                (+ (ldb starting-region prev)
                   (dpb 0 starting-region (ash prev shift)))))
            byte-specifers
            :initial-value moved-value)))

@export
(defun print-as-binary (data &optional (stream t))
  (declare (type integer data))
  (format stream "~b" data)
  (terpri)
  data)


;;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RSN-MTG; Base: 10 -*- file: rsn-mtg.lisp

;;;; Copyright (c) 2013 "the Phoeron" Colin J.E. Lupton <//thephoeron.com>
;;;; See LICENSE for additional information.

(in-package :rsn-mtg)

;; EOF

Add initial-setup wrapper function to simplify configuration and syncing

;;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RSN-MTG; Base: 10 -*- file: rsn-mtg.lisp

;;;; Copyright (c) 2013 "the Phoeron" Colin J.E. Lupton <//thephoeron.com>
;;;; See LICENSE for additional information.

(in-package :rsn-mtg)

(defun initial-setup (&key (db *default-database-connection*) (verbose nil))
  "Perform the initial set-up operations to configure your web app's environment for the RSN-MTG library."
  (format t "~%;; SETTING UP YOUR ENVIRONMENT FOR RSN-MTG LIBRARY")
  (postmodern:with-connection db
    (postmodern:create-package-tables 'rsn-mtg)
    (sync-db-from-gatherer :db db :verbose verbose))
  (format t "~%;; Done.  Please restart your REDSHIFTNET-powered Web App now."))

;; EOF


(cl:in-package #:sicl-clos)

(defclass class (specializer)
  ((%unique-number
    ;; FIXME: the unique numbers should be assigned during class
    ;; finalization, and not here.
    :initform (prog1 *class-unique-number* (incf *class-unique-number*))
    :reader unique-number)
   (%name
    :initform nil
    :initarg :name
    ;; There is a specified function named (SETF CLASS-NAME), but it
    ;; is not an accessor.  Instead it works by calling
    ;; REINITIALIZE-INSTANCE with the new name.
    :reader class-name)
   (%direct-subclasses
    :initform '()
    :initarg :direct-subclasses
    :reader class-direct-subclasses
    :writer (setf c-direct-subclasses))))

Use accessor rather than separate reader and writer.

(cl:in-package #:sicl-clos)

(defclass class (specializer)
  ((%unique-number
    ;; FIXME: the unique numbers should be assigned during class
    ;; finalization, and not here.
    :initform (prog1 *class-unique-number* (incf *class-unique-number*))
    :reader unique-number)
   (%name
    :initform nil
    :initarg :name
    ;; There is a specified function named (SETF CLASS-NAME), but it
    ;; is not an accessor.  Instead it works by calling
    ;; REINITIALIZE-INSTANCE with the new name.
    :reader class-name)
   (%direct-subclasses
    :initform '()
    :initarg :direct-subclasses
    :accessor class-direct-subclasses)))


(cl:in-package #:sicl-boot)

(defun create-bridge-classes (boot)
  (let ((c (c1 boot))
	(r (r2 boot)))
    (ld "../CLOS/t-defclass.lisp" c r)
    (ld "../CLOS/standard-object-defclass.lisp" c r)
    (ld "../CLOS/metaobject-defclass.lisp" c r)
    (ld "../CLOS/method-combination-defclass.lisp" c r)
    (ld "../CLOS/slot-definition-defclass.lisp" c r)
    (ld "../CLOS/specializer-defclass.lisp" c r)
    (ld "../CLOS/class-defclass.lisp" c r)
    (ld "../CLOS/forward-referenced-class-defclass.lisp" c r)
    (ld "../CLOS/real-class-defclass.lisp" c r)
    (ld "../CLOS/regular-class-defclass.lisp" c r)
    (ld "../CLOS/built-in-class-defclass.lisp" c r)
    (ld "../CLOS/standard-class-defclass.lisp" c r)
    (ld "../CLOS/funcallable-standard-class-defclass.lisp" c r)))

Load a file containing the definition of STANDARD-SLOT-DEFINITION.

(cl:in-package #:sicl-boot)

(defun create-bridge-classes (boot)
  (let ((c (c1 boot))
	(r (r2 boot)))
    (ld "../CLOS/t-defclass.lisp" c r)
    (ld "../CLOS/standard-object-defclass.lisp" c r)
    (ld "../CLOS/metaobject-defclass.lisp" c r)
    (ld "../CLOS/method-combination-defclass.lisp" c r)
    (ld "../CLOS/slot-definition-defclass.lisp" c r)
    (ld "../CLOS/standard-slot-definition-defclass.lisp" c r)
    (ld "../CLOS/specializer-defclass.lisp" c r)
    (ld "../CLOS/class-defclass.lisp" c r)
    (ld "../CLOS/forward-referenced-class-defclass.lisp" c r)
    (ld "../CLOS/real-class-defclass.lisp" c r)
    (ld "../CLOS/regular-class-defclass.lisp" c r)
    (ld "../CLOS/built-in-class-defclass.lisp" c r)
    (ld "../CLOS/standard-class-defclass.lisp" c r)
    (ld "../CLOS/funcallable-standard-class-defclass.lisp" c r)))


(cl:in-package #:asdf-user)

(defsystem clump
  :description "Library for operations on different kinds of trees"
  :author "Robert Strandh <robert.strandh@gmail.com>"
  :license "FreeBSD, see file LICENSE.text"
  :depends-on (:clump-binary-tree))

Add CLUMP-2-3-TREE as a dependency for system CLUMP.

(cl:in-package #:asdf-user)

(defsystem clump
  :description "Library for operations on different kinds of trees"
  :author "Robert Strandh <robert.strandh@gmail.com>"
  :license "FreeBSD, see file LICENSE.text"
  :depends-on (:clump-binary-tree :clump-2-3-tree))


(cl:in-package #:sicl-boot)

(defun customize-c1 (boot)
  (message "Customizing compilation environment C1~%")
  (message "Finished customizing compilation environment C1~%"))

Define a custom version of DEFGENERIC in compilation environment C1.

(cl:in-package #:sicl-boot)

(defun define-defgeneric-c1 (boot)
  (setf (sicl-genv:macro-function 'defgeneric (c1 boot))
	(lambda (form environment)
	  (declare (ignore environment))
	  `(progn (sicl-genv:fmakunbound ',(car form) ,(r1 boot))
		  (ensure-generic-function
		   ',(car form)
		   :name ',(car form)
		   :lambda-list ',(cadr form))
		  (setf (sicl-genv:fdefinition ',(car form) ,(c1 boot))
			(sicl-genv:fdefinition ',(car form) ,(r1 boot)))))))

(defun customize-c1 (boot)
  (message "Customizing compilation environment C1~%")
  (define-defgeneric-c1 boot)
  (message "Finished customizing compilation environment C1~%"))


;;;; zcdb.asd

(asdf:defsystem #:zcdb
  :serial t
                    :version "1.0.3"
  :description "Read and write cdb files, as specified in
  http://cr.yp.to/cdb.html"
  :author "Zach Beane <xach@xach.com>"
  :components ((:file "package")
               (:file "cdb")
               (:file "reading")
               (:file "writing")))

Add :license to system file

;;;; zcdb.asd

(asdf:defsystem #:zcdb
  :serial t
  :version "1.0.3"
  :description "Read and write cdb files, as specified in
  http://cr.yp.to/cdb.html"
  :author "Zach Beane <xach@xach.com>"
  :license "MIT"
  :components ((:file "package")
               (:file "cdb")
               (:file "reading")
               (:file "writing")))


(cl:in-package #:clump-binary-tree)

;;; Make CHILD the left child of NODE.
(defgeneric link-left (node child))

;;; Make CHILD the right child of NODE.
(defgeneric link-right (node child))

;;; Remove CHILD as the left child of NODE.
(defgeneric unlink-left (node child))

;;; Remove CHILD as the right child of NODE.
(defgeneric unlink-right (node child))

Rename parent parameter for improved readability.

(cl:in-package #:clump-binary-tree)

;;; Make CHILD the left child of NODE.
(defgeneric link-left (parent child))

;;; Make CHILD the right child of PARENT.
(defgeneric link-right (parent child))

;;; Remove CHILD as the left child of PARENT.
(defgeneric unlink-left (parent child))

;;; Remove CHILD as the right child of PARENT.
(defgeneric unlink-right (parent child))


;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-

(eval-when (:compile-toplevel :load-toplevel :execute)
  (asdf:oos 'asdf:load-op :cffi-grovel))

;;; Fix ecl long-long support
#+(and ecl (or cffi-features:no-long-long cffi-sys::no-long-long))
(defmethod perform :after ((o load-op) (c (eql (find-system :cffi))))
  (let* ((s (find-system :iolib.termios))
         (f (find-component s "ecl-long-long-fix")))
    (oos 'load-op f)))

(defsystem :iolib.termios
  :description "Termios (3p) api wrappers"
  :maintainer "Razbegaev N.V. <marsijanin@gmail.com>"
  :licence "MIT"
  :depends-on (:iolib.base :iolib.syscalls :iolib.streams :cffi :cffi-grovel :trivial-garbage)
  :components
  #+unix
  (#+ecl
   (:file "ecl-long-long-fix")
   (:file "pkgdcl")
   (cffi-grovel:grovel-file "ffi-termios-types-unix")
   (cffi-grovel:grovel-file "ffi-termios-constants-unix")
   (:file "ffi-termios-functions-unix")
   (:file "conditions")
   (:file "wrappers")
   (:file "streams")))
;;;; EOF

Fix system names (slash instead of dot)

;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-

(eval-when (:compile-toplevel :load-toplevel :execute)
  (asdf:oos 'asdf:load-op :cffi-grovel))

;;; Fix ecl long-long support
#+(and ecl (or cffi-features:no-long-long cffi-sys::no-long-long))
(defmethod perform :after ((o load-op) (c (eql (find-system :cffi))))
  (let* ((s (find-system :iolib.termios))
         (f (find-component s "ecl-long-long-fix")))
    (oos 'load-op f)))

(defsystem :iolib.termios
  :description "Termios (3p) api wrappers"
  :maintainer "Razbegaev N.V. <marsijanin@gmail.com>"
  :licence "MIT"
  :depends-on (:iolib/base :iolib/syscalls :iolib/streams :cffi :cffi-grovel :trivial-garbage)
  :components
  #+unix
  (#+ecl
   (:file "ecl-long-long-fix")
   (:file "pkgdcl")
   (cffi-grovel:grovel-file "ffi-termios-types-unix")
   (cffi-grovel:grovel-file "ffi-termios-constants-unix")
   (:file "ffi-termios-functions-unix")
   (:file "conditions")
   (:file "wrappers")
   (:file "streams")))
;;;; EOF


;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
;;;
;;; --- Resolver conditions.
;;;

(in-package :iolib.sockets)

(define-condition resolver-error ()
  ((datum :initarg :data :reader resolver-error-datum))
  (:documentation
   "Signaled when an error occurs while trying to resolve an address."))
(setf (documentation 'resolver-error-datum 'function)
      "Return the datum that caused the signalling of a RESOLVER-ERROR condition.")

(defmacro define-resolver-error (name format-string &optional documentation)
  `(define-condition ,name (resolver-error) ()
     (:report (lambda (condition stream)
                (format stream ,format-string (resolver-error-datum condition))))
     (:documentation ,documentation)))

(define-resolver-error resolver-again-error
  "Temporary failure occurred while resolving: ~S"
  "Condition signaled when a temporary failure occurred.")

(define-resolver-error resolver-fail-error
  "Non recoverable error occurred while resolving: ~S"
  "Condition signaled when a non-recoverable error occurred.")

(define-resolver-error resolver-no-name-error
  "Host or service not found: ~S"
  "Condition signaled when a host or service was not found.")

(define-resolver-error resolver-unknown-error
  "Unknown error while resolving: ~S"
  "Condition signaled when an unknown error is signaled while resolving
an address.")

Make RESOLVER-ERROR a subtype of ERROR.

;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
;;;
;;; --- Resolver conditions.
;;;

(in-package :iolib.sockets)

(define-condition resolver-error (error)
  ((datum :initarg :data :reader resolver-error-datum))
  (:documentation
   "Signaled when an error occurs while trying to resolve an address."))
(setf (documentation 'resolver-error-datum 'function)
      "Return the datum that caused the signalling of a RESOLVER-ERROR condition.")

(defmacro define-resolver-error (name format-string &optional documentation)
  `(define-condition ,name (resolver-error) ()
     (:report (lambda (condition stream)
                (format stream ,format-string (resolver-error-datum condition))))
     (:documentation ,documentation)))

(define-resolver-error resolver-again-error
  "Temporary failure occurred while resolving: ~S"
  "Condition signaled when a temporary failure occurred.")

(define-resolver-error resolver-fail-error
  "Non recoverable error occurred while resolving: ~S"
  "Condition signaled when a non-recoverable error occurred.")

(define-resolver-error resolver-no-name-error
  "Host or service not found: ~S"
  "Condition signaled when a host or service was not found.")

(define-resolver-error resolver-unknown-error
  "Unknown error while resolving: ~S"
  "Condition signaled when an unknown error is signaled while resolving
an address.")


(cl:in-package #:sicl-boot-phase2)

(cl:defclass bridge-generic-function
    (#+sbcl sb-pcl:funcallable-standard-object
     sicl-boot-phase1:standard-generic-function)
  ()
  (:metaclass #+sbcl sb-pcl:funcallable-standard-class))

(cl:defmethod cl:print-object ((object bridge-generic-function) stream)
  (print-unreadable-object (object stream :type t)
    (format stream "~s" (cl:slot-value object '%name))))

Update package name to reflect move from phase 2 to phase 1.

(cl:in-package #:sicl-boot-phase1)

(cl:defclass bridge-generic-function
    (#+sbcl sb-pcl:funcallable-standard-object
     sicl-boot-phase1:standard-generic-function)
  ()
  (:metaclass #+sbcl sb-pcl:funcallable-standard-class))

(cl:defmethod cl:print-object ((object bridge-generic-function) stream)
  (print-unreadable-object (object stream :type t)
    (format stream "~s" (cl:slot-value object '%name))))


(in-package #:eloquent.mvc.middleware)

(defun make-static-file (path-info prefix root)
  (let ((path (remove-prefix prefix path-info)))
    (merge-pathnames path
                     (merge-pathnames "static/" root))))

(defun get-prefix (config)
  (eloquent.mvc.config:get config "static-file" "prefix"))

(defun remove-prefix (prefix s)
  (subseq s (length prefix)))

(defun static-file (request next
                    &key config)
  "When the path-info of REQUEST matches the prefix specified in CONFIG's [static-file] section, feed the client a static file."
  (let ((path-info (eloquent.mvc.request:request-path-info request))
        (prefix (get-prefix config))
        (root (eloquent.mvc.config:get-application-root config)))
    (if (alexandria:starts-with-subseq prefix path-info)
        (let ((filespec (make-static-file path-info prefix root)))
          (if (probe-file filespec)
              (eloquent.mvc.response:respond filespec)
              (eloquent.mvc.router:not-found request)))
        (funcall next request))))

Remove the call of NOT-FOUND function from router

(in-package #:eloquent.mvc.middleware)

(defun make-static-file (path-info prefix root)
  (let ((path (remove-prefix prefix path-info)))
    (merge-pathnames path
                     (merge-pathnames "static/" root))))

(defun get-prefix (config)
  (eloquent.mvc.config:get config "static-file" "prefix"))

(defun remove-prefix (prefix s)
  (subseq s (length prefix)))

(defun static-file (request next
                    &key config)
  "When the path-info of REQUEST matches the prefix specified in CONFIG's [static-file] section, feed the client a static file."
  (let ((path-info (eloquent.mvc.request:request-path-info request))
        (prefix (get-prefix config))
        (root (eloquent.mvc.config:get-application-root config)))
    (if (alexandria:starts-with-subseq prefix path-info)
        (let ((filespec (make-static-file path-info prefix root)))
          (eloquent.mvc.response:respond filespec))
        (funcall next request))))


;;;; -*- Mode: LISP; Syntax: COMMON-LISP; indent-tabs-mode: nil; coding: utf-8; show-trailing-whitespace: t -*-
;;;; Copyright (C) 2011 Anton Vodonosov (avodonosov@yandex.ru)
;;;; See LICENSE for details.

;;;; Preventing more than one agent to run in parallel.
;;;; This is important, becuase the agents will
;;;; interfere via working directory file system,
;;;; at least via persistence.lisp.
;;;;
;;;; Implemented by opening a socket on a constant port.
;;;; If it is successful - we are the only running agent,
;;;; otherwise another agent instance is running.

(in-package #:test-grid-agent)

(defparameter +singleton-agent-lock-port+ 7658)

(define-condition another-agent-is-running (simple-error) ())

(defun execute-as-singleton-agent (body-func)
  (handler-case
      (let ((s (usocket:socket-listen "localhost" +singleton-agent-lock-port+)))
        (unwind-protect (funcall body-func)
          (usocket:socket-close s)))
    (usocket:address-in-use-error ()
      (error 'another-agent-is-running
             :format-control "Another agent seems to be already running - our \"lock\" TCP port ~A is already in use."
             :format-arguments (list +singleton-agent-lock-port+)))))

(defmacro as-singleton-agent (&body body)
  `(execute-as-singleton-agent (lambda () ,@body)))

Change singleton agent "lock" port number to avoid conflict with some Windows service.

;;;; -*- Mode: LISP; Syntax: COMMON-LISP; indent-tabs-mode: nil; coding: utf-8; show-trailing-whitespace: t -*-
;;;; Copyright (C) 2011 Anton Vodonosov (avodonosov@yandex.ru)
;;;; See LICENSE for details.

;;;; Preventing more than one agent to run in parallel.
;;;; This is important, becuase the agents will
;;;; interfere via working directory file system,
;;;; at least via persistence.lisp.
;;;;
;;;; Implemented by opening a socket on a constant port.
;;;; If it is successful - we are the only running agent,
;;;; otherwise another agent instance is running.

(in-package #:test-grid-agent)

(defparameter +singleton-agent-lock-port+ 7685)

(define-condition another-agent-is-running (simple-error) ())

(defun execute-as-singleton-agent (body-func)
  (handler-case
      (let ((s (usocket:socket-listen "localhost" +singleton-agent-lock-port+)))
        (unwind-protect (funcall body-func)
          (usocket:socket-close s)))
    (usocket:address-in-use-error ()
      (error 'another-agent-is-running
             :format-control "Another agent seems to be already running - our \"lock\" TCP port ~A is already in use."
             :format-arguments (list +singleton-agent-lock-port+)))))

(defmacro as-singleton-agent (&body body)
  `(execute-as-singleton-agent (lambda () ,@body)))


(cl:in-package #:sicl-clos)

;;; FIXME: I can not remember why I decided not to use initargs for
;;; the slots here, and instead calling explicit writers in :AFTER
;;; methods on INITIALIZE-INSTANCE and REINITIALIZE-INSTANCE.

(defclass generic-function (metaobject funcallable-standard-object)
  (;; While there is a function named (SETF GENERIC-FUNCTION-NAME), it
   ;; is not a writer function in that it works by calling
   ;; REINITIALIZE-INSTANCE.
   (%name
    :initform nil
    :initarg :name
    :reader generic-function-name)
   (%lambda-list
    :initarg :lambda-list
    :reader generic-function-lambda-list)
   (%documentation
    :initarg :documentation
    :initform nil
    :accessor documentation)
   (%dependents
    :initform '()
    :accessor dependents))
  (:metaclass funcallable-standard-class))

Add copyright dates and license statement.

;;;; Copyright (c) 2013 - 2015
;;;;
;;;;     Robert Strandh (robert.strandh@gmail.com)
;;;;
;;;; All rights reserved.
;;;;
;;;; Redistribution and use in source and binary forms, with or
;;;; without modification, are permitted provided that the following
;;;; conditions are met:
;;;;
;;;; 1. Redistributions of source code must retain the above copyright
;;;;    notice, this list of conditions and the following disclaimer.
;;;; 2. Redistributions in binary form must reproduce the above
;;;;    copyright notice, this list of conditions and the following
;;;;    disclaimer in the documentation and/or other materials
;;;;    provided with the distribution.
;;;;
;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND
;;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
;;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
;;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS
;;;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
;;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
;;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
;;;; ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
;;;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
;;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
;;;; POSSIBILITY OF SUCH DAMAGE.

(cl:in-package #:sicl-clos)

;;; FIXME: I can not remember why I decided not to use initargs for
;;; the slots here, and instead calling explicit writers in :AFTER
;;; methods on INITIALIZE-INSTANCE and REINITIALIZE-INSTANCE.

(defclass generic-function (metaobject funcallable-standard-object)
  (;; While there is a function named (SETF GENERIC-FUNCTION-NAME), it
   ;; is not a writer function in that it works by calling
   ;; REINITIALIZE-INSTANCE.
   (%name
    :initform nil
    :initarg :name
    :reader generic-function-name)
   (%lambda-list
    :initarg :lambda-list
    :reader generic-function-lambda-list)
   (%documentation
    :initarg :documentation
    :initform nil
    :accessor documentation)
   (%dependents
    :initform '()
    :accessor dependents))
  (:metaclass funcallable-standard-class))


(defpackage #:dynamic-classes-system (:use #:common-lisp #:asdf))
(in-package #:dynamic-classes-system)

(defsystem dynamic-classes
  :author "Gary Warren King <gwking@metabang.com>"
  :version "1.0.1"
  :maintainer "Gary Warren King <gwking@metabang.com>"
  :licence "MIT Style license"
  :components ((:module
		"dev"
		:serial t
		:components ((:file "package")
			     (:file "utilities")
			     (:file "define-class")
			     (:file "dynamic-class"))))
  :depends-on (:metatilities-base))

Add the usual test boilerplate to the system file

(defpackage #:dynamic-classes-system (:use #:common-lisp #:asdf))
(in-package #:dynamic-classes-system)

(defsystem dynamic-classes
  :author "Gary Warren King <gwking@metabang.com>"
  :version "1.0.1"
  :maintainer "Gary Warren King <gwking@metabang.com>"
  :licence "MIT Style license"
  :components ((:module
		"dev"
		:serial t
		:components ((:file "package")
			     (:file "utilities")
			     (:file "define-class")
			     (:file "dynamic-class"))))
  :in-order-to ((test-op (load-op dynamic-classes-test)))
  :perform (test-op :after (op c)
		    (funcall (intern (symbol-name '#:run-tests) :lift)
			     :config :generic))
  :depends-on (:metatilities-base))

(defmethod operation-done-p
           ((o test-op) (c (eql (find-system 'dynamic-classes))))
  (values nil))


(in-package :sicl-arithmetic)

(defun + (&rest args)
  (cond ((null args) 0)
	;; FIXME: check that we have a number
	((null (cdr args)) (car args))
	(t (apply #'+ (binary-+ (car args) (cadr args)) (cddr args)))))

(defun - (x &rest args)
  (cond ((null args) (negate x))
	((null (cdr args)) (binary-- x (car args)))
	(t (apply #'- (binary-- x (car args)) (cdr args)))))

(defun * (&rest args)
  (cond ((null args) 1)
	;; FIXME: check that we have a number
	((null (cdr args)) (car args))
	(t (apply #'* (binary-* (car args) (cadr args)) (cddr args)))))

(defun / (x &rest args)
  (cond ((null args) (invert x))
	((null (cdr args)) (binary-/ x (car args)))
	(t (apply #'/ (binary-/ x (car args)) (cdr args)))))

Use explicit package prefix for IN-PACKAGE.

(cl:in-package :sicl-arithmetic)

(defun + (&rest args)
  (cond ((null args) 0)
	;; FIXME: check that we have a number
	((null (cdr args)) (car args))
	(t (apply #'+ (binary-+ (car args) (cadr args)) (cddr args)))))

(defun - (x &rest args)
  (cond ((null args) (negate x))
	((null (cdr args)) (binary-- x (car args)))
	(t (apply #'- (binary-- x (car args)) (cdr args)))))

(defun * (&rest args)
  (cond ((null args) 1)
	;; FIXME: check that we have a number
	((null (cdr args)) (car args))
	(t (apply #'* (binary-* (car args) (cadr args)) (cddr args)))))

(defun / (x &rest args)
  (cond ((null args) (invert x))
	((null (cdr args)) (binary-/ x (car args)))
	(t (apply #'/ (binary-/ x (car args)) (cdr args)))))


(cl:in-package #:sicl-data-and-control-flow)

(defmethod cleavir-i18n:report-condition
    ((condition odd-number-of-arguments-to-setf)
     stream
     (langauge cleavir-i18n:english))
  (format stream
	  "An odd number of arguments was given to SETF~@
           in the following form:~@
           ~s"
          (form condition)))

(defmethod cleavir-i18n:report-condition
    ((condition odd-number-of-arguments-to-psetf)
     stream
     (langauge cleavir-i18n:english))
  (format stream
	  "An odd number of arguments was given to PSETF~@
           in the following form:~@
           ~s"
          (form condition)))

Add condition reporter for new condition.

(cl:in-package #:sicl-data-and-control-flow)

(defmethod cleavir-i18n:report-condition
    ((condition odd-number-of-arguments-to-setf)
     stream
     (langauge cleavir-i18n:english))
  (format stream
	  "An odd number of arguments was given to SETF~@
           in the following form:~@
           ~s"
          (form condition)))

(defmethod cleavir-i18n:report-condition
    ((condition odd-number-of-arguments-to-psetf)
     stream
     (langauge cleavir-i18n:english))
  (format stream
	  "An odd number of arguments was given to PSETF~@
           in the following form:~@
           ~s"
          (form condition)))

(defmethod cleavir-i18n:report-condition
    ((condition odd-number-of-arguments-to-psetq)
     stream
     (langauge cleavir-i18n:english))
  (format stream
	  "An odd number of arguments was given to PSETQ~@
           in the following form:~@
           ~s"
          (form condition)))


(in-package :mu-cl-resources)

(add-prefix "nie" "http://www.semanticdesktop.org/ontologies/2007/01/19/nie/#")
(add-prefix "nco" "http://www.semanticdesktop.org/ontologies/2007/03/22/nco#")
(add-prefix "nfo" "http://www.semanticdesktop.org/ontologies/2007/03/22/nfo#")
(add-prefix "dcterms" "http://purl.org/dc/terms/")
(add-prefix "vcard" "http://www.w3.org/2006/vcard/ns#")
(add-prefix "locn" "http://www.w3.org/ns/locn#")
(add-prefix "music" "http://mu.semte.ch/vocabularies/music/")
(add-prefix "bravoer" "http://mu.semte.ch/vocabularies/bravoer/")

;; Required namespaces for authorization
(add-prefix "auth" "http://mu.semte.ch/vocabularies/authorization/")
(add-prefix "session" "http://mu.semte.ch/vocabularies/session/")
(add-prefix "authToken" "http://mu.semte.ch/services/authorization-service/access-tokens/")

Change namespace of custom vocabularies music and bravoer

(in-package :mu-cl-resources)

(add-prefix "nie" "http://www.semanticdesktop.org/ontologies/2007/01/19/nie/#")
(add-prefix "nco" "http://www.semanticdesktop.org/ontologies/2007/03/22/nco#")
(add-prefix "nfo" "http://www.semanticdesktop.org/ontologies/2007/03/22/nfo#")
(add-prefix "dcterms" "http://purl.org/dc/terms/")
(add-prefix "vcard" "http://www.w3.org/2006/vcard/ns#")
(add-prefix "locn" "http://www.w3.org/ns/locn#")
(add-prefix "music" "http://mu.semte.ch/vocabularies/ext/music/")
(add-prefix "bravoer" "http://mu.semte.ch/vocabularies/ext/bravoer/")

;; Required namespaces for authorization
(add-prefix "auth" "http://mu.semte.ch/vocabularies/authorization/")
(add-prefix "session" "http://mu.semte.ch/vocabularies/session/")
(add-prefix "authToken" "http://mu.semte.ch/services/authorization-service/access-tokens/")


(cl:in-package #:clump-binary-tree)

(defgeneric iterative-traversal (tree enter leave))

(defmethod iterative-traversal ((tree node-with-parent) enter leave)
  (let ((current-node tree))
    (loop do (if (or (not (funcall enter current-node))
		     (and (null (left current-node))
			  (null (right current-node))))
		 (loop for parent = (parent current-node)
		       until (or (null parent)
				 (and (eq current-node (left parent))
				      (not (null (right parent)))))
		       do (funcall leave current-node)
			  (setf current-node parent)
		       finally (if (null parent)
				   (return-from iterative-traversal)
				   (setf current-node (right parent))))
		 (setf current-node
		       (or (left current-node)
			   (right current-node)))))))

Call function LEAVE before returning or entering right subtree.

(cl:in-package #:clump-binary-tree)

(defgeneric iterative-traversal (tree enter leave))

(defmethod iterative-traversal ((tree node-with-parent) enter leave)
  (let ((current-node tree))
    (loop do (if (or (not (funcall enter current-node))
		     (and (null (left current-node))
			  (null (right current-node))))
		 (loop for parent = (parent current-node)
		       until (or (null parent)
				 (and (eq current-node (left parent))
				      (not (null (right parent)))))
		       do (funcall leave current-node)
			  (setf current-node parent)
		       finally (funcall leave current-node)
			       (if (null parent)
				   (return-from iterative-traversal)
				   (setf current-node (right parent))))
		 (setf current-node
		       (or (left current-node)
			   (right current-node)))))))


(in-package :asdf-user)

(defsystem "bytecurry.asdf-ext"
  :class :package-inferred-system
  :author "Thayne McCombs"
  :maintainer "Thayne McCombs"
  :mailto "bytecurry.software@gmail.com"
  :defsystem-depends-on (:asdf-package-system)
  :depends-on (:bytecurry.asdf-ext/doc-op :bytecurry.asdf-ext/atdoc))

Add license attribute to asdf file.

(in-package :asdf-user)

(defsystem "bytecurry.asdf-ext"
  :class :package-inferred-system
  :author "Thayne McCombs"
  :maintainer "Thayne McCombs"
  :mailto "bytecurry.software@gmail.com"
  :license "MIT"
  :defsystem-depends-on (:asdf-package-system)
  :depends-on (:bytecurry.asdf-ext/doc-op :bytecurry.asdf-ext/atdoc))


; tré – Copyright (c) 2011–2013,2015 Sven Michael Klose <pixel@copei.de>

(define-expander 'standard-macros)
(set-expander-macros 'standard-macros *macros*)
(= *standard-macro-expander* (expander-get 'standard-macros))

(defun %%macro? (x)
  (expander-has-macro? 'standard-macros x.))

(defun %%macrocall (x)
  (funcall (expander-call *standard-macro-expander*) x))

(defvar *environment-macros* (copy-alist *macros*))
(define-expander 'environment-macros)
(set-expander-macros 'environment-macros *environment-macros*)
(defvar *environment-macro-expander* (expander-get 'environment-macros))

(defun %%env-macro? (x)
  (expander-has-macro? 'environment-macros x.))

(defun %%env-macrocall (x)
  (funcall (expander-call *environment-macro-expander*) x))

(= *macroexpand-backquote* #'%macroexpand-backquote)

Add comment about possibly useless *ENVIRONMENT-MACROS*.

; tré – Copyright (c) 2011–2013,2015 Sven Michael Klose <pixel@copei.de>

(define-expander 'standard-macros)
(set-expander-macros 'standard-macros *macros*)
(= *standard-macro-expander* (expander-get 'standard-macros))

(defun %%macro? (x)
  (expander-has-macro? 'standard-macros x.))

(defun %%macrocall (x)
  (funcall (expander-call *standard-macro-expander*) x))

; XXX I assume this is some work-around for some fixed xhost
; macroexpansion issue and can be removed safely. (pixel)

(defvar *environment-macros* (copy-alist *macros*))
(define-expander 'environment-macros)
(set-expander-macros 'environment-macros *environment-macros*)
(defvar *environment-macro-expander* (expander-get 'environment-macros))

(defun %%env-macro? (x)
  (expander-has-macro? 'environment-macros x.))

(defun %%env-macrocall (x)
  (funcall (expander-call *environment-macro-expander*) x))

(= *macroexpand-backquote* #'%macroexpand-backquote)


(in-package :cl-user)

(defpackage :med-asd
  (:use :cl :asdf))

(in-package :med-asd)

(defsystem :med
  :version "0.1"
  :description "med - Mezzano EDitor"
  :serial t
  :components ((:file "package")
               (:file "line")
               (:file "mark")
               (:file "editor")
               (:file "buffer")
               (:file "point")
               (:file "minibuffer")
               (:file "redisplay")
               (:file "commands")
               (:file "keybindings")
               (:file "main")))

Add grep to asd file.'

(in-package :cl-user)

(defpackage :med-asd
  (:use :cl :asdf))

(in-package :med-asd)

(defsystem :med
  :version "0.1"
  :description "med - Mezzano EDitor"
  :serial t
  :components ((:file "package")
               (:file "line")
               (:file "mark")
               (:file "editor")
               (:file "buffer")
               (:file "point")
               (:file "redisplay")
               (:file "commands")
               (:file "keybindings")
               (:file "minibuffer")
               (:file "repl")
               (:file "main")))


(cl:in-package #:cleavir-cst)

(defclass optional-or-keyword--parameter ()
  (;; This slot contains the CST for the obligatory variable of the
   ;; parameter.
   (%variable-cst :initarg :variable-cst :reader variable-cst)
   ;; This slot contains a CST for the INIT-FORM of the parameter.  If
   ;; no INIT-FORM was supplied, then this slot contains a CST for
   ;; which both EXPRESSION and LOCATION return NIL.
   (%init-form-cst :initarg :init-form-cst :reader init-form-cst)
   ;; This slot contains a CST for the SUPPLIED-P-PARAMETER of the
   ;; parameter.  If no SUPPLIED-P-PARAMETER was given, then this slot
   ;; contains NIL.
   (%supplied-p-parameter-cst :initarg :supplied-p-parameter-cst
			      :reader supplied-p-parameter-cst)))

(defclass optional-parameters ()
  (;; This slot contains a CST for the lambda-list keyword.
   ;; Typically, this keyword will be &OPTIONAL, but client code may
   ;; define other lambda-list keywords that work the same way as
   ;; &OPTIONAL.
   (%keyword-cst :initarg :keyword-cst :reader keyword-cst)
   ;; This slot contains a list of instances of the class
   ;; OPTIONAL-PARAMETER.
   (%parameters :initarg :parameters :reader parameters)))

Define new class OPTIONAL-PARAMETER using generalized class as superclass.

(cl:in-package #:cleavir-cst)

(defclass optional-or-keyword--parameter ()
  (;; This slot contains the CST for the obligatory variable of the
   ;; parameter.
   (%variable-cst :initarg :variable-cst :reader variable-cst)
   ;; This slot contains a CST for the INIT-FORM of the parameter.  If
   ;; no INIT-FORM was supplied, then this slot contains a CST for
   ;; which both EXPRESSION and LOCATION return NIL.
   (%init-form-cst :initarg :init-form-cst :reader init-form-cst)
   ;; This slot contains a CST for the SUPPLIED-P-PARAMETER of the
   ;; parameter.  If no SUPPLIED-P-PARAMETER was given, then this slot
   ;; contains NIL.
   (%supplied-p-parameter-cst :initarg :supplied-p-parameter-cst
			      :reader supplied-p-parameter-cst)))

(defclass optional-parameter (optional-or-keyword-parameter)
  ())

(defclass optional-parameters ()
  (;; This slot contains a CST for the lambda-list keyword.
   ;; Typically, this keyword will be &OPTIONAL, but client code may
   ;; define other lambda-list keywords that work the same way as
   ;; &OPTIONAL.
   (%keyword-cst :initarg :keyword-cst :reader keyword-cst)
   ;; This slot contains a list of instances of the class
   ;; OPTIONAL-PARAMETER.
   (%parameters :initarg :parameters :reader parameters)))


(in-package #:cl-user)

(asdf:defsystem :sicl-sequences-small-test
  :depends-on (:lisp-unit :sicl-sequences-small)
  :components
  ((:file "test" :depends-on ())))

Define ASDF system in package ASDF-USER.

(cl:in-package #:asdf-user)

(defsystem :sicl-sequences-small-test
  :depends-on (:lisp-unit :sicl-sequences-small)
  :components
  ((:file "test" :depends-on ())))


(cl:in-package #:asdf-user)

(defsystem :sicl-clos-support
  :depends-on (:sicl-clos-package
	       :sicl-global-environment)
  :serial t
  :components
  ((:file "ensure-generic-function-using-class-support")
   (:file "make-method-lambda-support")
   (:file "make-method-lambda-defgenerics")
   (:file "make-method-lambda-defmethods")
   (:file "defmethod-support")
   (:file "ensure-method")))

Include support code for ENSURE-CLASS-USING-CLASS.

(cl:in-package #:asdf-user)

(defsystem :sicl-clos-support
  :depends-on (:sicl-clos-package
	       :sicl-global-environment)
  :serial t
  :components
  ((:file "ensure-generic-function-using-class-support")
   (:file "make-method-lambda-support")
   (:file "make-method-lambda-defgenerics")
   (:file "make-method-lambda-defmethods")
   (:file "defmethod-support")
   (:file "ensure-method")
   (:file "ensure-class-using-class-support")))


(cl:in-package #:asdf-user)

(defsystem clump
  :depends-on (:clump-binary-tree))

Add initargs for :DESCRIPTION, :AUTHOR, and :LICENSE.

(cl:in-package #:asdf-user)

(defsystem clump
  :description "Library for operations on different kinds of trees"
  :author "Robert Strandh <robert.strandh@gmail.com>"
  :license "FreeBSD, see file LICENSE.text"
  :depends-on (:clump-binary-tree))


(defpackage #:info.isoraqathedh.umpns.asdf
  (:use #:cl #:asdf))
(in-package #:info.isoraqathedh.umpns.asdf)

(defsystem umpns
  :name "UMPNS-based Minor Planet Namer"
  :version "0.1"
  :license "MIT"
  :components ((:file "unified-minor-planet-naming-system"))
  :depends-on (:cl-ppcre :sqlite :iterate))

Add local-time to the list of deps

(defpackage #:info.isoraqathedh.umpns.asdf
  (:use #:cl #:asdf))
(in-package #:info.isoraqathedh.umpns.asdf)

(defsystem umpns
  :name "UMPNS-based Minor Planet Namer"
  :version "0.1"
  :license "MIT"
  :components ((:file "unified-minor-planet-naming-system"))
  :depends-on (:cl-ppcre :sqlite :iterate :local-time))


(test-directories ".")

(test

 ("Bug 0099 : Extra 'let' in generated proof obligation"
  :show   "MinusOb#MinusProof"
  :output ";;; Elaborating proof-term at $TESTDIR/MinusOb#MinusProof
;;; Elaborating obligator at $TESTDIR/MinusOb#ONat
;; ensure-directories-exist: creating $TESTDIR/Snark/MinusOb/MinusProof.log
;; Directory $TESTDIR/Snark/ does not exist, will create.
;; Directory $TESTDIR/Snark/MinusOb/ does not exist, will create.
MinusProof: Conjecture minus_def2_Obligation in ONat is Proved! using Snark.
    Snark Log file: $TESTDIR/Snark/MinusOb/MinusProof.log

")

 )

Adjust output of test case to new behavior.

(test-directories ".")

(test

 ("Bug 0099 : Extra 'let' in generated proof obligation"
  :show   "MinusOb#MinusProof"
  :output '(
	    ";;; Elaborating proof-term at $TESTDIR/MinusOb#MinusProof"
	    ";;; Elaborating obligator at $TESTDIR/MinusOb#ONat"
	    "    Expanded spec file: $TESTDIR/Snark/MinusOb/MinusProof.sw"
	    "    Snark Log file: $TESTDIR/Snark/MinusOb/MinusProof.log"
	    "MinusProof: Conjecture minus_def2_Obligation in ONat is Proved! using Snark."
	    ""
	    ""
	    ""))

 )


(cl:in-package #:sicl-data-and-control-flow)

(defun fdefinition (function-name)
  (sicl-global-environment:fdefinition
   function-name
   sicl-global-environment:*global-environment*))

Use function GLOBAL-ENVIRONMENT rather than obsolete special variable.

(cl:in-package #:sicl-data-and-control-flow)

(defun fdefinition (function-name)
  (sicl-global-environment:fdefinition
   function-name
   (load-time-value
    (sicl-global-environment:global-environment))))


(describe reduce-with-lambda
    (== (reduce (lambda (acc item) 0 (+ acc item)) 0 '(1 2 3)) 6))

(describe reduce-with-primitive
    (== (reduce + 0 '(1 2 3)) 6))

(describe reduce-building-a-list
    (== (reduce (lambda (l i) (cons i l)) '() '(1 2 3 4)) '(4 3 2 1)))

Fix test to reflect change to scheme style reduce.

(describe reduce-with-lambda
    (== (reduce (lambda (acc item) 0 (+ acc item)) 0 '(1 2 3)) 6))

(describe reduce-with-primitive
    (== (reduce + 0 '(1 2 3)) 6))

(describe reduce-building-a-list
          (== (reduce (lambda (l i) (cons i l)) '() '(1 2 3 4)) '(4 3 2 . 1))
          (== (reduce list '() '(1 2 3 4)) '(((1 2) 3) 4)))


(cl:in-package #:sicl-clos)

(defparameter *target-generic-functions* '())

Define abstractions for access to target GF database.

(cl:in-package #:sicl-clos)

(defparameter *target-generic-functions* '())

(defun add-target-generic-function (name function)
  (pushnew (cons name function) *target-generic-functions*
	   :key #'car :test #'equal))

(defun find-target-generic-function (name)
  (let ((entry (assoc name *target-generic-functions* :test #'equal)))
    (when (null entry)
      (error "There is no target generic function named ~s." name))
    (cdr entry)))

(defun delete-target-generic-function (name)
  (setf *target-generic-functions*
	(remove name *target-generic-functions* :key #'car :test #'equal)))


(cl:in-package #:cleavir-dataflow-analysis)

(defclass port ()
  ((%operation :initarg :operation :reader operation)
   (%datum :initarg :datum :reader datum)))

(defclass input (port)
  ((%outputs :initform '() :initarg outputs :accessor outputs)))

(defclass output (port)
  ((%inputs :initform '() :initarg inputs :accessor inputs)))

(defclass operation ()
  ((%instruction :initarg :instruction :reader instruction)
   (%inputs :initform '() :initarg inputs :accessor inputs)
   (%outputs :initform '() :initarg outputs :accessor outputs)))

(defclass dataflow ()
  (;; This hash table maps each instruction to its corresponding
   ;; operation
   (%operations :initform (make-hash-table :test #'eq)
		:initarg :operations
		:accessor operations)))

(defun dataflow-analysis (initial-instruction)
  (let ((result (make-instance 'dataflow)))
    (cleavir-ir:map-instructions-arbitrary-order
     (lambda (instruction)
       (setf (gethash instruction (operations result))
	     (make-instance 'operation
	       :instruction instruction)))
     initial-instruction)
    result))

Add comment explaining the purpose of the slot OPERATION in class PORT.

(cl:in-package #:cleavir-dataflow-analysis)

(defclass port ()
  (;; The operation to which this port belongs.
   (%operation :initarg :operation :reader operation)
   (%datum :initarg :datum :reader datum)))

(defclass input (port)
  ((%outputs :initform '() :initarg outputs :accessor outputs)))

(defclass output (port)
  ((%inputs :initform '() :initarg inputs :accessor inputs)))

(defclass operation ()
  ((%instruction :initarg :instruction :reader instruction)
   (%inputs :initform '() :initarg inputs :accessor inputs)
   (%outputs :initform '() :initarg outputs :accessor outputs)))

(defclass dataflow ()
  (;; This hash table maps each instruction to its corresponding
   ;; operation
   (%operations :initform (make-hash-table :test #'eq)
		:initarg :operations
		:accessor operations)))

(defun dataflow-analysis (initial-instruction)
  (let ((result (make-instance 'dataflow)))
    (cleavir-ir:map-instructions-arbitrary-order
     (lambda (instruction)
       (setf (gethash instruction (operations result))
	     (make-instance 'operation
	       :instruction instruction)))
     initial-instruction)
    result))


;;;; -*- lisp -*-

(in-package :it.bese.arnesi)

;;;; * Portable lexical environment access

;;;; ** OpenMCL

#+openmcl
(defun environment-p (environment)
  (subtypep (class-of environment) 'ccl::lexical-environment))

#+openmcl
(defun lexical-variables (environment)
  (loop
     for env = environment then (ccl::lexenv.parent-env env)
     while env
     for vars = (ccl::lexenv.variables env)
     when (listp vars)
     append (mapcar (lambda (var)
                      ;; ccl::var-name is a macro, se we can't do #'ccl::var-name directly
                      (ccl::var-name var))
                    vars)))

;;;; ** SBCL

#+sbcl
(defun environment-p (environment)
  (subtypep (class-of environment) (find-class 'sb-kernel:lexenv)))

#+sbcl
(defun lexical-variables (environment)
  (mapcar #'first (sb-c::lexenv-vars environment)))

;;;; ** CMUCL

#+cmu
(defun environment-p (environment)
  (subtypep (class-of environment) (find-class 'c::lexenv)))

#+cmu
(defun lexical-variables (environment)
  (mapcar #'first (c::lexenv-variables environment)))

Fix openmcl's definition of lexical-variables to deal with ccl::definition-environment

;;;; -*- lisp -*-

(in-package :it.bese.arnesi)

;;;; * Portable lexical environment access

;;;; ** OpenMCL

#+openmcl
(defun environment-p (environment)
  (subtypep (class-of environment) 'ccl::lexical-environment))

#+openmcl
(defun lexical-variables (environment)
  (loop
     for env = environment
          then (ccl::lexenv.parent-env env)
     while (and env
                (not (ccl::istruct-typep env 'ccl::definition-environment)))
     for vars = (ccl::lexenv.variables env)
     when (listp vars)
     append (mapcar (lambda (var)
                      ;; ccl::var-name is a macro, se we can't do #'ccl::var-name directly
                      (ccl::var-name var))
                    vars)))

;;;; ** SBCL

#+sbcl
(defun environment-p (environment)
  (subtypep (class-of environment) (find-class 'sb-kernel:lexenv)))

#+sbcl
(defun lexical-variables (environment)
  (mapcar #'first (sb-c::lexenv-vars environment)))

;;;; ** CMUCL

#+cmu
(defun environment-p (environment)
  (subtypep (class-of environment) (find-class 'c::lexenv)))

#+cmu
(defun lexical-variables (environment)
  (mapcar #'first (c::lexenv-variables environment)))


(defsystem :cl-postgres+local-time
  :depends-on (:cl-postgres :local-time)
  :components ((:module "src"
                :components ((:module "integration"
                              :components ((:file "cl-postgres")))))))

Update cl-postgres integration system file

(defsystem #:cl-postgres+local-time
  :name "cl-postgres+local-time"
  :version "1.0.5"
  :author "Daniel Lowe <dlowe@dlowe.net>"
  :description "Integration between cl-postgres and local-time"
  :depends-on (:cl-postgres :local-time)
  :components ((:module "src"
                :components ((:module "integration"
                              :components ((:file "cl-postgres")))))))


(cl:in-package #:sicl-boot)

(defun create-bridge-classes (boot)
  (let ((c (c1 boot))
	(r (r2 boot)))
    (ld "../CLOS/t-defclass.lisp" c r)
    (ld "../CLOS/standard-object-defclass.lisp" c r)
    (ld "../CLOS/metaobject-defclass.lisp" c r)
    (ld "../CLOS/specializer-defclass.lisp" c r)))

Load a file containing the definition of the class CLASS.

(cl:in-package #:sicl-boot)

(defun create-bridge-classes (boot)
  (let ((c (c1 boot))
	(r (r2 boot)))
    (ld "../CLOS/t-defclass.lisp" c r)
    (ld "../CLOS/standard-object-defclass.lisp" c r)
    (ld "../CLOS/metaobject-defclass.lisp" c r)
    (ld "../CLOS/specializer-defclass.lisp" c r)
    (ld "../CLOS/class-defclass.lisp" c r)))


(cl:in-package #:sicl-clos)

(defmethod initialize-instance (object &rest keys &key)
  (declare (ignore object keys))
  nil)

(cl:defmethod cl:initialize-instance :after
  ((metaobject metaobject) &rest keys &key &allow-other-keys)
  (apply #'initialize-instance metaobject keys))

Set fdefinition of SICL-CLOS:INITIALIZE-INSTANCE to CL:INITIALIZE-INTANCE.

(cl:in-package #:sicl-clos)

(setf (fdefinition 'initialize-instance)
      (fdefinition 'cl:initialize-instance))


(cl:in-package #:sicl-extrinsic-environment)

(defun load-file (filename environment)
  (format *trace-output* "Loading file ~a~%" filename)
  (load-source-with-environments
   (asdf:system-relative-pathname :sicl-extrinsic-environment filename)
   environment
   environment))

Call FINISH-OUTPUT after writing trace message.

(cl:in-package #:sicl-extrinsic-environment)

(defun load-file (filename environment)
  (format *trace-output* "Loading file ~a~%" filename)
  (finish-output *trace-output*)
  (load-source-with-environments
   (asdf:system-relative-pathname :sicl-extrinsic-environment filename)
   environment
   environment))


(eval-when (:compile-toplevel :load-toplevel)
  (ql:quickload 'puri))

(defpackage :coleslaw-gh-pages
  (:use :cl)
  (:import-from :puri #:parse-uri #:uri-host)
  (:import-from :coleslaw #:*config*
                          #:deploy
                          #:deploy-dir
                          #:domain
                          #:rel-path)
  (:export #:enable))

(in-package :coleslaw-gh-pages)

(defvar *cname* nil
  "The domain CNAME for github to serve pages from.")

(defmethod deploy :after (staging)
  (let ((blog (truename (rel-path (deploy-dir *config*) ".curr"))))
    (delete-file (rel-path blog "index.html"))
    (cl-fad:copy-file (rel-path blog "1.html") (rel-path blog "index.html"))
    (with-open-file (out (rel-path blog "CNAME")
                     :direction :output
                     :if-exists :supersede
                     :if-does-not-exist :create)
      (format out "~A~%" *cname*))))

(defun enable (&key cname)
  (typecase cname
    (string (setf *cname* cname))
    (t (setf *cname* (uri-host (parse-uri (domain *config*)))))
    (otherwise (error "Not a valid CNAME: ~A" cname))))

Remove call to truename to fix CNAME generation.

(eval-when (:compile-toplevel :load-toplevel)
  (ql:quickload 'puri))

(defpackage :coleslaw-gh-pages
  (:use :cl)
  (:import-from :puri #:parse-uri #:uri-host)
  (:import-from :coleslaw #:*config*
                          #:deploy
                          #:deploy-dir
                          #:domain
                          #:rel-path)
  (:export #:enable))

(in-package :coleslaw-gh-pages)

(defvar *cname* nil
  "The domain CNAME for github to serve pages from.")

(defmethod deploy :after (staging)
  (let ((blog (rel-path (deploy-dir *config*) ".curr")))
    (delete-file (rel-path blog "index.html"))
    (cl-fad:copy-file (rel-path blog "1.html") (rel-path blog "index.html"))
    (with-open-file (out (rel-path blog "CNAME")
                     :direction :output
                     :if-exists :supersede
                     :if-does-not-exist :create)
      (format out "~A~%" *cname*))))

(defun enable (&key cname)
  (typecase cname
    (string (setf *cname* cname))
    (t (setf *cname* (uri-host (parse-uri (domain *config*)))))
    (otherwise (error "Not a valid CNAME: ~A" cname))))


;;; -*- Mode: LISP; Syntax: COMMON-LISP; indent-tabs-mode: nil; coding: utf-8;  -*-
;;; Copyright (C) 2011 Anton Vodonosov (avodonosov@yandex.ru)
;;; See LICENSE for details.

(asdf:defsystem #:test-grid-reporting
  :version "0.1.0"
  :serial t
  :depends-on (#:test-grid-data #:test-grid-utils #:test-grid-agent #:html-template)
  :components
  ((:module "reporting"
    :serial t
    :components
    ((:file "package")
     (:file "my-time")
     (:file "cl-ex")
     (:file "do-results")
     (:file "distinct")
     (:file "html-printers")
     (:file "list-failures")
     (:file "list-results")
     (:file "templating")
     (:file "reporting")
     (:file "test-runs")
     (:file "csv")
     (:file "pivot")
     (:file "pivot2")
     (:file "quicklisp-diff")
     (:file "library-report")
     (:file "regressions")
     (:file "meta-info-from-quicklisp")
     (:file "dependencies-and-blockers")
     (:file "load-failures")
     (:file "compiler-diff")
     (:file "demo-reports")
     (:file "durations")
     (:file "contributors")))))

Remove old unused function test-gird-reporting::list-failures

;;; -*- Mode: LISP; Syntax: COMMON-LISP; indent-tabs-mode: nil; coding: utf-8;  -*-
;;; Copyright (C) 2011 Anton Vodonosov (avodonosov@yandex.ru)
;;; See LICENSE for details.

(asdf:defsystem #:test-grid-reporting
  :version "0.1.0"
  :serial t
  :depends-on (#:test-grid-data #:test-grid-utils #:test-grid-agent #:html-template)
  :components
  ((:module "reporting"
    :serial t
    :components
    ((:file "package")
     (:file "my-time")
     (:file "cl-ex")
     (:file "do-results")
     (:file "distinct")
     (:file "html-printers")
     (:file "list-results")
     (:file "templating")
     (:file "reporting")
     (:file "test-runs")
     (:file "csv")
     (:file "pivot")
     (:file "pivot2")
     (:file "quicklisp-diff")
     (:file "library-report")
     (:file "regressions")
     (:file "meta-info-from-quicklisp")
     (:file "dependencies-and-blockers")
     (:file "load-failures")
     (:file "compiler-diff")
     (:file "demo-reports")
     (:file "durations")
     (:file "contributors")))))


;; math-system-utils.lisp - misc. utility forms

(in-package #:math)

(define-condition entity-condition ()
  ((name
    :initarg :name
    :reader entity-condition-name)))

(define-condition entity-not-found (error entity-condition)
  ())

(define-condition redefinition-condition (style-warning)
  ((previous-object
    :initarg :previous
    :accessor redefinition-condition-previous-object)
   (new-object
    :initarg :new
    :accessor redefinition-condition-new-object)))

(define-condition container-condition ()
  ((container
    :intarg :container
    :reader container-condition-container)))

Correct typo in class defn

;; math-system-utils.lisp - misc. utility forms

(in-package #:math)

(define-condition entity-condition ()
  ((name
    :initarg :name
    :reader entity-condition-name)))

(define-condition entity-not-found (error entity-condition)
  ())

(define-condition redefinition-condition (style-warning)
  ((previous-object
    :initarg :previous
    :accessor redefinition-condition-previous-object)
   (new-object
    :initarg :new
    :accessor redefinition-condition-new-object)))

(define-condition container-condition ()
  ((container
    :initarg :container
    :reader container-condition-container)))


;; Declaration of package
;; Liam Healy 2009-02-22 09:55:45EST pkgdcl.lisp
;; Time-stamp: <2009-05-12 15:27:21EDT init.lisp>

(in-package :common-lisp-user)

(defpackage :foreign-structures-by-value
  (:nicknames #:fsbv)
  (:use #:common-lisp))

(cffi:load-foreign-library
 #+darwin "libffi.dylib"
 #+(and (not darwin) unix) "libffi.so")

(pushnew :fsbv *features*)

Add include path for OSX

;; Declaration of package
;; Liam Healy 2009-02-22 09:55:45EST pkgdcl.lisp
;; Time-stamp: <2009-08-22 16:20:00EDT init.lisp>

(in-package :common-lisp-user)

(defpackage :foreign-structures-by-value
  (:nicknames #:fsbv)
  (:use #:common-lisp))

(cffi:load-foreign-library
 #+darwin "libffi.dylib"
 #+(and (not darwin) unix) "libffi.so")

;;; When installed through Mac Ports, GSL .h files will be found
;;; in /opt/local/include.
#+darwin
(setf cffi-grovel::*cc-flags*
      (append '("-I" "/opt/local/include/") cffi-grovel::*cc-flags*))

(pushnew :fsbv *features*)


(cl:in-package #:clump-2-3-tree)

(defclass tree ()
  ((%contents :initform nil :accessor contents)
   (%leaf-class :initarg :leaf-class :reader leaf-class)
   (%2-node-class :initarg :2-node-class :reader 2-node-class)
   (%3-node-class :initarg :3-node-class :reader 3-node-class)))

(defclass node ()
  ((%parent :initarg :parent :accessor parent)
   (%tree :initarg :tree :reader tree)))

(defclass leaf (node)
  ((%contents :initarg :contents :accessor contents)))

(defclass 2-node (node)
  ((%left :initarg :left :accessor left)
   (%right :initarg :right :accessor right)))

(defgeneric 2-node-p (object)
  (:method (object) nil)
  (:method ((node 2-node)) t))

(defclass 3-node (node)
  ((%left :initarg :left :accessor left)
   (%middle :initarg :middle :accessor middle)
   (%right :initarg :right :accessor right)))

Define generic function 3-NODE-P with two methods.

(cl:in-package #:clump-2-3-tree)

(defclass tree ()
  ((%contents :initform nil :accessor contents)
   (%leaf-class :initarg :leaf-class :reader leaf-class)
   (%2-node-class :initarg :2-node-class :reader 2-node-class)
   (%3-node-class :initarg :3-node-class :reader 3-node-class)))

(defclass node ()
  ((%parent :initarg :parent :accessor parent)
   (%tree :initarg :tree :reader tree)))

(defclass leaf (node)
  ((%contents :initarg :contents :accessor contents)))

(defclass 2-node (node)
  ((%left :initarg :left :accessor left)
   (%right :initarg :right :accessor right)))

(defgeneric 2-node-p (object)
  (:method (object) nil)
  (:method ((node 2-node)) t))

(defclass 3-node (node)
  ((%left :initarg :left :accessor left)
   (%middle :initarg :middle :accessor middle)
   (%right :initarg :right :accessor right)))

(defgeneric 3-node-p (object)
  (:method (object) nil)
  (:method ((node 3-node)) t))


(defpackage #:eos-api
  (:use :cl #:api-dsl)
  (:export #:run-test-suites
           #:failed-tests))

(in-package #:eos-api)

(proclfun run-test-suites (&rest (test-suite-spec symbol)) t
  "Runs one or more Eos test suites specified by arguments and returns
an opaque result object combining all the results. The result object may
be passed to the FAILED-TESTS function to retreive the list of tests
failed in all the test sutes.")

(proclfun failed-tests ((test-suite-result t)) list
  "List of failed test names. Test names are downcased strings.
The TEST-SUITE-RESULT parameter must be a result of the RUN-TEST-SUITE
function.")

Fix typo in a docstring.

(defpackage #:eos-api
  (:use :cl #:api-dsl)
  (:export #:run-test-suites
           #:failed-tests))

(in-package #:eos-api)

(proclfun run-test-suites (&rest (test-suite-spec symbol)) t
  "Runs one or more Eos test suites specified by arguments and returns
an opaque result object combining all the results. The result object may
be passed to the FAILED-TESTS function to retreive the list of tests
failed in all the test sutes.")

(proclfun failed-tests ((test-suite-result t)) list
  "List of failed test names. Test names are downcased strings.
The TEST-SUITE-RESULT parameter must be a result of the RUN-TEST-SUITES
function.")