(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-support.lisp"
      environment)
  (ld "../../CLOS/ensure-generic-function-using-class-defmethods.lisp"
      environment)
  (ld "../../CLOS/ensure-class-using-class-support.lisp"
      environment)
  (ld "../../CLOS/ensure-class-using-class-defgenerics.lisp"
      environment)
  (ld "../../CLOS/ensure-class-using-class-defmethods.lisp"
      environment)
  (ld "../../CLOS/ensure-class.lisp" environment)
  (ld "../../Environment/standard-environment-functions.lisp" environment)
  (setf (sicl-genv:find-class 'standard-object environment) nil)
  (ld "../../CLOS/standard-object-defclass.lisp" environment))

Load file containing definition of class METAOBJECT.

(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-support.lisp"
      environment)
  (ld "../../CLOS/ensure-generic-function-using-class-defmethods.lisp"
      environment)
  (ld "../../CLOS/ensure-class-using-class-support.lisp"
      environment)
  (ld "../../CLOS/ensure-class-using-class-defgenerics.lisp"
      environment)
  (ld "../../CLOS/ensure-class-using-class-defmethods.lisp"
      environment)
  (ld "../../CLOS/ensure-class.lisp" environment)
  (ld "../../Environment/standard-environment-functions.lisp" environment)
  (setf (sicl-genv:find-class 'standard-object environment) nil)
  (ld "../../CLOS/standard-object-defclass.lisp" environment)
  (setf (sicl-genv:find-class 'sicl-clos:metaobject environment) nil)
  (ld "../../CLOS/metaobject-defclass.lisp" environment))


;;;; tutorial-builder.asd

(asdf:defsystem #:tutorial-builder
  :serial t
  :description "A library for presenting md files as tutorials."
  :author "Matt Niemeir <matt.niemeir@gmail.com>"
  :license "BSD 2-clause"
  :depends-on (#:lazy-susan
               #:dishes
               #:uiop
               #:alexandria
               #:3bmd
               )
  :components ((:file "package")
               (:file "utils.lisp")
               (:file "tutorial-builder")))

Fix name of utils.lisp in the asd

;;;; tutorial-builder.asd

(asdf:defsystem #:tutorial-builder
  :serial t
  :description "A library for presenting md files as tutorials."
  :author "Matt Niemeir <matt.niemeir@gmail.com>"
  :license "BSD 2-clause"
  :depends-on (#:lazy-susan
               #:dishes
               #:uiop
               #:alexandria
               #:3bmd
               )
  :components ((:file "package")
               (:file "utils")
               (:file "tutorial-builder")))


(asdf:defsystem cl-rfc3339
    :author "Gregory Tod <lisp@gtod.net>"
    :version "0.1.0"
    :license "MIT"
    :description "Canonicalize time formats to a specifc RFC 3339 compliant string."
    :depends-on (#:local-time)
    :components ((:file "package")
                 (:file "rfc3339")))

Fix typo in system description

(asdf:defsystem cl-rfc3339
    :author "Gregory Tod <lisp@gtod.net>"
    :version "0.1.0"
    :license "MIT"
    :description "Canonicalize time formats to a specific RFC 3339 compliant string."
    :depends-on (#:local-time)
    :components ((:file "package")
                 (:file "rfc3339")))


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

(defun define-ensure-generic-function-r1 (boot)
  (setf (sicl-genv:fdefinition 'ensure-generic-function (r1 boot))
	(lambda (function-name &rest arguments)
	  (let ((args (copy-list arguments)))
	    (loop while (remf args :environment))
	    (if (sicl-genv:fboundp function-name (r1 boot))
		(sicl-genv:fdefinition function-name (r1 boot))
		(setf (sicl-genv:fdefinition function-name (r1 boot))
		      (apply #'make-instance 'standard-generic-function
			     :name function-name
			     args)))))))

(defun customize-r1 (boot)
  (let ((c (c1 boot))
	(r (r1 boot)))
    (message "Customizing run-time environment R1~%")
    (define-ensure-generic-function-r1 boot)
    (message "Finished customizing run-time environment R1~%")))

Define function in R1, but operate on R2.

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

;;; We define a special version of ENSURE-GENERIC-FUNCTION in the
;;; run-time environment R1.  While the function is defined in the
;;; run-time environment R1, it operates on the run-time environment
;;; R2.  This version checks whether there is already a function named
;;; FUNCTION-NAME in R2.  If so that function is returned, and it is
;;; assumed to be a generic function.  If not, an instance of the host
;;; class STANDARD-GENERIC-FUNCTION is created and associated with
;;; FUNCTION-NAME in R2.
(defun define-ensure-generic-function-r1 (boot)
  (setf (sicl-genv:fdefinition 'ensure-generic-function (r1 boot))
	(lambda (function-name &rest arguments)
	  (let ((args (copy-list arguments)))
	    (loop while (remf args :environment))
	    (if (sicl-genv:fboundp function-name (r2 boot))
		(sicl-genv:fdefinition function-name (r2 boot))
		(setf (sicl-genv:fdefinition function-name (r2 boot))
		      (apply #'make-instance 'standard-generic-function
			     :name function-name
			     args)))))))

(defun customize-r1 (boot)
  (let ((c (c1 boot))
	(r (r1 boot)))
    (message "Customizing run-time environment R1~%")
    (define-ensure-generic-function-r1 boot)
    (message "Finished customizing run-time environment R1~%")))


;;;; bit-smasher.asd

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

(in-package :cl-user)

(defpackage bit-smasher-asd
  (:use :cl :asdf)
  (:export #:*bit-smasher-version*))

(in-package :bit-smasher-asd)

(defparameter *bit-smasher-version* "1.0.2")

(defsystem #:bit-smasher
  :serial t
  :description "Utility library for handling bit vectors, bit vector arithmetic, and universal integer type conversions between bit-vectors, byte-vectors, octals, decimals, and hexadecimal notation."
  :version #.*bit-smasher-version*
  :author "\"the Phoeron\" Colin J.E. Lupton <sysop@thephoeron.com>"
  :license "MIT"
  :pathname "src/"
  :depends-on (:cl-base58
               :cl-base64
               :ironclad)
  :components ((:file "packages")
               (:file "core")
               (:file "from-ironclad")
               (:file "conversion")
               (:file "arithmetic")
               (:file "aliases")
               (:file "utils"))
  :in-order-to ((test-op (test-op :bit-smasher-test))))

Remove Ironclad from system def

;;;; bit-smasher.asd

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

(in-package :cl-user)

(defpackage bit-smasher-asd
  (:use :cl :asdf)
  (:export #:*bit-smasher-version*))

(in-package :bit-smasher-asd)

(defparameter *bit-smasher-version* "1.0.2")

(defsystem #:bit-smasher
  :serial t
  :description "Utility library for handling bit vectors, bit vector arithmetic, and universal integer type conversions between bit-vectors, byte-vectors, octals, decimals, and hexadecimal notation."
  :version #.*bit-smasher-version*
  :author "\"the Phoeron\" Colin J.E. Lupton <sysop@thephoeron.com>"
  :license "MIT"
  :pathname "src/"
  :depends-on (:cl-base58
               :cl-base64)
  :components ((:file "packages")
               (:file "core")
               (:file "from-ironclad")
               (:file "conversion")
               (:file "arithmetic")
               (:file "aliases")
               (:file "utils"))
  :in-order-to ((test-op (test-op :bit-smasher-test))))


(cl:in-package #:cleavir-type-inference)

(defgeneric transfer (instruction input-bag))

(defmethod transfer (instruction input-bag)
  (loop with result = input-bag
	for output in (cleavir-ir:outputs instruction)
	when (typep output 'cleavir-ir:lexical-location)
	  do (setf result (update output t result))
	finally (return result)))

Rename in preparation for a TWO-SUCCESSORS-TRANSFER function.

(cl:in-package #:cleavir-type-inference)

(defgeneric one-successor-transfer (instruction input-bag))

(defmethod one-successor-transfer (instruction input-bag)
  (loop with result = input-bag
	for output in (cleavir-ir:outputs instruction)
	when (typep output 'cleavir-ir:lexical-location)
	  do (setf result (update output t result))
	finally (return result)))


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

(defun function-arguments (fun)
  (awhen fun.__source
    !.))

(defun function-body (fun)
  (awhen fun.__source
    .!))

Allow calls to unknown functions.

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

(defun function-arguments (fun)
  (? fun
     (aif fun.__source
          !.
          '(&rest unknown-args))
     '(&rest unknown-args)))

(defun function-body (fun)
  (awhen fun.__source
    .!))


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

(defgeneric delete (leaf))

(defgeneric delete-child (parent child))

(defgeneric replace-and-shrink (parent child))

(defmethod delete ((leaf leaf))
  (delete-child (parent leaf) leaf))

Define method on DELETE-CHILD specialized to TREE.

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

(defgeneric delete (leaf))

(defgeneric delete-child (parent child))

(defgeneric replace-and-shrink (parent child))

(defmethod delete ((leaf leaf))
  (delete-child (parent leaf) leaf))

(defmethod delete-child ((tree tree) child)
  (declare (ignore child))
  (setf (contents tree) nil))


(in-package :magicffi-test)

(defun do-test (testfile resultfile)
  (with-open-magic (cookie '(:none))
    (format t ";;; Loading ~A...~%" *magic-database*)
    (magic-load cookie)
    (format t ";;; Determining ~A...~%" testfile)
    (let* ((result (magic-file cookie testfile))
           (desired (read-file-into-string resultfile)))
      (format t "~A: ~A~%" testfile result)
      (unless (string= result desired)
        (error "Error: result was~%~A~%expected:~%~A~%" result desired)))))

(defun run-tests ()
  (let* ((this-file (or #.*compile-file-pathname*
                        (load-time-value *load-pathname*)))
         (testfiles (directory (make-pathname :name :wild
                                              :type "testfile"
                                              :defaults this-file))))
    (format t "~2&;;; Testing...~%")
    (dolist (testfile testfiles)
      (let* ((magicfile (make-pathname :type "magic" :defaults testfile))
             (resultfile (make-pathname :type "result" :defaults testfile))
             (*magic-database* magicfile))
        (do-test testfile resultfile)))
    (format t "~&;;; All tests passed!~%")))

Add test code for MAGIC-BUFFER.

(in-package :magicffi-test)

(defun do-test (testfile resultfile)
  (with-open-magic (cookie '(:none))
    (format t ";;; Loading ~A...~%" *magic-database*)
    (magic-load cookie)
    (format t ";;; Determining ~A...~%" testfile)
    (let* ((result (magic-file cookie testfile))
           (desired (read-file-into-string resultfile)))
      (format t "~A: ~A~%" testfile result)
      (unless (string= result desired)
        (error "Error: result was~%~A~%expected:~%~A~%" result desired)))
    (let* ((buffer (read-file-into-string testfile))
           (result (magic-buffer cookie buffer))
           (desired (read-file-into-string resultfile)))
      (format t "~A: ~A~%" testfile result)
      (unless (string= result desired)
        (error "Error: result was~%~A~%expected:~%~A~%" result desired)))))

(defun run-tests ()
  (let* ((this-file (or #.*compile-file-pathname*
                        (load-time-value *load-pathname*)))
         (testfiles (directory (make-pathname :name :wild
                                              :type "testfile"
                                              :defaults this-file))))
    (format t "~2&;;; Testing...~%")
    (dolist (testfile testfiles)
      (let* ((magicfile (make-pathname :type "magic" :defaults testfile))
             (resultfile (make-pathname :type "result" :defaults testfile))
             (*magic-database* magicfile))
        (do-test testfile resultfile)))
    (format t "~&;;; All tests passed!~%")))


(in-package :cl-user)

(defpackage :nellie.asd
  (:use :cl :asdf))

(in-package :nellie.asd)

(asdf:defsystem #:nellie
  :serial t
  :description "Away from the circus"
  :version "0.1"
  :author "Mike Ivanov"
  :license "LGPLv3"
  :depends-on (:iterate :drakma :flexi-streams :cl-ppcre :cl-json
               :getopt :iterate :simple-date-time :alexandria :cl-interpol
               :metabang-bind)
  :components ((:file "util")
               (:file "hdfs")
               (:file "hcat")
               (:file "ui")))

Remove the hcat.lisp reference (for now).

(in-package :cl-user)

(defpackage :nellie.asd
  (:use :cl :asdf))

(in-package :nellie.asd)

(asdf:defsystem #:nellie
  :serial t
  :description "Away from the circus"
  :version "0.1"
  :author "Mike Ivanov"
  :license "LGPLv3"
  :depends-on (:iterate :drakma :flexi-streams :cl-ppcre :cl-json
               :getopt :iterate :simple-date-time :alexandria :cl-interpol
               :metabang-bind)
  :components ((:file "util")
               (:file "hdfs")
               (:file "ui")))


#|
  This file is a part of cl-cuda project.
  Copyright (c) 2012 Masayuki Takagi (kamonama@gmail.com)
|#

(in-package :cl-user)
(defpackage cl-cuda-examples.defglobal
  (:use :cl :cl-cuda)
  (:export :main))
(in-package :cl-cuda-examples.defglobal)

(setf cl-cuda:*show-messages* nil)

;;
;; Globals

(defglobal foo int)

(defglobal bar int)

;;
;; Kernel function

(defkernel add-globals (void ((out int*)))
  (set (aref out 0) (+ foo bar)))

;;
;; Main

(defun main ()
  (let ((dev-id 0))
    (with-cuda (dev-id)
      ;; First, set values to globals.
      (setf (global-ref 'foo) 1)
      (setf (global-ref 'bar) 2)
      ;; Second, launch kernel function and get sum of globals.
      (with-memory-blocks ((out 'int 1))
        ;; Launch ADD-GLOBALS kernel function.
        (add-globals out :grid-dim '(1 1 1) :block-dim '(1 1 1))
        ;; Synchronize memory block.
        (sync-memory-block out :device-to-host)
        ;; Output result.
        (format t "Got ~A from adding two globals.~%"
                (memory-block-aref out 0))))))

Add qualifiers to DEFGLOBAL example.

#|
  This file is a part of cl-cuda project.
  Copyright (c) 2012 Masayuki Takagi (kamonama@gmail.com)
|#

(in-package :cl-user)
(defpackage cl-cuda-examples.defglobal
  (:use :cl :cl-cuda)
  (:export :main))
(in-package :cl-cuda-examples.defglobal)

(setf cl-cuda:*show-messages* nil)

;;
;; Globals

(defglobal foo int)

(defglobal bar int 0 :constant)

;;
;; Kernel function

(defkernel add-globals (void ((out int*)))
  (set (aref out 0) (+ foo bar)))

;;
;; Main

(defun main ()
  (let ((dev-id 0))
    (with-cuda (dev-id)
      ;; First, set values to globals.
      (setf (global-ref 'foo) 1)
      (setf (global-ref 'bar) 2)
      ;; Second, launch kernel function and get sum of globals.
      (with-memory-blocks ((out 'int 1))
        ;; Launch ADD-GLOBALS kernel function.
        (add-globals out :grid-dim '(1 1 1) :block-dim '(1 1 1))
        ;; Synchronize memory block.
        (sync-memory-block out :device-to-host)
        ;; Output result.
        (format t "Got ~A from adding two globals.~%"
                (memory-block-aref out 0))))))


(in-package :kit.gl)

;;; Protocol for everyone

(defgeneric gl-delete-object (gl-object)
  (:documentation "Call the appropriate gl* function to free the resource
`GL-OBJECT`."))

(defun gl-delete (&rest gl-objects)
  "Delete `GL-OBJECTS` by calling `GL-DELETE-OBJECT` on each."
  (map nil #'gl-delete-object gl-objects))

Allow vectors and lists of objects to be passed to GL-DELETE(-OBJECT)

(in-package :kit.gl)

;;; Protocol for everyone

(defgeneric gl-delete-object (gl-object)
  (:documentation "Call the appropriate gl* function to free the resource
`GL-OBJECT`."))

(defmethod gl-delete-object ((gl-objects list))
  (map nil #'gl-delete-object gl-objects))

(defmethod gl-delete-object ((gl-objects vector))
  (map nil #'gl-delete-object gl-objects))

(defun gl-delete (&rest gl-objects)
  "Delete `GL-OBJECTS` by calling `GL-DELETE-OBJECT` on each."
  (map nil #'gl-delete-object gl-objects))


(in-package :de.anvi.croatoan)

(defun insert-char (window char &key attributes color-pair y x)
  "Insert char into window before the character currently under the cursor.

Chars right of the cursor are moved one position to the right.
The rightmost character on the line may be lost. The position of the
cursor is not changed.

If the destination coordinates y and x are given, move the cursor
there first."
  (let ((winptr (.winptr window))
        (chtype (logior (typecase char
                          ;; if the char is already an integer chtype
                          (integer char)
                          ;; alternative chars are given as keywords
                          (keyword (acs char))
                          ;; if it is a lisp char, convert it to an integer first
                          (character (char-code char))
                          (t 0))
                        ;; convert the pair to an integer, then bit shift it by 8
                        (if color-pair (ash (pair->number color-pair) 8) 0)
                        ;; the attribute bitmasks already are bitshifted to the
                        ;; correct position in the chtype
                        (if attributes (attrs2chtype attributes) 0))))
    (cond ((and y x)
           (%mvwinsch winptr y x chtype))
          (t
           (%winsch winptr chtype)))))

Refactor insert-char to use char2chtype

(in-package :de.anvi.croatoan)

(defun insert-char (window char &key attributes color-pair y x)
  "Insert char into window before the character currently under the cursor.

Chars right of the cursor are moved one position to the right.
The rightmost character on the line may be lost. The position of the
cursor is not changed.

If the destination coordinates y and x are given, move the cursor
there first."
  (let ((winptr (.winptr window))
        (chtype (char2chtype char attributes color-pair)))
    (cond ((and y x)
           (%mvwinsch winptr y x chtype))
          (t
           (%winsch winptr chtype)))))


(in-package :serapeum.tests)

(def-suite macro-tools :in serapeum)
(in-suite macro-tools)

(test read-only-var
  (let ((x 1))
    (with-read-only-vars (x)
      (is (eql x 1)))))

(test read-only-var-warning
  (if (can-introspect-environment?)
      (signals warning
        (compile nil
                 '(lambda ()
                   (let ((x 1))
                     (with-read-only-vars (x)
                       (setf x 2))))))
      (pass)))

(test read-only-var-error
  (if (can-introspect-environment?)
      (signals warning
        (eval*
         '(let ((x 1))
           (with-read-only-vars (x)
             (setf x 2)))))
      (pass)))

(test read-only-var/special
  (is-false
   (let ((*special* t))
     (with-read-only-vars (*special*)
       (setf *special* nil)))))

Test for eval-if-constant in an environment.

(in-package :serapeum.tests)

(def-suite macro-tools :in serapeum)
(in-suite macro-tools)

(test read-only-var
  (let ((x 1))
    (with-read-only-vars (x)
      (is (eql x 1)))))

(test read-only-var-warning
  (if (can-introspect-environment?)
      (signals warning
        (compile nil
                 '(lambda ()
                   (let ((x 1))
                     (with-read-only-vars (x)
                       (setf x 2))))))
      (pass)))

(test read-only-var-error
  (if (can-introspect-environment?)
      (signals warning
        (eval*
         '(let ((x 1))
           (with-read-only-vars (x)
             (setf x 2)))))
      (pass)))

(test read-only-var/special
  (is-false
   (let ((*special* t))
     (with-read-only-vars (*special*)
       (setf *special* nil)))))

(test eval-if-constant-in-env
  (macrolet ((constant-value/env (x &environment env)
               (eval-if-constant x env)))
    (symbol-macrolet ((x 1))
      (is (eql 1 (constant-value/env x))))))


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

(defmacro defun (name lambda-list &body body)
  (multiple-value-bind (declarations documentation forms)
      (cleavir-code-utilities:separate-function-body body)
    ;; FIXME: handle documentation
    (declare (ignore documentation))
    (let ((definition `(lambda ,lambda-list
			 ,declarations
			 (block ,name
			   ,@forms))))
      `(progn
	 (eval-when (:compile-toplevel)
	   (sicl-compiler:compile-time-compile ',name ',definition))
	 (eval-when (:load-toplevel :execute)
	   (funcall #'(setf fdefinition) ,definition ',name))))))

Set function type at compile time.

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

(defmacro defun (&environment env name lambda-list &body body)
  (multiple-value-bind (declarations documentation forms)
      (cleavir-code-utilities:separate-function-body body)
    (let ((global-env (cleavir-env:global-environment env))
	  (arg-type
	    (cleavir-code-utilities:lambda-list-type-specifier lambda-list)))
      `(progn
	 (eval-when (:compile-toplevel)
	   (setf (sicl-env:function-type ',name ,global-env)
		 `(function ,arg-type t)))
	 (eval-when (:load-toplevel :execute)
	   (setf (sicl-env:fdefinition ',name ,global-env)
		 (lambda ,lambda-list
		   ,declarations
		   ,@(if (null documentation)
			 '()
			 (list documentation))
		   (block ,name
		     ,@forms))))))))


(in-package :cl-user)

(defpackage :manifest
  (:use :cl :toot :split-sequence :closer-mop :monkeylib-html :monkeylib-text-output)
  (:shadowing-import-from :closer-mop
                          :defmethod
                          :defgeneric
                          :standard-generic-function)

  (:export :start
           :stop))

Fix defpackage for proper use of Closer MOP

(in-package :cl-user)

(defpackage :manifest
  (:use :closer-common-lisp
        :monkeylib-html
        :monkeylib-text-output
        :toot
        :split-sequence)
  (:export :start
           :stop))


(in-package :brreg)

(push (cons "application" "json") drakma:*text-content-types*)

(defun get-jsonhash (orgnummer)
  (when (and (every #'digit-char-p orgnummer)
             (= (length orgnummer) 9))
    (multiple-value-bind (response status)
        (drakma:http-request
         (format nil "http://data.brreg.no/enhetsregisteret/enhet/~A.json"
                 orgnummer))
      (when (eql status 200)
        (yason:parse response)))))

(defun get-orgfeature (feature orgnummer)
  (ignore-errors
   (let ((hash (get-jsonhash orgnummer)))
     (if hash
         (gethash feature hash)
         (make-hash-table)))))

(defun get-org-name (orgnummer)
  (get-orgfeature "navn" orgnummer))

(defun get-org-address (orgnummer)
  (gethash "adresse" (get-orgfeature "forretningsadresse" orgnummer)))

(defun get-org-postnummer (orgnummer)
  (gethash "postnummer" (get-orgfeature "forretningsadresse" orgnummer)))

(defun get-org-poststed (orgnummer)
  (gethash "poststed" (get-orgfeature "forretningsadresse" orgnummer)))

Fix problem with get-name and empty hash.

(in-package :brreg)

(push (cons "application" "json") drakma:*text-content-types*)

(defun get-jsonhash (orgnummer)
  (when (and (every #'digit-char-p orgnummer)
             (= (length orgnummer) 9))
    (multiple-value-bind (response status)
        (drakma:http-request
         (format nil "http://data.brreg.no/enhetsregisteret/enhet/~A.json"
                 orgnummer))
      (when (eql status 200)
        (yason:parse response)))))

(defun get-orgfeature (feature orgnummer)
  (ignore-errors
   (let ((hash (get-jsonhash orgnummer)))
     (if hash
         (gethash feature hash)
         (make-hash-table)))))

(defun get-org-name (orgnummer)
  (let ((navn (get-orgfeature "navn" orgnummer)))
    (when (stringp navn)
      navn)))

(defun get-org-address (orgnummer)
  (gethash "adresse" (get-orgfeature "forretningsadresse" orgnummer)))

(defun get-org-postnummer (orgnummer)
  (gethash "postnummer" (get-orgfeature "forretningsadresse" orgnummer)))

(defun get-org-poststed (orgnummer)
  (gethash "poststed" (get-orgfeature "forretningsadresse" orgnummer)))


;;;; clinenoise.asd
(cl:eval-when (:load-toplevel :execute)
  (asdf:operate 'asdf:load-op 'cffi-grovel))

(asdf:defsystem #:clinenoise
  :serial t
  :description "Describe clinenoise here"
  :author "Your Name <your.name@example.com>"
  :license "Specify license here"
  :depends-on (#:cffi
               #:alexandria
               #:split-sequence
	       #:cffi-grovel)
  :components ((:file "package")
	       (cffi-grovel:grovel-file "termios-grovel")
	       (:file "cwrappers")
               (:file "clinenoise")))

Update how the CFFI groveller is invoked

;;;; clinenoise.asd
(asdf:defsystem #:clinenoise
  :serial t
  :description "Describe clinenoise here"
  :author "Your Name <your.name@example.com>"
  :license "Specify license here"
  :defsystem-depends-on ("cffi-grovel")
  :depends-on (#:cffi
               #:alexandria
               #:split-sequence
	       #:cffi-grovel)
  :components ((:file "package")
	       (:cffi-grovel-file "termios-grovel")
	       (:file "cwrappers")
               (:file "clinenoise")))


(in-package :ratatoskr)

(default-targmaxes
    ((cmd-join . 4)
     (cmd-part . 4)
     (cmd-mode . 100)
     (cmd-names . 1)
     (cmd-privmsg . 4)
     (cmd-notice . 4)
     (cmd-whois . 4)))

(defparameter *targmaxes*
  (alist-hash-table +default-targmaxes+ :test 'eq))

(defconstant +max-params+ 10)
(defvar *targmax* 4)
(proclaim
 `(type (or (integer 1 ,+max-params+) null) *operands-per-message*))

Enlarge default *targmax*, configure constructors

(in-package :ratatoskr)

(default-targmaxes
    ((cmd-join . 4)
     (cmd-part . 4)
     (cmd-mode . 100)
     (cmd-names . 1)
     (cmd-privmsg . 4)
     (cmd-notice . 4)
     (cmd-whois . 4)
     (cmd-userhost . 5)))

(defparameter *targmaxes*
  (alist-hash-table +default-targmaxes+ :test 'eq))

(defconstant +max-params+ 10)
(defvar *targmax* 5)
(proclaim
 `(type (or (integer 1 ,+max-params+) null) *operands-per-message*))


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

(asdf:defsystem cleavir-code-utilities
  :depends-on (:cleavir-internationalization)
  :serial t
  :components
  ((:file "packages")
   (:file "conditions")
   (:file "condition-reporters-english")
   (:file "argcount")
   (:file "form")
   (:file "list-structure")
   (:file "declarations")
   (:file "lambda-lists")
   (:file "destructuring")))

Define system in package ASDF-USER.

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

(defsystem cleavir-code-utilities
  :depends-on (:cleavir-internationalization)
  :serial t
  :components
  ((:file "packages")
   (:file "conditions")
   (:file "condition-reporters-english")
   (:file "argcount")
   (:file "form")
   (:file "list-structure")
   (:file "declarations")
   (:file "lambda-lists")
   (:file "destructuring")))


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

(defsystem :cleavir-ast
  :depends-on (:cleavir-io
	       :cleavir-meter)
  :serial t
  :components
  ((:file "packages")
   (:file "general-purpose-asts")
   (:file "fixnum-related-asts")
   (:file "float-related-asts")
   (:file "cons-related-asts")
   (:file "standard-object-related-asts")
   (:file "array-related-asts")
   (:file "graphviz-drawing")
   (:file "map-ast")))

Add new component to system definition.

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

(defsystem :cleavir-ast
  :depends-on (:cleavir-io
	       :cleavir-meter)
  :serial t
  :components
  ((:file "packages")
   (:file "general-purpose-asts")
   (:file "fixnum-related-asts")
   (:file "float-related-asts")
   (:file "cons-related-asts")
   (:file "standard-object-related-asts")
   (:file "array-related-asts")
   (:file "optimize-related-asts")
   (:file "graphviz-drawing")
   (:file "map-ast")))


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

;;; We use the reader DEFAULT-INITARGS rather than
;;; CLASS-DEFAULT-INITARGS, because the AMOP stipulates that
;;; CLASS-DEFAULT-INITARGS must return the empty list for built-in
;;; classes.  However, our built-in classes do have default initargs.
;;; The solution to this problem is to use a different reader named
;;; DEFAULT-INITARGS.  This reader works for standard classes and
;;; funcallable standard classes as well.

(defun make-built-in-instance (class &rest initargs)
  (let ((defaulted-initargs initargs))
    (loop for default-initarg in (default-initargs class)
	  do (unless (initarg-in-list-p (car default-initarg) initargs)
	       (setf defaulted-initargs
		     (append defaulted-initargs
			     (list (first default-initarg)
				   (funcall (third default-initarg)))))))
    (let ((instance (apply #'allocate-built-in-instance class defaulted-initargs)))
      (apply #'initialize-built-in-instance instance defaulted-initargs)
      instance)))

Rename function and add more comments.

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

;;; The function in this file implements the action of the default
;;; method on the generic function MAKE-BUILT-IN-INSTANCE, i.e. the
;;; one specialized to BUILT-IN-CLASS.
;;;
;;; We use the reader DEFAULT-INITARGS rather than
;;; CLASS-DEFAULT-INITARGS, because the AMOP stipulates that
;;; CLASS-DEFAULT-INITARGS must return the empty list for built-in
;;; classes.  However, our built-in classes do have default initargs.
;;; The solution to this problem is to use a different reader named
;;; DEFAULT-INITARGS.  This reader works for standard classes and
;;; funcallable standard classes as well.

(defun make-built-in-instance-default (class &rest initargs)
  (let ((defaulted-initargs initargs))
    (loop for default-initarg in (default-initargs class)
	  do (unless (initarg-in-list-p (car default-initarg) initargs)
	       (setf defaulted-initargs
		     (append defaulted-initargs
			     (list (first default-initarg)
				   (funcall (third default-initarg)))))))
    (let ((instance (apply #'allocate-built-in-instance class defaulted-initargs)))
      (apply #'initialize-built-in-instance instance defaulted-initargs)
      instance)))


;;;;; TRE environment
;;;;; Copyright (c) 2009 Sven Klose <pixel@copei.de>
;;;;;
;;;;; Testing stage 0 functions

;(define-test "%NCONC"
;  ((%nconc '(1 2) '(3 4)))
;  '(1 2 3 4))

(define-test "%NCONC with NIL first"
  ((%nconc nil '(3 4)))
  '(3 4))

(define-test "%NCONC with NIL second"
  ((%nconc '(1 2) nil))
  '(1 2))

(define-test "LENGHT with conses"
  ((length '(1 2 3 4)))
  (integer 4))

(define-test "LENGHT with strings"
  ((length "test"))
  (integer 4))

Test if (NOT 0) returns T.

;;;;; TRE environment
;;;;; Copyright (c) 2009 Sven Klose <pixel@copei.de>
;;;;;
;;;;; Testing stage 0 functions

;(define-test "%NCONC"
;  ((%nconc '(1 2) '(3 4)))
;  '(1 2 3 4))

(define-test "NOT 0 is NIL"
  ((not 0))
  nil)

(define-test "%NCONC with NIL first"
  ((%nconc nil '(3 4)))
  '(3 4))

(define-test "%NCONC with NIL second"
  ((%nconc '(1 2) nil))
  '(1 2))

(define-test "LENGHT with conses"
  ((length '(1 2 3 4)))
  (integer 4))

(define-test "LENGHT with strings"
  ((length "test"))
  (integer 4))


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

(defvar *t*
  (find-bridge-class 't))

(defvar *standard-reader-method*
  (find-bridge-class 'standard-reader-method))

(defvar *standard-writer-method*
  (find-bridge-class 'standard-writer-method))

(defvar *standard-object*
  (find-bridge-class 'standard-object))

(defvar *funcallable-standard-object*
  (find-bridge-class 'funcallable-standard-object))

(defvar *standard-direct-slot-definition*
  (find-bridge-class 'standard-direct-slot-definition))

(defvar *standard-effective-slot-definition*
  (find-bridge-class 'standard-effective-slot-definition))

Define *T* as a symbol macro for finding target class.

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

(define-symbol-macro *t*
  (find-target-class 't))

(defvar *standard-reader-method*
  (find-bridge-class 'standard-reader-method))

(defvar *standard-writer-method*
  (find-bridge-class 'standard-writer-method))

(defvar *standard-object*
  (find-bridge-class 'standard-object))

(defvar *funcallable-standard-object*
  (find-bridge-class 'funcallable-standard-object))

(defvar *standard-direct-slot-definition*
  (find-bridge-class 'standard-direct-slot-definition))

(defvar *standard-effective-slot-definition*
  (find-bridge-class 'standard-effective-slot-definition))


;;;;; XCVB-Utils. Mix and match utilities from xcvb, asdf, alexandria, fare-utils

#+xcvb
(module
 (:build-depends-on ((:asdf "alexandria")
                     (:asdf "fare-utils")
                     (:asdf "asdf-utils")
                     "/xcvb/driver")))

(asdf/package:define-package :xcvb-utils
  (:mix :fare-utils :asdf/driver :alexandria)
  (:reexport :fare-utils :asdf/driver :alexandria))

Use asdf-driver, not asdf-utils anymore.

;;;;; XCVB-Utils. Mix and match utilities from xcvb, asdf, alexandria, fare-utils

#+xcvb
(module
 (:build-depends-on ((:asdf "alexandria")
                     (:asdf "fare-utils")
                     (:asdf "asdf-utils")
                     "/xcvb/driver")))

(asdf/package:define-package :xcvb-utils
  (:mix :asdf/driver :fare-utils :alexandria)
  (:reexport :asdf/driver :fare-utils :alexandria))


(in-package #:sicl-compiler)

(defun compile-file (input-file &key
				(output-file nil output-file-p)
				(verbose *compile-verbose*)
				(print *compile-print*)
				(external-format :default))

  (with-open-file (stream input-file
			  :direction :input
			  :external-format external-format)
    (let* ((*compile-file-pathname* (merge-pathnames input-file))
	   (*compile-file-truename* (truename *compile-file-pathname*))
	   (*package* *package*)
	   (*readtable* *readtable*)
	   (sicl-compiler-phase-1:*compile-file* t))
      (sicl-ast:make-progn-ast
       (loop with eof-value = (list nil)
	     for form = (read stream nil eof-value)
	     until (eq form eof-value)
	     for result = (sicl-compiler-phase-1:convert-initial form)
	     unless (null result)
	       collect result)))))

Use the SICL reader in COMPILE-FILE.

(in-package #:sicl-compiler)

(defun compile-file (input-file &key
				(output-file nil output-file-p)
				(verbose *compile-verbose*)
				(print *compile-print*)
				(external-format :default))

  (with-open-file (stream input-file
			  :direction :input
			  :external-format external-format)
    (let* ((*compile-file-pathname* (merge-pathnames input-file))
	   (*compile-file-truename* (truename *compile-file-pathname*))
	   (*package* *package*)
	   (*readtable* *readtable*)
	   (sicl-compiler-phase-1:*compile-file* t))
      (sicl-ast:make-progn-ast
       (loop with eof-value = (list nil)
	     for form = (sicl-reader:read stream nil eof-value)
	     until (eq form eof-value)
	     for result = (sicl-compiler-phase-1:convert-initial form)
	     unless (null result)
	       collect result)))))


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

(eval-when (:compile-toplevel :load-toplevel :execute)
  (fmakunbound 'defgeneric))

(defmacro defgeneric (name parameters)
  `(progn
     (let* ((class (find-bridge-class 'standard-generic-function))
	    (fun (make-instance-default class
		   :name ',name
		   :lambda-list ',parameters
		   :method-class (find-bridge-class 'standard-method))))
       (push (cons ',name fun) *target-generic-functions*))))

Use MAKE-INSTANCE instead of MAKE-INSTANCE-DEFAULT.

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

(eval-when (:compile-toplevel :load-toplevel :execute)
  (fmakunbound 'defgeneric))

(defmacro defgeneric (name parameters)
  `(progn
     (let* ((class (find-bridge-class 'standard-generic-function))
	    (fun (make-instance class
		   :name ',name
		   :lambda-list ',parameters
		   :method-class (find-bridge-class 'standard-method))))
       (push (cons ',name fun) *target-generic-functions*))))


(cl:in-package #:clump-test)

(defun in-order-traversal (tree)
  (let ((result '()))
    (clump-binary-tree:recursive-traversal
     tree
     ;; Function PRE.  Do nothing.
     (constantly t)
     ;; Function IN.
     (lambda (node)
       (push (data node) result)
       t)
     ;; Function POST.  Do nothing.
     #'identity)
    result))

Add comment explaining how we test the SPLAY operation.

(cl:in-package #:clump-test)

;;; We know that the SPLAY operation preserves an in-order traversal
;;; of the tree.  Therefore, we test the SPLAY operation by the
;;; following steps:
;;;
;;;  1. Generate a random tree
;;;  2. Make an in-order traversal of that tree, saving the result
;;;  3. Select a random node of the random tree.
;;;  4. Splay the selected node.
;;;  5. Make an in-order traversal of the splayed node, saving the result.
;;;  6. Compare the two in-order traversals.

(defun in-order-traversal (tree)
  (let ((result '()))
    (clump-binary-tree:recursive-traversal
     tree
     ;; Function PRE.  Do nothing.
     (constantly t)
     ;; Function IN.
     (lambda (node)
       (push (data node) result)
       t)
     ;; Function POST.  Do nothing.
     #'identity)
    result))


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

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

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

Make loading relative to ASDF system location.

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

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

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


;; This file is part of yason, a Common Lisp JSON parser/encoder
;;
;; Copyright (c) 2008 Hans Hbner
;; All rights reserved.
;;
;; Please see the file LICENSE in the distribution.

;;;; -*- Mode: LISP -*-

(in-package :cl-user)

(defpackage :yason.system
  (:use :cl :asdf))

(in-package :yason.system)

(defsystem :yason
  :name "yason"
  :author "Hans Huebner <hans@huebner.org>"
  :version "1"
  :maintainer "Hans Huebner <hans@huebner.org>"
  :licence "BSD"
  :description "JSON parser/encoder"
  :long-description ""

  :depends-on ()

  :components ((:file "package")
	       (:file "encode" :depends-on ("package"))
	       (:file "parse" :depends-on ("package"))))

Add missing dependency on alexandria

;; This file is part of yason, a Common Lisp JSON parser/encoder
;;
;; Copyright (c) 2008 Hans Hbner
;; All rights reserved.
;;
;; Please see the file LICENSE in the distribution.

;;;; -*- Mode: LISP -*-

(in-package :cl-user)

(defpackage :yason.system
  (:use :cl :asdf))

(in-package :yason.system)

(defsystem :yason
  :name "yason"
  :author "Hans Huebner <hans@huebner.org>"
  :version "1"
  :maintainer "Hans Huebner <hans@huebner.org>"
  :licence "BSD"
  :description "JSON parser/encoder"
  :long-description ""

  :depends-on (:alexandria)

  :components ((:file "package")
	       (:file "encode" :depends-on ("package"))
	       (:file "parse" :depends-on ("package"))))


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

(defvar *terpri* (format nil "~%"))

Use CODE-CHAR instead of FORMAT.

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

(defvar *terpri* (string (code-char 10)))


(ql:quickload :fiveam)
(defsystem :cqlcl
  :author "Aaron France"
  :version "0.0.1"
  :license "BSD"
  :description "CQLv2 binary protocol"
  :serial t
  :components ((:file "package")
               (:file "util")
               (:file "constants")
               (:file "types")
               (:file "headers")
               (:file "protocol")
               (:file "conn"))
  :depends-on (:pooler
               :alexandria
               :flexi-streams
               :uuid
               :split-sequence
               :usocket)
  :in-order-to ((test-op (test-op :cqlcl-test))))

(defsystem cqlcl-test
  :version "0.0.1"
  :description "CQLv2 binary protocol tests"
  :licence "BSD"
  :components ((:module "test"
                        :components
                        ((:file "tests"))))
  :depends-on (:cqlcl :fiveam :alexandria :flexi-streams :uuid)
  :perform (test-op (o s) (fiveam:run! :cqlcl)))

Comment out the testing related things until they work properly

(defsystem :cqlcl
  :author "Aaron France"
  :version "0.0.1"
  :license "BSD"
  :description "CQLv2 binary protocol"
  :serial t
  :components ((:file "package")
               (:file "util")
               (:file "constants")
               (:file "types")
               (:file "headers")
               (:file "protocol")
               (:file "conn"))
  :depends-on (:pooler
               :alexandria
               :flexi-streams
               :uuid
               :split-sequence
               :usocket)
  :in-order-to ((test-op (test-op :cqlcl-test))))

(defsystem cqlcl-test
  :version "0.0.1"
  :description "CQLv2 binary protocol tests"
  :licence "BSD"
  :components ((:module "test"
                        :components
                        ((:file "tests"))))
  ;; :defsystem-depends-on (:fiveam)
  :depends-on (:cqlcl :fiveam :alexandria :flexi-streams :uuid)
  ;; :perform (test-op (o s) (fiveam:run! :cqlcl))
  )


(in-package :cqlcl)

(defmacro rev-hash (ht)
  (let ((ht-sym (gensym "hash-table"))
        (ht-orig (gensym "hash-table-orig"))
        (k (gensym))
        (v (gensym)))
    `(let* ((,ht-orig ,ht)
            (,ht-sym (make-hash-table :size (hash-table-count ,ht) :test #'equal)))
       (maphash (lambda (,k ,v)
                  (setf (gethash ,v ,ht-sym) ,k)) ,ht-orig)
       ,ht-sym)))

(defun make-stream-from-byte-vector (bv)
  (flexi-streams:make-flexi-stream
   (flexi-streams:make-in-memory-input-stream bv)))

Add some helper methods for debugging streams

(in-package :cqlcl)

(defmacro rev-hash (ht)
  (let ((ht-sym (gensym "hash-table"))
        (ht-orig (gensym "hash-table-orig"))
        (k (gensym))
        (v (gensym)))
    `(let* ((,ht-orig ,ht)
            (,ht-sym (make-hash-table :size (hash-table-count ,ht) :test #'equal)))
       (maphash (lambda (,k ,v)
                  (setf (gethash ,v ,ht-sym) ,k)) ,ht-orig)
       ,ht-sym)))

(defun make-stream-from-byte-vector (bv)
  (flexi-streams:make-flexi-stream
   (flexi-streams:make-in-memory-input-stream bv)))

(defun empty? (thing)
  (zerop (length thing)))

(defmacro while (condition &rest body)
  `(loop while ,condition
      do
        ,@body))

(defun drain-stream (stream)
  (while (listen stream)
    (print (read-byte stream)))
  (values))


(cl:defpackage #:bubble-operator-upwards_tests
  (:use #:cl #:parachute)
  (:import-from #:bubble-operator-upwards #:bubble-operator-upwards #:cartesian-product))

(cl:in-package #:bubble-operator-upwards_tests)

(define-test "featured-examples"
  (is equal
      (bubble-operator-upwards 'and '(plate (and ham eggs) beans))
      '(and (plate ham beans) (plate eggs beans)))
  (is equal
      (bubble-operator-upwards 'alt '(section (alt 1 2 3) - (alt "a" "b"))
                               :result-kind :branches)
      '((section 1 - "a") (section 1 - "b")
        (section 2 - "a") (section 2 - "b")
        (section 3 - "a") (section 3 - "b")))
  (is equal
      (bubble-operator-upwards 'or '(>> (or ul ol)
                                     (or (:class (or "important" "urgent"))
                                      (id "first-priority"))))
      '(or
        (>> ul (:class "important"))
        (>> ul (:class "urgent"))
        (>> ul (id "first-priority"))
        (>> ol (:class "important"))
        (>> ol (:class "urgent"))
        (>> ol (id "first-priority"))))
  (is equal
      (cartesian-product '(1 2) '(a b c))
      '((1 a) (1 b) (1 c)
        (2 a) (2 b) (2 c))))

Use proper argument order for IS.

(cl:defpackage #:bubble-operator-upwards_tests
  (:use #:cl #:parachute)
  (:import-from #:bubble-operator-upwards #:bubble-operator-upwards #:cartesian-product))

(cl:in-package #:bubble-operator-upwards_tests)

(define-test "featured-examples"
  (is equal '(and (plate ham beans) (plate eggs beans))
      (bubble-operator-upwards 'and '(plate (and ham eggs) beans)))
  (is equal '((section 1 - "a") (section 1 - "b")
              (section 2 - "a") (section 2 - "b")
              (section 3 - "a") (section 3 - "b"))
      (bubble-operator-upwards 'alt '(section (alt 1 2 3) - (alt "a" "b"))
                               :result-kind :branches))
  (is equal '(or
              (>> ul (:class "important"))
              (>> ul (:class "urgent"))
              (>> ul (id "first-priority"))
              (>> ol (:class "important"))
              (>> ol (:class "urgent"))
              (>> ol (id "first-priority")))
      (bubble-operator-upwards 'or '(>> (or ul ol)
                                     (or (:class (or "important" "urgent"))
                                      (id "first-priority")))))
  (is equal '((1 a) (1 b) (1 c)
              (2 a) (2 b) (2 c))
      (cartesian-product '(1 2) '(a b c))))


;;; -*- lisp -*-

(defpackage :clim-examples.system
  (:use :cl :asdf))

(in-package :clim-examples.system)

;;; CLIM-Examples depends on having at least one backend loaded.
(defsystem :clim-examples
    :depends-on (:mcclim)
    :components
    ((:module "Examples"
              :components
              ((:file "calculator")
               (:file "colorslider")
	       (:file "menutest") ; extra
               (:file "address-book")
               (:file "traffic-lights")
               (:file "clim-fig")
               (:file "postscript-test")
               (:file "puzzle")
               (:file "transformations-test")
	       (:file "demodemo" :depends-on ("tabdemo"))
               (:file "stream-test")
               (:file "presentation-test")
               (:file "dragndrop")
	       (:file "gadget-test")
               (:file "accepting-values")
               (:file "method-browser")
	       (:file "stopwatch")
	       (:file "dragndrop-translator")
               (:file "draggable-graph")
               (:file "text-size-test")
               (:file "drawing-benchmark")
               (:file "logic-cube")
               (:file "views")
               (:file "font-selector")
               (:file "tabdemo")))
     (:module "Goatee"
	      :components
	      ((:file "goatee-test")))))

Add border and misc tests to examples system.

;;; -*- lisp -*-

(defpackage :clim-examples.system
  (:use :cl :asdf))

(in-package :clim-examples.system)

;;; CLIM-Examples depends on having at least one backend loaded.
(defsystem :clim-examples
    :depends-on (:mcclim)
    :components
    ((:module "Examples"
              :components
              ((:file "calculator")
               (:file "colorslider")
	       (:file "menutest") ; extra
               (:file "address-book")
               (:file "traffic-lights")
               (:file "clim-fig")
               (:file "postscript-test")
               (:file "puzzle")
               (:file "transformations-test")
	       (:file "demodemo" :depends-on ("tabdemo"))
               (:file "stream-test")
               (:file "presentation-test")
               (:file "dragndrop")
	       (:file "gadget-test")
               (:file "accepting-values")
               (:file "method-browser")
	       (:file "stopwatch")
	       (:file "dragndrop-translator")
               (:file "draggable-graph")
               (:file "text-size-test")
               (:file "drawing-benchmark")
               (:file "logic-cube")
               (:file "views")
               (:file "font-selector")
               (:file "tabdemo")
               (:file "bordered-output-examples")
               (:file "misc-tests")))
     (:module "Goatee"
	      :components
	      ((:file "goatee-test")))))


;;
;; Copyright (c) 2005-2010, Peter Seibel. All rights reserved.
;;

(asdf:defsystem com.gigamonkeys.binary-data
  :name "binary-data"
  :author "Peter Seibel <peter@gigamonkeys.com>"
  :components
  ((:file "packages")
   (:file "binary-data" :depends-on ("packages"))
   (:file "common-datatypes" :depends-on ("packages" "binary-data")))
  :depends-on (alexandria))

Add description to .asd file.

;;
;; Copyright (c) 2005-2011, Peter Seibel. All rights reserved.
;;

(defsystem com.gigamonkeys.binary-data
  :name "binary-data"
  :description "Library for reading and writing binary data."
  :author "Peter Seibel <peter@gigamonkeys.com>"
  :components
  ((:file "packages")
   (:file "binary-data" :depends-on ("packages"))
   (:file "common-datatypes" :depends-on ("packages" "binary-data")))
  :depends-on (alexandria))


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

(defsystem :sicl-sequence-support
  :serial t
  :components
  ((:file "packages")
   (:file "find")
   (:file "position")))

Add existing component utilities to system definition.

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

(defsystem :sicl-sequence-support
  :serial t
  :components
  ((:file "packages")
   (:file "utilities")
   (:file "find")
   (:file "position")))


(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~%"))

Select appropriate elements of the DEFGENERIC form.

(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 ',(second form) ,(r1 boot))
		  (ensure-generic-function
		   ',(second form)
		   :name ',(second form)
		   :lambda-list ',(third form))
		  (setf (sicl-genv:fdefinition ',(second form) ,(c1 boot))
			(sicl-genv:fdefinition ',(second form) ,(r1 boot)))))))

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


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

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

(load (rp "../../Environment/lambda.lisp"))
(load (rp "../../Environment/multiple-value-bind.lisp"))

Load a file containing the SETF macro.

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

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

(load (rp "../../Environment/lambda.lisp"))
(load (rp "../../Environment/multiple-value-bind.lisp"))
(load (rp "../../Environment/setf.lisp"))


(asdf:defsystem #:place-modifiers

  :author "Jean-Philippe Paradis <hexstream@gmail.com>"

  ;; See the UNLICENSE file for details.
  :license "Public Domain"

  :description "Essentially gives access to hundreds of modify macros with one single symbol: MODIFY."

  :depends-on (#:map-bind)

  :version "2.0"
  :serial cl:t
  :components ((:file "package")
               (:file "info")
               (:file "main")
               (:file "definitions")))

Fix broken build due to undeclared dependency on cartesian-product-switch.

(asdf:defsystem #:place-modifiers

  :author "Jean-Philippe Paradis <hexstream@gmail.com>"

  ;; See the UNLICENSE file for details.
  :license "Public Domain"

  :description "Essentially gives access to hundreds of modify macros with one single symbol: MODIFY."

  :depends-on (#:map-bind
               #:cartesian-product-switch)

  :version "2.0.1"
  :serial cl:t
  :components ((:file "package")
               (:file "info")
               (:file "main")
               (:file "definitions")))


(in-package #:sicl-clos)

(define-built-in-class sequence (t))

(define-built-in-class list (sequence))

(defclass symbol ()
  ((%name :initarg :name :reader symbol-name)
   (%package :initarg :package :reader symbol-package)
   (%plist :initform '() :accessor symbol-plist)))

(define-built-in-class null (symbol list))

Change syntax to include slot specs.

(in-package #:sicl-clos)

(define-built-in-class sequence (t)
  ())

(define-built-in-class list (sequence)
  ())

(define-built-in-class symbol ()
  ((%name :initarg :name :reader symbol-name)
   (%package :initarg :package :reader symbol-package)))

(define-built-in-class null (symbol list)
  ())


(in-package #:sicl-package)

(defclass package (t)
  ((%name
    :initarg :name
    :accessor name)
   (%nicknames
    :initarg :nicknames
    :initform '()
    :accessor nicknames)
   (%use-list
    :initarg :use-list
    :initform '()
    :accessor use-list)
   (%used-by-list
    :initarg :used-by-list
    :initform '()
    :accessor used-by-list)
   (%external-symbols
    :initarg :external-symbols
    :initform '()
    :accessor external-symbols)
   (%internal-symbols
    :initarg :internal-symbols
    :initform '()
    :accessor internal-symbols)
   (%shadowing-symbols
    :initarg :shadowing-symbols
    :initform '()
    :accessor shadowing-symbols))
  (:metaclass built-in-class))

Use explicit package prefix for IN-PACKAGE.

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

(defclass package (t)
  ((%name
    :initarg :name
    :accessor name)
   (%nicknames
    :initarg :nicknames
    :initform '()
    :accessor nicknames)
   (%use-list
    :initarg :use-list
    :initform '()
    :accessor use-list)
   (%used-by-list
    :initarg :used-by-list
    :initform '()
    :accessor used-by-list)
   (%external-symbols
    :initarg :external-symbols
    :initform '()
    :accessor external-symbols)
   (%internal-symbols
    :initarg :internal-symbols
    :initform '()
    :accessor internal-symbols)
   (%shadowing-symbols
    :initarg :shadowing-symbols
    :initform '()
    :accessor shadowing-symbols))
  (:metaclass built-in-class))


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

(defmethod initialize-instance :after
    ((class regular-class) &rest initargs &key &allow-other-keys)
  (apply #'initialize-instance-after-regular-class-default
	 class initargs))

(defmethod shared-initialize :around
    ((class real-class)
     slot-names
     &rest initargs
     &key
     &allow-other-keys)
  (apply #'shared-initialize-around-real-class-default
	 #'call-next-method
	 class
	 slot-names
	 initargs))

;;; According to the AMOP, calling initialize-instance on a built-in
;;; class (i.e., on an instance of a subclass of the class
;;; BUILT-IN-CLASS) signals an error, because built-in classes can not
;;; be created by the user.  But during the bootstrapping phase we
;;; need to create built-in classes.  We solve this problem by
;;; removing this method once the bootstrapping phase is finished.
;;;
;;; We do not add readers and writers here, because we do it in
;;; ENSURE-BUILT-IN-CLASS after we have finalized inheritance.  The
;;; reason for that is that we then know the slot location.
(defmethod initialize-instance :after
    ((class built-in-class) &rest initargs &key &allow-other-keys)
  (apply #'initialize-instance-after-built-in-class-default
	 class initargs))

;;; I don't know why this definition makes SBCL go into an infinite
;;; recursion.
;; (defmethod reinitialize-instance :after
;;     ((class standard-class)
;;      &rest args
;;      &key
;;      &allow-other-keys)
;;   (map-dependents class
;; 		  (lambda (dependent)
;; 		    (apply #'update-dependent class dependent args))))

Remove :AFTER methods. What they did is now in the :AROUND method.

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

(defmethod shared-initialize :around
    ((class real-class)
     slot-names
     &rest initargs
     &key
     &allow-other-keys)
  (apply #'shared-initialize-around-real-class-default
	 #'call-next-method
	 class
	 slot-names
	 initargs))


;;; -*- Mode: Lisp -*-

;;;  (c) copyright 2008 by
;;;           Troels Henriksen (athas@sigkill.dk)
;;;
;;; 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.

(asdf:defsystem :mcclim-gif-bitmaps
  :description "Support for GIF images in McCLIM bitmap reading functions."
  :depends-on (:mcclim :skippy)
  :components ((:file "gif" :pathname #P"Extensions/Bitmap-formats/gif")))

Define system in package ASDF-USER.

;;; -*- Mode: Lisp -*-

;;;  (c) copyright 2008 by
;;;           Troels Henriksen (athas@sigkill.dk)
;;;
;;; 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.

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

(defsystem :mcclim-gif-bitmaps
  :description "Support for GIF images in McCLIM bitmap reading functions."
  :depends-on (:mcclim :skippy)
  :components ((:file "gif" :pathname #P"Extensions/Bitmap-formats/gif")))


(in-package #:cl-user)

(asdf:defsystem :sicl-sequences-small
  :depends-on ("sicl-additional-types"
	       "sicl-additional-conditions"
	       "cleavir-code-utilities")
  :components
  ((:file "packages" :depends-on ())
   (:file "sequences" :depends-on ("packages"))))

Use explicit package prefix for IN-PACKAGE, and define system in package ASDF-USER.

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

(defsystem :sicl-sequences-small
  :depends-on ("sicl-additional-types"
	       "sicl-additional-conditions"
	       "cleavir-code-utilities")
  :components
  ((:file "packages" :depends-on ())
   (:file "sequences" :depends-on ("packages"))))


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

(defsystem :sicl-sequences-small
  :depends-on (:sicl-additional-types
	       :sicl-additional-conditions
	       :cleavir-code-utilities)
  :components
  ((:file "packages" :depends-on ())
   (:file "sequences" :depends-on ("packages"))))

Define system with option :SERIAL T.

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

(defsystem :sicl-sequences-small
  :depends-on (:sicl-additional-types
	       :sicl-additional-conditions
	       :cleavir-code-utilities)
  :serial t
  :components
  ((:file "packages")
   (:file "sequences")))


(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)))))))

Complete rewrite using a state machine.

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

(defgeneric iterative-traversal (tree pre in post))

(defmethod iterative-traversal ((tree node-with-parent) pre in post)
  (let ((current-node tree))
    (tagbody
     pre
       (if (funcall pre current-node)
	   (let ((left (left current-node)))
	     (if (null left)
		 (go in)
		 (progn (setf current-node left)
			(go pre))))
	   (go in))
     in
       (if (funcall in current-node)
	   (let ((right (right current-node)))
	     (if (null right)
		 (go post)
		 (progn (setf current-node right)
			(go pre))))
	   (go post))
     post
       (funcall post current-node)
       (let ((parent (parent current-node)))
	 (if (null parent)
	     (return-from iterative-traversal)
	     (if (eq current-node (left parent))
		 (progn (setf current-node parent)
			(go in))
		 (progn (setf current-node parent)
			(go post))))))))


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

; Check and return keyword argument or NIL.
(%defun %defun-arg-keyword (args)
  (let a (car args)
	(let d (and (cdr args)
				(cadr args))
      (if (%arg-keyword? a)
          (if d
              (if (%arg-keyword? d)
                  (%error "keyword following keyword"))
              (%error "end after keyword"))))))

(%defun %defun-checked-args (args)
  (if args
      (or (%defun-arg-keyword args)
          (cons (car args)
				(%defun-checked-args (cdr args))))))

(%defun %defun-name (name)
  (if (atom name)
      name
      (if (eq (car name) 'SETF)
          (make-symbol (string-concat "%%USETF-" (string (cadr name))))
          (progn
			(print name)
			(%error "illegal function name")))))

(defmacro defun (name args &rest body)
  (let name (%defun-name name)
    `(block nil
	   (if *show-definitions*
	       (print `(defun ,name)))
       (setq *universe* (cons ',name *universe*)
       		 *defined-functions* (cons ',name *defined-functions*))
       (%set-atom-fun ,name
           #'(,(%defun-checked-args args)
               (block ,name
                 ,@(%add-documentation name body))))
	   (return-from nil ',name))))

Apply package to setter function names.

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

; Check and return keyword argument or NIL.
(%defun %defun-arg-keyword (args)
  (let a (car args)
	(let d (and (cdr args)
				(cadr args))
      (if (%arg-keyword? a)
          (if d
              (if (%arg-keyword? d)
                  (%error "keyword following keyword"))
              (%error "end after keyword"))))))

(%defun %defun-checked-args (args)
  (if args
      (or (%defun-arg-keyword args)
          (cons (car args)
				(%defun-checked-args (cdr args))))))

(%defun %defun-name (name)
  (if (atom name)
      name
      (if (eq (car name) 'SETF)
          (make-symbol (string-concat "%%USETF-" (string (cadr name))) (symbol-package (cadr name)))
          (progn
			(print name)
			(%error "illegal function name")))))

(defmacro defun (name args &rest body)
  (let name (%defun-name name)
    `(block nil
	   (if *show-definitions*
	       (print `(defun ,name)))
       (setq *universe* (cons ',name *universe*)
       		 *defined-functions* (cons ',name *defined-functions*))
       (%set-atom-fun ,name
           #'(,(%defun-checked-args args)
               (block ,name
                 ,@(%add-documentation name body))))
	   (return-from nil ',name))))


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

(asdf:defsystem :sicl-compiler-test-utilities
  :depends-on (:sicl-compiler-utilities)
  :components
  ((:file "packages")
   (:file "test-utilities" :depends-on ("packages"))))

Define ASDF system in package ASDF-USER.

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

(defsystem :sicl-compiler-test-utilities
  :depends-on (:sicl-compiler-utilities)
  :components
  ((:file "packages")
   (:file "test-utilities" :depends-on ("packages"))))


;;;; Copyright (c) 2014
;;;;
;;;;     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.

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

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Clause FOR-AS-ACROSS

(defclass for-as-across (for-as-subclause var-and-type-spec-mixin)
  ((%array-form :initarg :array-form :reader array-form)
   (%form-var :initform (gensym) :reader form-var)
   (%length-var  :initform (gensym) :reader length-var)
   (%index-var  :initform (gensym) :reader index-var)))

Define a parser for FOR-AS-ACROSS.

;;;; Copyright (c) 2014
;;;;
;;;;     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.

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

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Clause FOR-AS-ACROSS

(defclass for-as-across (for-as-subclause var-and-type-spec-mixin)
  ((%vector-form :initarg :vector-form :reader vector-form)
   (%form-var :initform (gensym) :reader form-var)
   (%length-var :initform (gensym) :reader length-var)
   (%index-var :initform (gensym) :reader index-var)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parser

(define-parser for-as-across-parser
  (consecutive (lambda (var type-spec across vector-form)
		 (declare (ignore across))
		 (make-instance 'for-as-across
		   :var-spec var
		   :type-spec type-spec
		   :vector-form vector))
	       'd-var-spec-parser
	       'optional-type-spec-parser
	       (keyword-parser 'across)
	       (singleton #'identity (constantly t))))


#|
 This file is a part of grouping-stack
 (c) 2014 Shirakumo http://tymoon.eu (shinmera@tymoon.eu)
 Author: Nicolas Hafner <shinmera@tymoon.eu>
|#

(in-package #:org.shirakumo.grouping-stack)

(defclass balancer ()
  ())

(defclass inactive-balancer (balancer)
  ())

(defmethod balance ((stack grouping-stack) (balancer inactive-balancer))
  (declare (ignore balancer))
  stack)

(defclass sink-balancer (balancer)
  ((buffer-size :initarg :buffer-size :initform 2 :accessor buffer-size)))

(defmethod balance ((stack grouping-stack) (balancer sink-balancer))
  (let ((items (nthcdr (buffer-size balancer) (stack-items stack))))
    (unless (null (cdr items))
      (setf (car items) (make-instance 'item :content (apply #'group (mapcar #'content items)))
            (cdr items) NIL))))

Fix for old name mismatch

#|
 This file is a part of grouping-stack
 (c) 2014 Shirakumo http://tymoon.eu (shinmera@tymoon.eu)
 Author: Nicolas Hafner <shinmera@tymoon.eu>
|#

(in-package #:org.shirakumo.grouping-stack)

(defclass balancer ()
  ())

(defclass inactive-balancer (balancer)
  ())

(defmethod balance ((stack grouping-stack) (balancer inactive-balancer))
  (declare (ignore balancer))
  stack)

(defclass sink-balancer (balancer)
  ((buffer-size :initarg :buffer-size :initform 2 :accessor buffer-size)))

(defmethod balance ((stack grouping-stack) (balancer sink-balancer))
  (let ((items (nthcdr (buffer-size balancer) (stack-items stack))))
    (unless (null (cdr items))
      (setf (car items) (make-instance 'item :content (apply #'combine (mapcar #'content items)))
            (cdr items) NIL))))


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

(defmethod reader-method-class
    ((class standard-class)
     (direct-slot standard-direct-slot-definition)
     &rest initargs)
  (apply #'reader-method-class-default class direct-slot initargs))

(defmethod reader-method-class
    ((class funcallable-standard-class)
     (direct-slot standard-direct-slot-definition)
     &rest initargs)
  (apply #'reader-method-class-default class direct-slot initargs))

(defmethod writer-method-class
    ((class standard-class)
     (direct-slot standard-direct-slot-definition)
     &rest initargs)
  (apply #'writer-method-class-default class direct-slot initargs))

(defmethod writer-method-class
    ((class funcallable-standard-class)
     (direct-slot standard-direct-slot-definition)
     &rest initargs)
  (apply #'writer-method-class-default class direct-slot initargs))

Simplify by factoring methods to specilize on REGULAR-CLASS.

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

(defmethod reader-method-class
    ((class regular-class)
     (direct-slot standard-direct-slot-definition)
     &rest initargs)
  (apply #'reader-method-class-default class direct-slot initargs))

(defmethod writer-method-class
    ((class regular-class)
     (direct-slot standard-direct-slot-definition)
     &rest initargs)
  (apply #'writer-method-class-default class direct-slot initargs))


;;;; Eval-bot --- An IRC bot for evaluating Common Lisp expressions

;; Copyright (C) 2013 Teemu Likonen <tlikonen@iki.fi>
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU Affero General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;;
;; This program 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
;; Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public
;; License along with this program. If not, see
;; <http://www.gnu.org/licenses/>.

(cl:defpackage #:sandbox-extra)
(cl:in-package #:sandbox-extra)

(cl:declaim (cl:optimize (cl:safety 3)))

(cl:loop
 :for func :in '(help)
 :do
 (cl:setf (cl:get func :sandbox-locked) cl:t)
 (cl:export (cl:list func))
 (cl:eval
  `(cl:defun ,func (cl:&rest args)
     (cl:signal
      'common:extra-command
      :command (cl:symbol-name ',func)
      :arguments args))))

(cl:define-symbol-macro help (help))

Implement "help" command only as a symbol macro, not as a function

;;;; Eval-bot --- An IRC bot for evaluating Common Lisp expressions

;; Copyright (C) 2013 Teemu Likonen <tlikonen@iki.fi>
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU Affero General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;;
;; This program 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
;; Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public
;; License along with this program. If not, see
;; <http://www.gnu.org/licenses/>.

(cl:defpackage #:sandbox-extra)
(cl:in-package #:sandbox-extra)

(cl:declaim (cl:optimize (cl:safety 3)))

(cl:define-symbol-macro help
    (cl:signal 'common:extra-command
               :command "help"
               :arguments cl:nil))

(cl:setf (cl:get 'help :sandbox-locked) cl:t)
(cl:export 'help)


(in-package :cl-user)
(defpackage sxql.statement
  (:use :cl
        :sxql.sql-type)
  (:import-from :sxql.operator
                :find-constructor
                :detect-and-convert))
(in-package :sxql.statement)

(cl-syntax:use-syntax :annot)

(defstruct (select-statement (:include sql-composed-statement (name "SELECT"))
                             (:constructor make-select-statement (&rest children))))

(defstruct (insert-into-statement (:include sql-composed-statement (name "INSERT INTO"))
                                  (:constructor make-insert-into-statement (&rest children))))

(defstruct (update (:include sql-composed-statement (name "UPDATE"))
                   (:constructor make-update-statement (&rest children))))

(defstruct (delete-from (:include sql-composed-statement (name "DELETE FROM"))
                        (:constructor make-delete-from-statement (&rest children))))

(defun find-make-statement (statement-name &optional (package *package*))
  (find-constructor statement-name #.(string :-statement)
                    :package package))

@export
(defun make-statement (statement-name &rest args)
  (apply (find-make-statement statement-name #.*package*)
         (mapcar #'detect-and-convert args)))

Fix the structure names of INSERT and UPDATE.

(in-package :cl-user)
(defpackage sxql.statement
  (:use :cl
        :sxql.sql-type)
  (:import-from :sxql.operator
                :find-constructor
                :detect-and-convert))
(in-package :sxql.statement)

(cl-syntax:use-syntax :annot)

(defstruct (select-statement (:include sql-composed-statement (name "SELECT"))
                             (:constructor make-select-statement (&rest children))))

(defstruct (insert-into-statement (:include sql-composed-statement (name "INSERT INTO"))
                                  (:constructor make-insert-into-statement (&rest children))))

(defstruct (update-statement (:include sql-composed-statement (name "UPDATE"))
                             (:constructor make-update-statement (&rest children))))

(defstruct (delete-from-statement (:include sql-composed-statement (name "DELETE FROM"))
                                  (:constructor make-delete-from-statement (&rest children))))

(defun find-make-statement (statement-name &optional (package *package*))
  (find-constructor statement-name #.(string :-statement)
                    :package package))

@export
(defun make-statement (statement-name &rest args)
  (apply (find-make-statement statement-name #.*package*)
         (mapcar #'detect-and-convert args)))


(in-package #:sicl-compiler)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Function COMPILE-FILE.

(defun compile-file (input-file &key
				  (output-file nil output-file-p)
				  (verbose *compile-verbose*)
				  (print *compile-print*)
				  (external-format :default))
  (declare (ignore output-file output-file-p verbose print))
  (with-open-file (stream input-file
			  :direction :input
			  :external-format external-format)
    (let* ((*compile-file-pathname* (merge-pathnames input-file))
	   (*compile-file-truename* (truename *compile-file-pathname*))
	   (*package* *package*)
	   (*readtable* *readtable*)
	   (*cross-compiling-p* nil)
	   (*top-level-asts* '()))
      (loop with eof-value = (list nil)
	    for form = (sicl-reader:read stream nil eof-value)
	    until (eq form eof-value)
	    do (process-top-level-form form nil)))))

Use explicit package marker for IN-PACKAGE.

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

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Function COMPILE-FILE.

(defun compile-file (input-file &key
				  (output-file nil output-file-p)
				  (verbose *compile-verbose*)
				  (print *compile-print*)
				  (external-format :default))
  (declare (ignore output-file output-file-p verbose print))
  (with-open-file (stream input-file
			  :direction :input
			  :external-format external-format)
    (let* ((*compile-file-pathname* (merge-pathnames input-file))
	   (*compile-file-truename* (truename *compile-file-pathname*))
	   (*package* *package*)
	   (*readtable* *readtable*)
	   (*cross-compiling-p* nil)
	   (*top-level-asts* '()))
      (loop with eof-value = (list nil)
	    for form = (sicl-reader:read stream nil eof-value)
	    until (eq form eof-value)
	    do (process-top-level-form form nil)))))


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

(asdf:defsystem :sicl-simple-environment
  :depends-on (:sicl-global-environment)
  :serial t
  :components
  ((:file "packages")
   (:file "environment")
   (:file "methods")))

Use package ASDF-USER for defining system.

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

(defsystem :sicl-simple-environment
  :depends-on (:sicl-global-environment)
  :serial t
  :components
  ((:file "packages")
   (:file "environment")
   (:file "methods")))


;;;;; Caroshi – Copyright (c) 2009–2013 Sven Michael Klose <pixel@copei.de>

(defun sql-clause-where (alst)
  (!? alst
      (+ " WHERE "
         (? (string? !)
            !
            (alist-assignments ! :padding " AND ")))))

(defun sql-clause-select (&key table (fields nil) (where nil) (limit nil) (offset nil) (order-by nil) (direction nil))
  (apply #'string-concat
         `("SELECT " ,@(!? fields
                           (comma-separated-list (symbol-names ! :downcase? t))
                           (list "*"))
           " FROM " ,table
           ,(sql-clause-where where)
           ,(!? order-by  (+ " ORDER BY " !))
           ,(!? direction (+ " " !))
           ,(!? limit     (+ " LIMIT " !))
           ,(!? (& offset
                   (not (zero? offset)))
                (+ " OFFSET " !)))))

Check if :LIMIT and :OFFSET are used together.

;;;;; Caroshi – Copyright (c) 2009–2013 Sven Michael Klose <pixel@copei.de>

(defun sql-clause-where (alst)
  (!? alst
      (+ " WHERE "
         (? (string? !)
            !
            (alist-assignments ! :padding " AND ")))))

(defun sql-clause-select (&key table (fields nil) (where nil) (limit nil) (offset nil) (order-by nil) (direction nil))
  (when-debug
    (when (== 1 (length (remove-if #'not (list limit offset))))
      (error ":LIMIT and :OFFSET have to be used together.")))
  (apply #'string-concat
         `("SELECT " ,@(!? fields
                           (comma-separated-list (symbol-names ! :downcase? t))
                           (list "*"))
           " FROM " ,table
           ,(sql-clause-where where)
           ,(!? order-by  (+ " ORDER BY " !))
           ,(!? direction (+ " " !))
           ,(!? limit     (+ " LIMIT " !))
           ,(!? (& offset
                   (not (zero? offset)))
                (+ " OFFSET " !)))))


;; Common Lisp Script
;; Manoel Vilela

;; higher-order function sigma-sum
;; func must be a lambda(x) expression
(defun sigma-sum (func a b &key (next #'1+))
  (if (> a b)
      0
      (+ (funcall func a)
         (sigma-sum func (funcall next a) b))))

(defun square (x)
  (* x x))

(sigma-sum #'(lambda(x) (/ 1 x)) 1 10 :next #'(lambda (x) (+ 4 x)))
(sigma-sum #'(lambda(x) (- x)) 1 10)

Add a note about ideal avoiding funcall at lambda expressions material

;; Common Lisp Script
;; Manoel Vilela

;; higher-order function sigma-sum
;; func must be a lambda(x) expression
(defun sigma-sum (func a b &key (next #'1+))
  (if (> a b)
      0
      (+ (funcall func a)
         (sigma-sum func (funcall next a) b))))

;; I would like to avoid the use of 'funcall' for calling
;; lambda expressions passed to sigma-sum, is ugly.

(defun square (x)
  (* x x))

(sigma-sum #'(lambda(x) (/ 1 x)) 1 10 :next #'(lambda (x) (+ 4 x)))
(sigma-sum #'(lambda(x) (- x)) 1 10)


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

(asdf:defsystem :sicl-arithmetic
  :serial t
  :components
  ((:file "packages")
   (:file "support")))

Define ASDF system in the package ASDF-USER.

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

(defsystem :sicl-arithmetic
  :serial t
  :components
  ((:file "packages")
   (:file "support")))


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

(asdf:defsystem :sicl-conditions
  :components
  ((:file "packages")
   (:file "support"
    :depends-on ("packages"))))

Use package ASDF-USER for defining system.

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

(defsystem :sicl-conditions
  :components
  ((:file "packages")
   (:file "support"
    :depends-on ("packages"))))


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

(defclass tree ()
  ((%contents :initform nil :accessor contents)))

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

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

Define new class 2-NODE for the nodes with 2 children of the 2-3 tree.

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

(defclass tree ()
  ((%contents :initform nil :accessor contents)))

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

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

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


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

(defsystem :cleavir-dominance
  :depends-on (:cleavir-utilities
	       :cleavir-meter)
  :components
  ((:file "packages" :depends-on ())
   (:file "dominance" :depends-on ("packages"))))

Use option :SERIAL T to simplify system.

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

(defsystem :cleavir-dominance
  :depends-on (:cleavir-utilities
	       :cleavir-meter)
  :serial t
  :components
  ((:file "packages")
   (:file "dominance")))


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

(defmethod acclimation:report-condition
    ((condition invalid-binary-tree)
     stream
     (language acclimation:english))
  (format stream
	  "A binary tree was expected,~@
           but instead the following was found:~@
           ~s"
	  (tree condition)))

(defmethod acclimation:report-condition
    ((condition right-subtree-must-be-non-nil)
     stream
     (language acclimation:english))
  (format stream
	  "The right subtree of the following tree,~@
           is NIL, but a non-NIL subtree is required:~@
           ~s"
	  (tree condition)))

Add English condition reporter for LEFT-SUBTREE-MUST-BE-NON-NIL.

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

(defmethod acclimation:report-condition
    ((condition invalid-binary-tree)
     stream
     (language acclimation:english))
  (format stream
	  "A binary tree was expected,~@
           but instead the following was found:~@
           ~s"
	  (tree condition)))

(defmethod acclimation:report-condition
    ((condition right-subtree-must-be-non-nil)
     stream
     (language acclimation:english))
  (format stream
	  "The right subtree of the following tree,~@
           is NIL, but a non-NIL subtree is required:~@
           ~s"
	  (tree condition)))

(defmethod acclimation:report-condition
    ((condition left-subtree-must-be-non-nil)
     stream
     (language acclimation:english))
  (format stream
	  "The left subtree of the following tree,~@
           is NIL, but a non-NIL subtree is required:~@
           ~s"
	  (tree condition)))


(cl:in-package #:sicl-source-tracking-reader)

(defun make-contents ()
  (make-array 10
	      :fill-pointer 0
	      :element-type 'character
	      :adjustable t))

(defclass source-tracking-stream
    (trivial-gray-streams:fundamental-character-input-stream)
  ((%original :initarg :original :reader original)
   (%contents :initform (make-contents) :reader contents)
   (%index :initform 0 :accessor index)
   (%line :initform 0 :accessor line)
   (%column :initform 0 :accessor column)
   (%char-to-read :initform nil :accessor char-to-read)))

(defun make-source-tracking-stream (stream)
  (make-instance 'source-tracking-stream
    :original stream))

(defmethod trivial-gray-streams:stream-read-char
    ((stream source-tracking-stream))
  (if (null (char-to-read stream))
      (let ((char (trivial-gray-streams:stream-read-char (original stream))))
	(vector-push-extend char (contents stream) 10)
	(if (eql char #\Newline)
	    (progn (setf (column stream) 0)
		   (incf (line stream)))
	    (incf (column stream)))
	char)
      (prog1 (char-to-read stream)
	(setf (char-to-read stream) nil))))

Define method on UNREAD-CHAR specialized to SOURCE-TRACKING-STREAM.

(cl:in-package #:sicl-source-tracking-reader)

(defun make-contents ()
  (make-array 10
	      :fill-pointer 0
	      :element-type 'character
	      :adjustable t))

(defclass source-tracking-stream
    (trivial-gray-streams:fundamental-character-input-stream)
  ((%original :initarg :original :reader original)
   (%contents :initform (make-contents) :reader contents)
   (%index :initform 0 :accessor index)
   (%line :initform 0 :accessor line)
   (%column :initform 0 :accessor column)
   (%char-to-read :initform nil :accessor char-to-read)))

(defun make-source-tracking-stream (stream)
  (make-instance 'source-tracking-stream
    :original stream))

(defmethod trivial-gray-streams:stream-read-char
    ((stream source-tracking-stream))
  (if (null (char-to-read stream))
      (let ((char (trivial-gray-streams:stream-read-char (original stream))))
	(vector-push-extend char (contents stream) 10)
	(if (eql char #\Newline)
	    (progn (setf (column stream) 0)
		   (incf (line stream)))
	    (incf (column stream)))
	char)
      (prog1 (char-to-read stream)
	(setf (char-to-read stream) nil))))

(defmethod trivial-gray-streams:stream-unread-char
    ((stream source-tracking-stream) character)
  (setf (char-to-read stream) character))


;;;; Copyright (c) 2014
;;;;
;;;;     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.

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

(defclass type-spec () ())

(defclass simple-type-spec (type-spec)
  ((%type :initarg :type :reader type)))

(defclass destructured-type-spec (type-spec)
  ((%tree :initarg :tree :reader tree)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parser

(define-parser simple-type-spec
  (lambda (tokens)
    (if (and (not (null tokens))
	     (member (car tokens) '(fixnum float t nil)))
	(values t
		(make-instance 'simple-type-spec
		  :type (car tokens))
		(cdr tokens))
	(values nil nil tokens))))

(define-parser destructured-type-spec
  (consecutive (lambda (of-type tree)
		 (declare (ignore of-type))
		 (make-instance 'destructured-type-spec
		   :tree tree))
	       (keyword-parser 'of-type)
	       (singleton #'identity (constantly t))))

(define-parser type-spec
  (alternative 'simple-type-spec 'destructured-type-spec))

Use suffix -PARSER for parser functions.

;;;; Copyright (c) 2014
;;;;
;;;;     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.

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

(defclass type-spec () ())

(defclass simple-type-spec (type-spec)
  ((%type :initarg :type :reader type)))

(defclass destructured-type-spec (type-spec)
  ((%tree :initarg :tree :reader tree)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parser

(define-parser simple-type-spec-parser
  (lambda (tokens)
    (if (and (not (null tokens))
	     (member (car tokens) '(fixnum float t nil)))
	(values t
		(make-instance 'simple-type-spec
		  :type (car tokens))
		(cdr tokens))
	(values nil nil tokens))))

(define-parser destructured-type-spec-parser
  (consecutive (lambda (of-type tree)
		 (declare (ignore of-type))
		 (make-instance 'destructured-type-spec
		   :tree tree))
	       (keyword-parser 'of-type)
	       (singleton #'identity (constantly t))))

(define-parser type-spec-parser
  (alternative 'simple-type-spec 'destructured-type-spec))


(ros:include "util")
(defpackage :roswell.dump.sbcl
  (:use :cl :roswell.util))
(in-package :roswell.dump.sbcl)

(defun dump-executable (cmds out script)
  (declare (ignore script))
  (sb-ext:save-lisp-and-die
   out
   ;; no need to do GC because of :purify t by default
   ;; however, this only affects old cheyneyGC
   ;; http://www.sbcl.org/manual/#Efficiency-Hacks
   :purify t ; just here to make it explicit
   :compression t ; we all want our programs to be small, right?
   :toplevel
   #'(lambda ()
       (setf *load-pathname* (pathname (first sb-ext:*posix-argv*)))
       (setf ros:*argv* (rest sb-ext:*posix-argv*))
       (ros:run cmds))
   :executable t
   :save-runtime-options t))

(defun sbcl (type &rest args)
  (case type
    (:executable
     (apply 'dump-executable args))))

Check for sb-core-compression feature before turning on compression for SBCL.

(ros:include "util")
(defpackage :roswell.dump.sbcl
  (:use :cl :roswell.util))
(in-package :roswell.dump.sbcl)

(defun dump-executable (cmds out script)
  (declare (ignore script))
  (sb-ext:save-lisp-and-die
   out
   ;; no need to do GC because of :purify t by default
   ;; however, this only affects old cheyneyGC
   ;; http://www.sbcl.org/manual/#Efficiency-Hacks
   :purify t ; just here to make it explicit
   ; we all want our programs to be small, right?
   #+sb-core-compression :compression
   #+sb-core-compression t
   :toplevel
   #'(lambda ()
       (setf *load-pathname* (pathname (first sb-ext:*posix-argv*)))
       (setf ros:*argv* (rest sb-ext:*posix-argv*))
       (ros:run cmds))
   :executable t
   :save-runtime-options t))

(defun sbcl (type &rest args)
  (case type
    (:executable
     (apply 'dump-executable args))))


(in-package "BASIC-BINARY-IPC.TESTS")

(defmethod asdf:perform ((operation asdf:test-op) (component (eql (asdf:find-system "basic-binary-ipc-tests"))))
  (lisp-unit:run-tests :all "BASIC-BINARY-IPC.TESTS"))

Print failures and errors when performing ASDF:TEST-SYSTEM.

(in-package "BASIC-BINARY-IPC.TESTS")

(defmethod asdf:perform ((operation asdf:test-op) (component (eql (asdf:find-system "basic-binary-ipc-tests"))))
  (dolist (pkg (list "BASIC-BINARY-IPC.TESTS"))
    (let ((report (lisp-unit:run-tests :all pkg)))
      (print-failures report)
      (print-errors report))))


;; Tested on SBCL

(defmacro swap (x y)
  (let ((tmp-sym (gensym)))
    `(let (,tmp-sym)
       (setf ,tmp-sym ,x)
       (setf ,x ,y)
       (setf ,y ,tmp-sym))))

(defun use-swap ()
  (let ((a 1)
        (b 2))
    (swap a b)
    (format t "a: ~A, b: ~A~%" a b))
  (let ((my-list (list 3 4)))
    (swap (first my-list) (second my-list))
    (format t "(first my-list): ~A, (second my-list): ~A~%"
            (first my-list) (second my-list))))

(use-swap)

Set the temp symbol immediately, for consistent with our other languages.

;; Tested on SBCL

(defmacro swap (x y)
  (let ((tmp-sym (gensym)))
    `(let ((,tmp-sym ,x))
       (setf ,x ,y)
       (setf ,y ,tmp-sym))))

(defun use-swap ()
  (let ((a 1)
        (b 2))
    (swap a b)
    (format t "a: ~A, b: ~A~%" a b))
  (let ((my-list (list 3 4)))
    (swap (first my-list) (second my-list))
    (format t "(first my-list): ~A, (second my-list): ~A~%"
            (first my-list) (second my-list))))

(use-swap)


;;;; lisphys.asd

(asdf:defsystem #:lisphys
  :serial t
  :description "Describe lisphys here"
  :author "Guillaume <guillaume.saupin@gmail.com>"
  :license "Specify license here"
  :depends-on (#:clunit
	       #:alexandria)
  :components ((:file "infpre")
	       (:file "package")
	       (:file "memoization")
               (:file "autodiff")
               (:file "autodiff-test")
               (:file "math")
               (:file "vector3")
               (:file "vector3ad")
               (:file "quaternion")
               (:file "quaternionad")
               (:file "lisphys")))

Add twist and displacement to project.

;;;; lisphys.asd

(asdf:defsystem #:lisphys
  :serial t
  :description "Describe lisphys here"
  :author "Guillaume <guillaume.saupin@gmail.com>"
  :license "Specify license here"
  :depends-on (#:clunit
	       #:alexandria)
  :components ((:file "infpre")
	       (:file "package")
	       (:file "memoization")
               (:file "autodiff")
               (:file "autodiff-test")
               (:file "math")
               (:file "vector3")
               (:file "vector3ad")
               (:file "quaternion")
               (:file "quaternionad")
;               (:file "twist")
               (:file "displacement")
               (:file "lisphys")))


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

(defclass tree ()
  ((%contents :initform nil :accessor contents)))

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

(defclass leaf (node)
  ((%contents :initform nil :accessor contents)))

Change from :INITFORM to :INITARG in leaf contents slot.

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

(defclass tree ()
  ((%contents :initform nil :accessor contents)))

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

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


(cl:in-package #:cleavir-remove-useless-instructions)

(defgeneric instruction-may-be-removed-p (instruction))

(defmethod instruction-may-be-removed-p (instruction)
  (and (= (length (cleavir-ir:successors instruction)) 1)
       (loop for output in (cleavir-ir:outputs instruction)
	     always (null (cleavir-ir:using-instructions output)))))

(defmethod instruction-may-be-removed-p
    ((instruction cleavir-ir:enter-instruction))
  nil)

(defun remove-useless-instructions (initial-instruction)
  (cleavir-ir:reinitialize-data initial-instruction)
  (let ((useless-instructions '()))
    (cleavir-ir:map-instructions-arbitrary-order
     (lambda (instruction)
       (when (and (= (length (cleavir-ir:successors instruction)) 1)
		  (not (typep instruction 'cleavir-ir:funcall-instruction))
		  (loop for output in (cleavir-ir:outputs instruction)
			always (null (cleavir-ir:using-instructions output))))
	 (push instruction useless-instructions)))
     initial-instruction)
    (mapc #'cleavir-ir:delete-instruction useless-instructions)))

Add method specialized to UNWIND-INSTRUCTION.

(cl:in-package #:cleavir-remove-useless-instructions)

(defgeneric instruction-may-be-removed-p (instruction))

(defmethod instruction-may-be-removed-p (instruction)
  (and (= (length (cleavir-ir:successors instruction)) 1)
       (loop for output in (cleavir-ir:outputs instruction)
	     always (null (cleavir-ir:using-instructions output)))))

(defmethod instruction-may-be-removed-p
    ((instruction cleavir-ir:enter-instruction))
  nil)

(defmethod instruction-may-be-removed-p
    ((instruction cleavir-ir:unwind-instruction))
  nil)

(defun remove-useless-instructions (initial-instruction)
  (cleavir-ir:reinitialize-data initial-instruction)
  (let ((useless-instructions '()))
    (cleavir-ir:map-instructions-arbitrary-order
     (lambda (instruction)
       (when (and (= (length (cleavir-ir:successors instruction)) 1)
		  (not (typep instruction 'cleavir-ir:funcall-instruction))
		  (loop for output in (cleavir-ir:outputs instruction)
			always (null (cleavir-ir:using-instructions output))))
	 (push instruction useless-instructions)))
     initial-instruction)
    (mapc #'cleavir-ir:delete-instruction useless-instructions)))


(in-package :mu-support)

;;; repository definition
(defun server-location ()
  (if (find :docker *features*)
      (progn (format t "~&running inside a docker~%")
         "http://database:8890")
      (progn (format t "~&running on localhost~%")
         "http://localhost:8890")))

(defparameter *repository*
  (make-instance 'fuseki::virtuoso-repository :name "main repository"
                 :server (make-instance 'fuseki::virtuoso-server
                                        :base-url (server-location))))

(add-prefix "app" "http://mu.semte.ch/app/")
(add-prefix "xsd" "http://www.w3.org/2001/XMLSchema#")
(add-prefix "mu" "http://mu.semte.ch/vocabularies/core/")
(add-prefix "typedLiterals" "http://mu.semte.ch/vocabularies/typed-literals/")
(add-prefix "rm" "http://mu.semte.ch/vocabularies/logical-delete/")

Include mu-session-id header in sparql requests

(in-package :mu-support)

;;; repository definition
(defun server-location ()
  (if (find :docker *features*)
      (progn (format t "~&running inside a docker~%")
         "http://database:8890")
      (progn (format t "~&running on localhost~%")
         "http://localhost:8890")))

(defclass mu-semtech-repository (cl-fuseki::virtuoso-repository)
  ()
  (:documentation "repository for mu-semtech Virtuoso endpoints."))

(defun mu-semtech-headers ()
  (list (cons "mu-session-id" (webserver:header-in* :mu-session-id))))

(defmethod fuseki::query-raw ((repos mu-semtech-repository) (query string)
			      &rest options &key &allow-other-keys)
  (fuseki::flush-updates repos)
  (let ((full-query (apply #'fuseki::query-update-prefixes query options)))
    (fuseki::maybe-log-query full-query)
    (fuseki::send-request (fuseki::query-endpoint repos)
                  :accept (fuseki::get-data-type-binding :json)
                  :parameters `(("query" . ,full-query))
		  :additional-headers (mu-semtech-headers))))

(defparameter *repository*
  (make-instance 'mu-semtech-repository :name "main repository"
                 :server (make-instance 'fuseki::virtuoso-server
                                        :base-url (server-location))))

(add-prefix "app" "http://mu.semte.ch/app/")
(add-prefix "xsd" "http://www.w3.org/2001/XMLSchema#")
(add-prefix "mu" "http://mu.semte.ch/vocabularies/core/")
(add-prefix "typedLiterals" "http://mu.semte.ch/vocabularies/typed-literals/")
(add-prefix "rm" "http://mu.semte.ch/vocabularies/logical-delete/")