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

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

Add test code for MAGIC-BUFFER.

Add test code for MAGIC-BUFFER.


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

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

Remove the hcat.lisp reference (for now).


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

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

Add qualifiers to DEFGLOBAL example.

Add qualifiers to DEFGLOBAL example.


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

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

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


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

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

Refactor insert-char to use char2chtype

Refactor insert-char to use char2chtype


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

Test for eval-if-constant in an environment.


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

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

Set function type at compile time.

Set function type at compile time.


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

(in-package :cl-user)

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

Fix defpackage for proper use of Closer MOP


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

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

Fix problem with get-name and empty hash.


;;;; 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")))

;;;; 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")))

Update how the CFFI groveller is invoked

Fixes #1


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

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

Enlarge default *targmax*, configure constructors


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

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

Define system in package ASDF-USER.

Define system in package ASDF-USER.


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

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

Add new component to system definition.

Add new component to system definition.


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

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

Rename function and add more comments.

Rename function and add more comments.


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

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

Test if (NOT 0) returns T.

Test if (NOT 0) returns T.


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

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

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


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

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

Use asdf-driver, not asdf-utils anymore.


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

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

Use the SICL reader in COMPILE-FILE.

Use the SICL reader in COMPILE-FILE.


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

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

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


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

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

Add comment explaining how we test the SPLAY operation.


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

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

Make loading relative to ASDF system location.


;; 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"))))

;; 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"))))

Add missing dependency on alexandria

Add missing dependency on alexandria


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

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

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

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

Use CODE-CHAR instead of FORMAT.

Use CODE-CHAR instead of FORMAT.


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

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

Comment out the testing related things until they work properly


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

Add some helper methods for debugging streams


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

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

Use proper argument order for IS.

Tests: Use proper argument order for IS.


;;; -*- 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")))))

;;; -*- 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")))))

Add border and misc tests to examples system.


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

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

Add description to .asd file.

Add description to .asd file.


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

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

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

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

Add existing component utilities to system definition.


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

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

Select appropriate elements of the DEFGENERIC form.


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

Load a file containing the SETF macro.

Load a file containing the SETF macro.


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

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

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

While doing my big refactoring I removed an instance of cartesian-product-switch which I thought was the only one in the codebase. But even if that had been true, I forgot to remove the dependency in package.lisp.

I guess it's only fair that I should make one big stupid mistake when doing a reckless night of intense coding while tired.


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

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

Change syntax to include slot specs.

Change syntax to include slot specs.


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

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

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


;;; -*- 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")))

;;; -*- 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")))

Define system in package ASDF-USER.

Define system in package ASDF-USER.


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

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

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)
  :serial t
  :components
  ((:file "packages")
   (:file "sequences")))

Define system with option :SERIAL T.

Define system with option :SERIAL T.


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

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

Complete rewrite using a state machine.

Complete rewrite using a state machine.


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

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

Apply package to setter function names.

Apply package to setter function names.


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

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

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


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

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

Define a parser for FOR-AS-ACROSS.

Define a parser for FOR-AS-ACROSS.


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

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

Fix for old name mismatch

Fix for old name mismatch


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

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

Simplify by factoring methods to specilize on REGULAR-CLASS.


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

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

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


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

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

Fix the structure names of INSERT and UPDATE.


(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 #: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 #:common-lisp-user)

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

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

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


;;;;; 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 " !)))))

;;;;; 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 " !)))))

Check if :LIMIT and :OFFSET are used together.


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

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

Add a note about ideal avoiding funcall at lambda expressions material


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

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

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

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

Define ASDF system in the package ASDF-USER.


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

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

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

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

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


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

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

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

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

Use option :SERIAL T to simplify system.


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

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


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

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


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

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

Use suffix -PARSER for parser functions.


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

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

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


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

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

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


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

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

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


;;;; 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")))

;;;; 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")))

Add twist and displacement to project.

Add twist and displacement to project.


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

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

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


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

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

Add method specialized to UNWIND-INSTRUCTION.


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

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

Include mu-session-id header in sparql requests

Extends cl-fuseki::virtuoso-repository class and fuseki::query-raw
method to allow received headers to be passed on.


;;;; $Id$
;;;; $URL$

;;;; See the LICENSE file for licensing information.

(in-package :cl-user)

#+lispworks (require "comm")

(eval-when (:execute :load-toplevel :compile-toplevel)
  (defpackage :usocket
      (:use :cl)
    (:export #:socket-connect ; socket constructors and methods
             #:socket-listen
             #:socket-accept
             #:socket-close
             #:get-local-address
             #:get-peer-address
             #:get-local-port
             #:get-peer-port
             #:get-local-name
             #:get-peer-name

             #:with-connected-socket ; macros

             #:usocket ; socket object and accessors
             #:stream-usocket
             #:stream-server-usocket
             #:socket
             #:socket-stream

             #:host-byte-order ; IPv4 utility functions
             #:hbo-to-dotted-quad
             #:hbo-to-vector-quad
             #:vector-quad-to-dotted-quad
             #:dotted-quad-to-vector-quad

             #:socket-condition ; conditions
             #:socket-error ; errors
             #:unknown-condition
             #:unknown-error)))

;;;; $Id$
;;;; $URL$

;;;; See the LICENSE file for licensing information.

(in-package :cl-user)

#+lispworks (require "comm")

(eval-when (:execute :load-toplevel :compile-toplevel)
  (defpackage :usocket
      (:use :cl)
    (:export #:socket-connect ; socket constructors and methods
             #:socket-listen
             #:socket-accept
             #:socket-close
             #:get-local-address
             #:get-peer-address
             #:get-local-port
             #:get-peer-port
             #:get-local-name
             #:get-peer-name

             #:with-connected-socket ; macros
             #:with-server-socket

             #:usocket ; socket object and accessors
             #:stream-usocket
             #:stream-server-usocket
             #:socket
             #:socket-stream

             #:host-byte-order ; IPv4 utility functions
             #:hbo-to-dotted-quad
             #:hbo-to-vector-quad
             #:vector-quad-to-dotted-quad
             #:dotted-quad-to-vector-quad

             #:socket-condition ; conditions
             #:socket-error ; errors
             #:unknown-condition
             #:unknown-error)))

Add the 'with-server-socket' macro to the list of exported symbols.


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

(defun customize-r2 (boot)
  (define-make-instance boot)
  (define-direct-slot-definition-class boot)
  (define-find-class boot))

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

(defun customize-r2 (boot)
  (let ((c (c1 boot))
	(r (r2 boot)))
    (define-make-instance boot)
    (define-direct-slot-definition-class boot)
    (define-find-class boot)
    (ld "../CLOS/ensure-generic-function-using-class-support.lisp" c r)))

Load a file containing support code for ENSURE-GENERIC-FUNCTION-USING-CLASS.


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

(defmethod cleavir-i18n:report-condition
    ((condition unmatched-right-parenthesis)
     stream
     (language cleavir-i18n:english))
  (format stream "Unmatched right parenthesis found."))

(defmethod cleavir-i18n:report-condition
    ((condition only-dots-in-token)
     stream
     (language cleavir-i18n:english))
  (format stream "A token with only dots in it was found"))

(defmethod cleavir-i18n:report-condition
    ((condition single-dot-token)
     stream
     (language cleavir-i18n:english))
  (format stream "A token consisting of a single dot was found ~@
                  in a context that does not permit such a token."))

(defmethod cleavir-i18n:report-condition
    ((condition no-object-preceding-dot)
     stream
     (language cleavir-i18n:english))
  (format stream "A left parenthesis cannot be ~
                  immediately followed by a dot"))

(defmethod cleavir-i18n:report-condition
    ((condition multiple-objects-following-dot)
     stream
     (language cleavir-i18n:english))
  (format stream "A second expression following a dot~@
                  inside a list was found: ~S."
	  (offending-expression condition)))

Add method on REPORT-CONDITION specialized to MULTIPLE-OBJECTS-FOLLOWING-DOT.


;;; Common functions for solving problems

(defun primep (n)
  "Predicate to test the primality of N. If composite, the second
return value is the lowest factor."
  (loop for i from 2 to (sqrt n)
     when (= 0 (mod n i)) return (values nil i) finally (return t)))

(defun factors (n)
  "Return the prime factors of N."
  (multiple-value-bind (prime f) (primep n)
    (if prime
        (list n)
        (cons f (factors (/ n f))))))

(defun curry (function &rest args)
  "Partially apply FUNCTION to ARGS."
  (lambda (&rest more-args)
    (apply function (append args more-args))))

(defun rcurry (function &rest args)
  "Partially apply FUNCTION to ARGS as the rightmost arguments."
  (lambda (&rest more-args)
    (apply function (append more-args args))))

;;; Common functions for solving problems

(defun primep (n)
  "Predicate to test the primality of N. If composite, the second
return value is the lowest factor."
  (when (> n 1)
    (loop for i from 2 to (sqrt n)
       when (= 0 (mod n i)) return (values nil i) finally (return t))))

(defun factors (n)
  "Return the prime factors of N."
  (multiple-value-bind (prime f) (primep n)
    (if prime
        (list n)
        (cons f (factors (/ n f))))))

(defun curry (function &rest args)
  "Partially apply FUNCTION to ARGS."
  (lambda (&rest more-args)
    (apply function (append args more-args))))

(defun rcurry (function &rest args)
  "Partially apply FUNCTION to ARGS as the rightmost arguments."
  (lambda (&rest more-args)
    (apply function (append more-args args))))

Fix definition of primep for 1.

Fix definition of primep for 1.


;; -*- mode: common-lisp -*-
(defsystem lispkit
  :version "0.0.1"
  :description "Lispy browser"
  :licence "BSD"
  :components ((:file "lispkit" :depends-on ("macros" "packages" "keys"))
               (:file "keys" :depends-on ("packages" "browser" "events" "commands"))
               (:file "browser" :depends-on ("packages" "events" "jumps" "commands" "settings"))
               (:file "events" :depends-on ("packages"))
               (:file "jumps" :depends-on ("packages"))
               (:file "macros" :depends-on ("packages"))
               (:file "commands" :depends-on ("packages" "user"))
               (:file "user" :depends-on ("packages"))
               (:file "settings")
               (:file "packages"))
  :depends-on (:asdf
               :cl-cffi-gtk
               :cl-webkit2
               :cl-xkeysym
               :djula
               :parenscript
               :purl
               :split-sequence)
  :in-order-to ((test-op (test-op :lispkit-test))))

(defsystem lispkit-test
  :version "0.0.1"
  :description "Lispy browser"
  :licence "BSD"
  :components ((:module "test"
                        :components
                        ((:file "tests"))))
  :depends-on (:lispkit :lisp-unit :alexandria)
  :perform (test-op (o s)
                    ;; LISP-UNIT:RUN-ALL-TESTS is a macro, so it can't be called
                    ;; like a function.
                    (eval `(,(intern "RUN-ALL-TESTS" :lisp-unit)
                            :lispkit-test))))

;; -*- mode: common-lisp -*-
(defsystem lispkit
  :version "0.0.1"
  :description "Lispy browser"
  :licence "BSD"
  :serial t
  :components ((:file "packages")
               (:file "user")
               (:file "settings")
               (:file "commands")
               (:file "macros")
               (:file "jumps")
               (:file "events")
               (:file "browser")
               (:file "keys")
               (:file "lispkit"))
  :depends-on (:asdf
               :cl-cffi-gtk
               :cl-webkit2
               :cl-xkeysym
               :djula
               :parenscript
               :purl
               :split-sequence)
  :in-order-to ((test-op (test-op :lispkit-test))))

(defsystem lispkit-test
  :version "0.0.1"
  :description "Lispy browser"
  :licence "BSD"
  :components ((:module "test"
                        :components
                        ((:file "tests"))))
  :depends-on (:lispkit :lisp-unit :alexandria)
  :perform (test-op (o s)
                    ;; LISP-UNIT:RUN-ALL-TESTS is a macro, so it can't be called
                    ;; like a function.
                    (eval `(,(intern "RUN-ALL-TESTS" :lisp-unit)
                            :lispkit-test))))

Use the :serial option in the asd file

Use the :serial option in the asd file


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

(defsystem :clobber
  :components
  ((:file "packages")
   (:file "clobber" :depends-on ("packages"))
   (:file "demo" :depends-on ("clobber"))
   (:file "demo2" :depends-on ("clobber"))))

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

(defsystem :clobber
  :serial t
  :components
  ((:file "packages")
   (:file "clobber")
   (:file "demo")
   (:file "demo2")))

Use option :SERIAL T to simplify system definition.


;;; -*- Lisp -*-

(defsystem :split-sequence
  :version "1.0"
  :maintainer "Sharp Lispers <sharplispers@googlegroups.com>"
  :components ((:file "split-sequence"))
  :in-order-to ((asdf:test-op (asdf:load-op :split-sequence-tests)))
  :perform (asdf:test-op :after (op c)
             (funcall (intern (symbol-name '#:run!) '#:5am) :split-sequence)))

(defsystem :split-sequence-tests
  :depends-on (:split-sequence :fiveam)
  :components ((:file "tests")))

;;; -*- Lisp -*-

(defsystem :split-sequence
  :version "1.0"
  :description "Splits a sequence into a list of subsequences
  delimited by objects satisfying a test."
  :maintainer "Sharp Lispers <sharplispers@googlegroups.com>"
  :components ((:file "split-sequence"))
  :in-order-to ((asdf:test-op (asdf:load-op :split-sequence-tests)))
  :perform (asdf:test-op :after (op c)
             (funcall (intern (symbol-name '#:run!) '#:5am) :split-sequence)))

(defsystem :split-sequence-tests
  :depends-on (:split-sequence :fiveam)
  :components ((:file "tests")))

Add :description to system definition.

Add :description to system definition.


;;; -*- Mode: Lisp ; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
(defsystem "fare-memoization"
  :description "memoizing functions the correct, portable way"
  :long-description "define memoized functions and memoize previously defined functions"
  :license "MIT"
  :author "Francois-Rene Rideau"
  :version "1.0.0"
  :components
  ((:file "memoization"))
  :in-order-to ((test-op (load-op "fare-memoization/test")))
  :perform (test-op :after (o c)
             (symbol-call :fare-memoization-test :test-memoization)))

(defsystem "fare-memoization/test"
  :description "memoizing functions the correct, portable way"
  :license "MIT"
  :author "Francois-Rene Rideau"
  :version "1.0.0"
  :depends-on ("fare-memoization" "hu.dwim.stefil")
  :components
  ((:file "memoization-test")))

;;; -*- Mode: Lisp ; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
(defsystem "fare-memoization"
  :description "memoizing functions the correct, portable way"
  :long-description "define memoized functions and memoize previously defined functions"
  :license "MIT"
  :author "Francois-Rene Rideau"
  :version "1.0.0"
  :components ((:file "memoization"))
  :in-order-to ((test-op (test-op "fare-memoization/test"))))

(defsystem "fare-memoization/test"
  :description "memoizing functions the correct, portable way"
  :license "MIT"
  :author "Francois-Rene Rideau"
  :version "1.0.0"
  :depends-on ("fare-memoization" "hu.dwim.stefil")
  :components ((:file "memoization-test"))
  :perform (test-op (o c) (symbol-call :fare-memoization-test :test-memoization)))

Make .asd file nicer for ASDF 3

Make .asd file nicer for ASDF 3

Also drop ASDF 2 support


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

(defgeneric delete (leaf))

(defgeneric delete-child (parent child))

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

Define method on DELETE specialized to LEAF.


(defsystem :eval-bot
  :depends-on (:bordeaux-threads :trivial-irc :alexandria :split-sequence
                                 :babel)
  :components
  ((:file "sandbox-impl" :depends-on ("common"))
   (:file "sandbox-extra" :depends-on ("common" "sandbox-impl" "sandbox-cl"))
   (:file "sandbox-cl" :depends-on ("sandbox-impl"))
   (:file "common")
   (:file "eval-bot" :depends-on ("common" "sandbox-impl"))))

(defsystem "eval-bot"
  :description "An IRC bot for Common Lisp code evaluation"
  :author "Teemu Likonen <tlikonen@iki.fi>"
  :licence "GNU Affero General Public License version 3"
  :depends-on ("bordeaux-threads"
               "trivial-irc" "alexandria" "split-sequence" "babel")
  :components
  ((:file "sandbox-impl" :depends-on ("common"))
   (:file "sandbox-extra" :depends-on ("common" "sandbox-impl" "sandbox-cl"))
   (:file "sandbox-cl" :depends-on ("sandbox-impl"))
   (:file "common")
   (:file "eval-bot" :depends-on ("common" "sandbox-impl"))))

Add description, author and licence information to .asd file