; tré – Copyright (C) 2006,2008,2012,2014–2015 Sven Michael Klose <pixel@hugbox.org>

(defmacro with-struct (typ strct &body body)
  (alet (assoc-value typ *struct-defs*)
    `(let* ((,typ ,strct)
            ,@(@ [let n (%struct-field-name _)
	               `(,n (,(%struct-accessor-name typ n) ,strct))]
                 !))
       ,@(@ [%struct-field-name _] !)
       ,@body)))

Make only a single function for all slots.

; tré – Copyright (C) 2006,2008,2012,2014–2015 Sven Michael Klose <pixel@hugbox.org>

(defmacro with-struct (typ strct &body body)
  (alet (assoc-value typ *struct-defs*)
    `(#'((,typ ,@(@ #'%struct-field-name !))
           ,@(@ [%struct-field-name _] !)
           ,@body)
       ,strct ,@(@ [`(,(%struct-accessor-name typ (%struct-field-name _)) ,strct)] !))))


(asdf:defsystem #:hexstream-project-template

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

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

  :description "I unsophistically copy/paste and rename/modify these files to start a new project, currently."

  :depends-on ()

  :version "0.1"
  :serial cl:t
  :components ((:file "package")
	       (:file "main")))

Remove 2 extraneous spaces in ASD file.


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

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

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

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

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

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

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

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

Use unexported names for slot writers.

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

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

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

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

(defclass 2-node (node)
  ((%left :initarg :left :reader left :writer (setf %left))
   (%right :initarg :right :reader right :writer (setf %right))))

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

(defclass 3-node (node)
  ((%left :initarg :left :reader left :writer (setf %left))
   (%middle :initarg :middle :reader middle :writer (setf %middle))
   (%right :initarg :right :reader right :writer (setf %right))))

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


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

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

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

Load a file containing the definition of the macro DEFCLASS.

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

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

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


(defpackage :cl-autowrap.asdf
  (:use #:cl #:asdf))

(in-package :cl-autowrap.asdf)

(defsystem :cl-autowrap
  :description "Import c2ffi specs and generate CFFI wrappers"
  :author "Ryan Pavlik"
  :license "BSD-2-Clause"
  :version "1.0"

  :depends-on (:alexandria :cffi :cl-json :cl-ppcre
               :external-program :cl-fad :trivial-features)
  :pathname "autowrap"
  :serial t

  :components
  ((:file "package")
   (:file "util")
   (:file "conditions")
   (:file "c2ffi")
   (:file "sffi")
   (:file "wrapper")
   (:file "parse")
   (:file "bitmask")))

Change load order so WRAPPER is available to SFFI

(defpackage :cl-autowrap.asdf
  (:use #:cl #:asdf))

(in-package :cl-autowrap.asdf)

(defsystem :cl-autowrap
  :description "Import c2ffi specs and generate CFFI wrappers"
  :author "Ryan Pavlik"
  :license "BSD-2-Clause"
  :version "1.0"

  :depends-on (:alexandria :cffi :cl-json :cl-ppcre
               :external-program :cl-fad :trivial-features)
  :pathname "autowrap"
  :serial t

  :components
  ((:file "package")
   (:file "util")
   (:file "conditions")
   (:file "c2ffi")
   (:file "wrapper")
   (:file "sffi")
   (:file "parse")
   (:file "bitmask")))


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

(in-package :common-lisp-user)

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

(asdf:defsystem :iolib.syscalls
  :description "Syscalls and foreign types."
  :maintainer "Stelian Ionescu <sionescu@common-lisp.net>"
  :licence "MIT"
  :depends-on (:iolib.base :cffi :cffi-grovel :trivial-features)
  :pathname (merge-pathnames "syscalls/" *load-truename*)
  :serial t
  :components
  ((:file "pkgdcl")
   ;; Platform-specific files
   (cffi-grovel:grovel-file "ffi-types"
     :pathname #+unix "ffi-types-unix")
   (:file "conditions")
   (:file "os-conditions"
     :pathname #+unix "os-conditions-unix")
   (:file "designators")
   (:file "early")
   (cffi-grovel:wrapper-file "ffi-wrappers"
     :pathname #+unix "ffi-wrappers-unix")
   (:file "ffi-functions"
     :pathname #+unix "ffi-functions-unix")))

Change soname of syscall wrapper library.

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

(in-package :common-lisp-user)

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

(asdf:defsystem :iolib.syscalls
  :description "Syscalls and foreign types."
  :maintainer "Stelian Ionescu <sionescu@common-lisp.net>"
  :licence "MIT"
  :depends-on (:iolib.base :cffi :cffi-grovel :trivial-features)
  :pathname (merge-pathnames "syscalls/" *load-truename*)
  :serial t
  :components
  ((:file "pkgdcl")
   ;; Platform-specific files
   (cffi-grovel:grovel-file "ffi-types"
     :pathname #+unix "ffi-types-unix")
   (:file "conditions")
   (:file "os-conditions"
     :pathname #+unix "os-conditions-unix")
   (:file "designators")
   (:file "early")
   (cffi-grovel:wrapper-file "ffi-wrappers"
     :pathname #+unix "ffi-wrappers-unix"
     :soname "libiolib-syscalls")
   (:file "ffi-functions"
     :pathname #+unix "ffi-functions-unix")))


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

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

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

Fix test to reflect change to scheme style reduce.

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

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

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


(in-package :cl-user)

(prove:plan nil)

(defvar *test-package-name* "hello")
(defvar *test-complex-package-name* "nyxt")

(prove:subtest "Package list"
  (prove:ok (< 0 (length (ospama:list-packages))))
  (prove:ok (typep (first (ospama:list-packages)) 'ospama:os-package)))

(prove:subtest "Find package"
  (prove:is (ospama:name (first (ospama:find-os-packages *test-package-name*)))
            *test-package-name*))

(prove:subtest "Package inputs"
  (let* ((pkg (first (ospama:find-os-packages *test-complex-package-name*)))
         (all-inputs (append
                      (ospama:inputs pkg)
                      (ospama:propagated-inputs pkg)
                      (ospama:native-inputs pkg))))
    (prove:ok (mapc #'ospama:find-os-packages all-inputs))))

(prove:subtest "List profiles"
  (prove:ok (uiop:directory-exists-p (first (ospama:list-profiles)))))

(prove:finalize)

Test finding multiple package versions.

(in-package :cl-user)

(prove:plan nil)

(defvar *test-package-name* "hello")
(defvar *test-complex-package-name* "nyxt")
(defvar *multi-version-package-name* "linux-libre")

(prove:subtest "Package list"
  (prove:ok (< 0 (length (ospama:list-packages))))
  (prove:ok (typep (first (ospama:list-packages)) 'ospama:os-package)))

(prove:subtest "Find package"
  (prove:is (ospama:name (first (ospama:find-os-packages *test-package-name*)))
            *test-package-name*))

(prove:subtest "Find multiple package versions"
  (prove:ok (<= 2 (length (ospama:find-os-packages *multi-version-package-name*)))))

(prove:subtest "Package inputs"
  (let* ((pkg (first (ospama:find-os-packages *test-complex-package-name*)))
         (all-inputs (append
                      (ospama:inputs pkg)
                      (ospama:propagated-inputs pkg)
                      (ospama:native-inputs pkg))))
    (prove:ok (mapc #'ospama:find-os-packages all-inputs))))

(prove:subtest "List profiles"
  (prove:ok (uiop:directory-exists-p (first (ospama:list-profiles)))))

(prove:finalize)


(defpackage #:local-time.system
  (:use :common-lisp :asdf))

(in-package #:local-time.system)

(defsystem :local-time
  :name "local-time"
  :version "0.9.1"
  :author "Daniel Lowe <dlowe@sanctuary.org>"
  :description "A library for manipulating dates and times, based on a paper by Erik Naggum"
  :components ((:file "local-time")))

(defsystem #:local-time.test
  :name "local-time.test"
  :version "0.9.1"
  :author "Daniel Lowe <dlowe@sanctuary.org>"
  :description "Testing code for the local-time library"
  :depends-on (:local-time)
  :components ((:file "tests")))

(defmethod perform ((op test-op) (system (eql (find-system :local-time))))
  (operate 'load-op '#:local-time.test)
  (funcall (read-from-string "local-time::run-tests")))

(defmethod perform :after ((op load-op) (system (eql (find-system :local-time))))
  (in-package :local-time))

(defmethod operation-done-p ((op test-op) (system (eql (find-system :local-time))))
  nil)

Comment out the in-package form by default

(defpackage #:local-time.system
  (:use :common-lisp :asdf))

(in-package #:local-time.system)

(defsystem :local-time
  :name "local-time"
  :version "0.9.1"
  :author "Daniel Lowe <dlowe@sanctuary.org>"
  :description "A library for manipulating dates and times, based on a paper by Erik Naggum"
  :components ((:file "local-time")))

(defsystem #:local-time.test
  :name "local-time.test"
  :version "0.9.1"
  :author "Daniel Lowe <dlowe@sanctuary.org>"
  :description "Testing code for the local-time library"
  :depends-on (:local-time)
  :components ((:file "tests")))

(defmethod perform ((op test-op) (system (eql (find-system :local-time))))
  (operate 'load-op '#:local-time.test)
  (funcall (read-from-string "local-time::run-tests")))

;; this is not really nice to have it enabled by default
#+nil(defmethod perform :after ((op load-op) (system (eql (find-system :local-time))))
  (in-package :local-time))

(defmethod operation-done-p ((op test-op) (system (eql (find-system :local-time))))
  nil)


;;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: BIT-SMASHER; Base: 10 -*-
;;;; packages.lisp

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

(in-package :cl-user)

(defpackage #:bit-smasher
  (:nicknames #:bitsmash)
  (:use :cl :cl-user :ironclad)
  (:shadowing-import-from :cl-user #:null)
  (:export #:*bit-smasher-version*
           #:hex->bits #:hex->octets #:hex->int
           #:octets->hex #:octets->bits #:octets->int
           #:int->hex #:int->octets #:int->bits
           #:bits->hex #:bits->octets #:bits->int
           #:bit-sum #:bit+
           #:bit-difference #:bit-
           #:bit-product #:bit*
           #:bit-quotient #:bit/
           #:bit-floor #:bit-ceiling
           #:<< #:lshift
           #:>> #:rshift
           #:byte-length #:wide-bit-length #:min-bit-length
           #:twos-complement-p))

(in-package :bit-smasher)

(defvar *bit-smasher-version* #.bit-smasher-asd:*bit-smasher-version*)

;; EOF

Add type-checking, type-casting functions to package exports

;;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: BIT-SMASHER; Base: 10 -*-
;;;; packages.lisp

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

(in-package :cl-user)

(defpackage #:bit-smasher
  (:nicknames #:bitsmash)
  (:use :cl :cl-user :ironclad)
  (:shadowing-import-from :cl-user #:null)
  (:export #:*bit-smasher-version*
           #:hex<- #:hex->bits #:hex->octets #:hex->int
           #:octets<- #:octets->hex #:octets->bits #:octets->int
           #:int<- #:int->hex #:int->octets #:int->bits
           #:bits<- #:bits->hex #:bits->octets #:bits->int
           #:bit-sum #:bit+
           #:bit-difference #:bit-
           #:bit-product #:bit*
           #:bit-quotient #:bit/
           #:bit-floor #:bit-ceiling
           #:<< #:lshift
           #:>> #:rshift
           #:byte-length #:wide-bit-length #:min-bit-length
           #:twos-complement-p))

(in-package :bit-smasher)

(defvar *bit-smasher-version* #.bit-smasher-asd:*bit-smasher-version*)

;; EOF


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

(defclass header ()
  ((%class :initarg :class :accessor class)
   (%rack :initarg :rack :reader rack)))

(defun phase3 (boot)
  (let ((c (c1 boot))
	(r (r2 boot)))
    (define-effective-slot-definition-class boot)
    (ld "../CLOS/class-finalization-support.lisp" c r)
    (export-to-host 'sicl-clos::compute-default-initargs-default r)
    (export-to-host 'sicl-clos::compute-slots-default r)
    (export-to-host 'sicl-clos::compute-slots-around-default r)
    (export-to-host 'sicl-clos::compute-effective-slot-definition-default r)
    (export-to-host 'sicl-clos::compute-class-precedence-list-default r)
    (export-to-host 'sicl-clos::finalize-inheritance-default r)
    (export-to-host 'sicl-clos::effective-slot-definition-class r)
    (ld "../CLOS/class-finalization-defmethods.lisp" c r)))

Define a function for defining ALLOCATE-GENERAL-INSTANCE.

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

(defclass header ()
  ((%class :initarg :class :accessor class)
   (%rack :initarg :rack :reader rack)))

(defun define-allocate-general-instance (env)
  (setf (sicl-genv:fdefinition 'sicl-clos:allocate-general-instance env)
	(lambda (class size)
	  (make-instance 'header
	    :class class
	    :rack (make-array size)))))

(defun phase3 (boot)
  (let ((c (c1 boot))
	(r (r2 boot)))
    (define-effective-slot-definition-class boot)
    (ld "../CLOS/class-finalization-support.lisp" c r)
    (export-to-host 'sicl-clos::compute-default-initargs-default r)
    (export-to-host 'sicl-clos::compute-slots-default r)
    (export-to-host 'sicl-clos::compute-slots-around-default r)
    (export-to-host 'sicl-clos::compute-effective-slot-definition-default r)
    (export-to-host 'sicl-clos::compute-class-precedence-list-default r)
    (export-to-host 'sicl-clos::finalize-inheritance-default r)
    (export-to-host 'sicl-clos::effective-slot-definition-class r)
    (ld "../CLOS/class-finalization-defmethods.lisp" c r)))


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

(defun phase3 (boot)
  (let ((c (c1 boot))
	(r (r2 boot)))
    (define-effective-slot-definition-class boot)))

Load file containing support code for class finalization.

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

(defun phase3 (boot)
  (let ((c (c1 boot))
	(r (r2 boot)))
    (define-effective-slot-definition-class boot)
    (ld "../CLOS/class-finalization-support.lisp" c r)))


#| dummy system to make Quicklisp happy |#
(defsystem #:mcclim-fonts)

(defsystem #:mcclim-fonts/truetype
    :depends-on (#:clim-basic #:zpb-ttf #:cl-vectors #:cl-paths-ttf #:cl-aa #:alexandria)
    :components ((:static-file "README.md")
                 (:file "truetype-package")
                 (:file "fontconfig" :depends-on ("truetype-package"))
                 (:file "mcclim-native-ttf" :depends-on ("truetype-package"))))

(defmethod perform :after ((o load-op)
                           (s (eql (find-system :mcclim-fonts/truetype))))
  (uiop:symbol-call :mcclim-truetype :autoconfigure-fonts))

(defsystem #:mcclim-fonts/clx-truetype
    :depends-on (#:mcclim-fonts/truetype #:mcclim-clx)
    :components ((:file "xrender-fonts")))

(defsystem #:mcclim-fonts/clx-freetype
  :depends-on (#:mcclim-clx #:cl-freetype2 #:mcclim-fontconfig #:mcclim-harfbuzz #:log4cl)
  :components ((:file "freetype")))

Remove log4cl from the dependencies for the freetype system

#| dummy system to make Quicklisp happy |#
(defsystem #:mcclim-fonts)

(defsystem #:mcclim-fonts/truetype
    :depends-on (#:clim-basic #:zpb-ttf #:cl-vectors #:cl-paths-ttf #:cl-aa #:alexandria)
    :components ((:static-file "README.md")
                 (:file "truetype-package")
                 (:file "fontconfig" :depends-on ("truetype-package"))
                 (:file "mcclim-native-ttf" :depends-on ("truetype-package"))))

(defmethod perform :after ((o load-op)
                           (s (eql (find-system :mcclim-fonts/truetype))))
  (uiop:symbol-call :mcclim-truetype :autoconfigure-fonts))

(defsystem #:mcclim-fonts/clx-truetype
    :depends-on (#:mcclim-fonts/truetype #:mcclim-clx)
    :components ((:file "xrender-fonts")))

(defsystem #:mcclim-fonts/clx-freetype
  :depends-on (#:mcclim-clx #:cl-freetype2 #:mcclim-fontconfig #:mcclim-harfbuzz)
  :components ((:file "freetype")))


(in-package #:sicl-clos)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Computing the effective slots of a built-in class.

(defun compute-built-in-slots (class)
  (let* ((superclasses (class-precedence-list class))
	 (direct-slots (mapcar #'direct-slots superclasses))
	 (concatenated (reduce #'append direct-slots))
	 (reverse-slots (reverse direct-slots))
	 (reverse-concatenated (reduce #'append reverse-slots))
	 (names (mapcar #'slot-definition-name reverse-concatenated))
	 (unique (remove-duplicates names :from-end t))
	 (slots (loop for name in unique
		      collect (compute-effective-slot-definition-aux
			       name
			       (remove name concatenated
				       :key #'slot-definition-name
				       :test-not #'eql)
			       'standard-effective-slot-definition)))
	 (next-location 0))
    (loop for slot in slots
	  do (when (eq (slot-definition-allocation slot) :instance)
	       (setf (slot-definition-location slot)
		     next-location)
	       (incf next-location)))
    slots))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; FINALIZE-BUILT-IN-INHERITANCE.

(defun finalize-built-in-inheritance (class)
  (setf (c-precedence-list class) (compute-class-precedence-list class))
  (setf (c-slots class) (compute-built-in-slots class))
  (setf (c-default-initargs class) (compute-default-initargs-aux class))
  (setf (c-finalized-p class) t))

Update calls to renamed function.

(in-package #:sicl-clos)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Computing the effective slots of a built-in class.

(defun compute-built-in-slots (class)
  (let* ((superclasses (class-precedence-list class))
	 (direct-slots (mapcar #'direct-slots superclasses))
	 (concatenated (reduce #'append direct-slots))
	 (reverse-slots (reverse direct-slots))
	 (reverse-concatenated (reduce #'append reverse-slots))
	 (names (mapcar #'slot-definition-name reverse-concatenated))
	 (unique (remove-duplicates names :from-end t))
	 (slots (loop for name in unique
		      collect (compute-effective-slot-definition-default
			       name
			       (remove name concatenated
				       :key #'slot-definition-name
				       :test-not #'eql)
			       'standard-effective-slot-definition)))
	 (next-location 0))
    (loop for slot in slots
	  do (when (eq (slot-definition-allocation slot) :instance)
	       (setf (s-location slot)
		     next-location)
	       (incf next-location)))
    slots))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; FINALIZE-BUILT-IN-INHERITANCE.

(defun finalize-built-in-inheritance (class)
  (setf (c-precedence-list class) (compute-class-precedence-list class))
  (setf (c-slots class) (compute-built-in-slots class))
  (setf (c-default-initargs class) (compute-default-initargs-default class))
  (setf (c-finalized-p class) t))


;;;; System definition for PURL.

(defpackage purl-asd
  (:documentation
   "System definition for PURL.")
  (:use :cl :asdf))

(in-package :purl-asd)

(defsystem purl
  :description "Parse and print URLs as described in RFC 1738."
  :author "Max Rottenkolber <max@mr.gy>"
  :license "GNU AGPL"
  :version "1.1"
  :components ((:file "package")
               (:file "grammar"
                      :depends-on ("package"))
               (:file "purl"
                      :depends-on ("package" "grammar")))
  :depends-on ("mpc" "percent-encoding" "uiop"))

Replace dependency mpc with maxpc.

;;;; System definition for PURL.

(defpackage purl-asd
  (:documentation
   "System definition for PURL.")
  (:use :cl :asdf))

(in-package :purl-asd)

(defsystem purl
  :description "Parse and print URLs as described in RFC 1738."
  :author "Max Rottenkolber <max@mr.gy>"
  :license "GNU AGPL"
  :version "1.1"
  :components ((:file "package")
               (:file "grammar"
                      :depends-on ("package"))
               (:file "purl"
                      :depends-on ("package" "grammar")))
  :depends-on ("maxpc" "percent-encoding" "uiop"))


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

(defmethod print-object ((class standard-class) stream)
  (format stream
	  "#<Ersatz standard class ~s>"
	  (sicl-clos:class-name class)))

(defmethod print-object ((class sicl-clos:built-in-class) stream)
  (format stream
	  "#<Ersatz built-in class ~s>"
	  (sicl-clos:class-name class)))

(defmethod print-object ((function standard-generic-function) stream)
  (format stream
	  "#<Ersatz standard generic function ~s>"
	  (sicl-clos:generic-function-name function)))

Fix incorrect terminology in PRINT-OBJECT methods.

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

(defmethod print-object ((class standard-class) stream)
  (format stream
	  "#<Bridge standard class ~s>"
	  (sicl-clos:class-name class)))

(defmethod print-object ((class sicl-clos:built-in-class) stream)
  (format stream
	  "#<Bridge built-in class ~s>"
	  (sicl-clos:class-name class)))

(defmethod print-object ((function standard-generic-function) stream)
  (format stream
	  "#<Bridge standard generic function ~s>"
	  (sicl-clos:generic-function-name function)))


(in-package :lispkit)

(defparameter *jumps* (make-hash-table :test #'equal))

(defun defjump (place prefix url)
  (setf (gethash prefix place) url))

(defjump *jumps* "g" "http://google.com/search?=~a")

(defun lookup-jump (s table)
  (gethash s table))

(defun extract-jump-str (s)
  (split-sequence " " s :test #'string=))

(defmacro multiple-value-destructuring-bind (lambda-list value-list &body body)
  (let ((ignore (gensym)))
    `(destructuring-bind (,@lambda-list &rest ,ignore)
         (multiple-value-list ,value-list)
       (declare (ignore ,ignore))
       ,@body)))

(defun apply-jumps (s browser)
  (multiple-value-destructuring-bind ((jump args)) (extract-jump-str s)
    (let ((jump? (lookup-jump jump *jumps*)))
      (when jump?
        (load-url (format nil jump? args) browser)
        t))))

Set the Google jump URL to the proper thing

(in-package :lispkit)

(defparameter *jumps* (make-hash-table :test #'equal))

(defun defjump (place prefix url)
  (setf (gethash prefix place) url))

(defjump *jumps* "g" "http://google.com/search?q=~a")

(defun lookup-jump (s table)
  (gethash s table))

(defun extract-jump-str (s)
  (split-sequence " " s :test #'string=))

(defmacro multiple-value-destructuring-bind (lambda-list value-list &body body)
  (let ((ignore (gensym)))
    `(destructuring-bind (,@lambda-list &rest ,ignore)
         (multiple-value-list ,value-list)
       (declare (ignore ,ignore))
       ,@body)))

(defun apply-jumps (s browser)
  (multiple-value-destructuring-bind ((jump args)) (extract-jump-str s)
    (let ((jump? (lookup-jump jump *jumps*)))
      (when jump?
        (load-url (format nil jump? args) browser)
        t))))


(in-package #:cl-user)

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

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

(asdf:defsystem :sicl-cons-high
    :components
  ((:file "packages" :depends-on ())
   (:file "cons-high" :depends-on ("packages"))
   (:file "conditions" :depends-on ("packages"))
   (:file "condition-reporters-en" :depends-on ("packages" "conditions"))
   (:file "docstrings-en" :depends-on ("packages"))))

Define ASDF system in package ASDF-USER.

(in-package #:asdf-user)

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

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

(defsystem :sicl-cons-high
    :components
  ((:file "packages" :depends-on ())
   (:file "cons-high" :depends-on ("packages"))
   (:file "conditions" :depends-on ("packages"))
   (:file "condition-reporters-en" :depends-on ("packages" "conditions"))
   (:file "docstrings-en" :depends-on ("packages"))))


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

(in-package :common-lisp-user)

(defpackage :iolib.base
  (:use #:common-lisp :alexandria)
  (:shadow #:defun #:defmethod
           #:defmacro #:define-compiler-macro)
  (:export #:return* #:defun #:defmethod
           #:defmacro #:define-compiler-macro))

(flet ((gather-external-symbols (&rest packages)
         (let ((symbols (make-hash-table :test #'eq)))
           (with-package-iterator (iterator packages :external)
             (loop (multiple-value-bind (morep symbol) (iterator)
                     (unless morep (return))
                     (setf (gethash symbol symbols) t))))
           (alexandria:hash-table-keys symbols))))
  (export (gather-external-symbols :common-lisp :alexandria :iolib.base)
          :iolib.base))

Fix symbol exporting from IOLIB.BASE

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

(in-package :common-lisp-user)

(defpackage :iolib.base
  (:use #:common-lisp :alexandria)
  (:shadow #:defun #:defmethod
           #:defmacro #:define-compiler-macro)
  (:export #:return* #:defun #:defmethod
           #:defmacro #:define-compiler-macro))

(flet ((gather-external-symbols (&rest packages)
         (let ((symbols (make-hash-table :test #'eq)))
           (with-package-iterator (iterator packages :external)
             (loop (multiple-value-bind (morep symbol) (iterator)
                     (unless morep (return))
                     (setf (gethash (alexandria:ensure-symbol symbol :iolib.base) symbols) t))))
           (alexandria:hash-table-keys symbols))))
  (export (gather-external-symbols :common-lisp :alexandria :iolib.base)
          :iolib.base))


(defun cal (file)
   (handler-bind
     ;; automatically choose 'smash existing class' when loading
     ((t (lambda (c)
           (invoke-restart 'continue))))
    (sys.int::cal file)))

(cal "home/med/package.lisp")
(cal "home/med/line.lisp")
(cal "home/med/mark.lisp")
(cal "home/med/editor.lisp")
(cal "home/med/buffer.lisp")
(cal "home/med/point.lisp")
(cal "home/med/minibuffer.lisp")
(cal "home/med/redisplay.lisp")
(cal "home/med/commands.lisp")
(cal "home/med/keybindings.lisp")
(cal "home/med/main.lisp")

(defun make ()
   (cal "home/med/all.lisp"))

Stop stack overflow when loaded from sys.int.

(sys.int::cal "home/med/package.lisp")

(in-package :med)

(defmacro awhen (cond &body body)
  `(let ((it ,cond))
     (when it
       ,@body)))

(defun cal (file)
   (handler-bind
     ;; automatically choose 'smash existing class' when loading
     ((t (lambda (c)
           (declare (ignore c))
           (awhen (find-restart 'continue)
             (invoke-restart it)))))
    (sys.int::cal file)))

(cal "home/med/line.lisp")
(cal "home/med/mark.lisp")
(cal "home/med/editor.lisp")
(cal "home/med/buffer.lisp")
(cal "home/med/point.lisp")
(cal "home/med/minibuffer.lisp")
(cal "home/med/redisplay.lisp")
(cal "home/med/commands.lisp")
(cal "home/med/keybindings.lisp")
(cal "home/med/main.lisp")

(defun make ()
   (cal "home/med/all.lisp"))


(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 define-ensure-generic-function (environment)
  (setf (sicl-genv:fdefinition 'ensure-generic-function environment)
	(lambda (function-name &rest arguments)
	  (if (sicl-genv:fboundp function-name environment)
	      (sicl-genv:fdefinition function-name environment)
	      (let ((new-arguments (copy-list arguments)))
		(loop while (remf new-arguments :environment))
		(apply #'make-instance
		       (sicl-genv:find-class
			'standard-generic-function
			(phase1-environment environment))
		       new-arguments))))))

(defun fill-environment (environment)
  (define-ensure-generic-function environment))

Save new definition in 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 define-ensure-generic-function (environment)
  (setf (sicl-genv:fdefinition 'ensure-generic-function environment)
	(lambda (function-name &rest arguments)
	  (if (sicl-genv:fboundp function-name environment)
	      (sicl-genv:fdefinition function-name environment)
	      (let ((new-arguments (copy-list arguments)))
		(loop while (remf new-arguments :environment))
		(setf (sicl-genv:fdefinition function-name environment)
		      (apply #'make-instance
			     (sicl-genv:find-class
			      'standard-generic-function
			      (phase1-environment environment))
			     new-arguments)))))))

(defun fill-environment (environment)
  (define-ensure-generic-function environment))


;; -*- Syntax: Ansi-Common-Lisp; Mode: lisp; -*-

(defpackage cl-dot
  (:use :common-lisp)
  (:export #:attributed #:node
           #:*dot-path*
           #:*neato-path*
           #:graph-object-knows-of #:graph-object-node
           #:graph-object-points-to #:graph-object-pointed-to-by
           #:generate-graph-from-roots
           #:print-graph #:dot-graph

           ;; deprecated
           #:object-knows-of #:object-node
           #:object-points-to #:object-pointed-to-by
           #:generate-graph))

Put deprecated symbols into extra export

;; -*- Syntax: Ansi-Common-Lisp; Mode: lisp; -*-

(defpackage cl-dot
  (:use :common-lisp)
  (:export #:attributed #:node
           #:*dot-path*
           #:*neato-path*
           #:graph-object-knows-of #:graph-object-node
           #:graph-object-points-to #:graph-object-pointed-to-by
           #:graph-object-edges
           #:generate-graph-from-roots
           #:print-graph #:dot-graph)
  ;; deprecated
  (:export #:object-knows-of #:object-node
           #:object-points-to #:object-pointed-to-by
           #:generate-graph))


;;;; slime-helper.lisp

(defpackage #:quicklisp-slime-helper
  (:use #:cl)
  (:export #:install)
  (:shadowing-import-from #:alexandria
                          #:copy-file)
  (:shadowing-import-from #:ql-dist
                          #:ensure-installed
                          #:find-system)
  (:shadowing-import-from #:ql-setup
                          #:qmerge))

(in-package #:quicklisp-slime-helper)

(defun install ()
  (let ((source (asdf:system-relative-pathname "quicklisp-slime-helper"
                                               "slime-helper-template"
                                               :type "el"))
        (target (qmerge "slime-helper.el")))
    (copy-file source target)
    (ensure-installed  (find-system "swank"))
    (format t "~&slime-helper.el installed in ~S~%~%"
            (namestring target))
    (let ((enough (enough-namestring target (user-homedir-pathname))))
      (unless (equal (pathname enough) target)
        (setf enough (format nil "~~/~A" enough)))
      (format t "To use, add this to your ~~/.emacs:~%~%")
      (format t "  (load (expand-file-name ~S))~%" enough)
      (format t "~%"))))

Add info about setting inferior-lisp-program.

;;;; slime-helper.lisp

(defpackage #:quicklisp-slime-helper
  (:use #:cl)
  (:export #:install)
  (:shadowing-import-from #:alexandria
                          #:copy-file)
  (:shadowing-import-from #:ql-dist
                          #:ensure-installed
                          #:find-system)
  (:shadowing-import-from #:ql-setup
                          #:qmerge))

(in-package #:quicklisp-slime-helper)

(defun install ()
  (let ((source (asdf:system-relative-pathname "quicklisp-slime-helper"
                                               "slime-helper-template"
                                               :type "el"))
        (target (qmerge "slime-helper.el")))
    (copy-file source target)
    (ensure-installed (find-system "swank"))
    (format t "~&slime-helper.el installed in ~S~%~%"
            (namestring target))
    (let ((enough (enough-namestring target (user-homedir-pathname))))
      (unless (equal (pathname enough) target)
        (setf enough (format nil "~~/~A" enough)))
      (format t "To use, add this to your ~~/.emacs:~%~%")
      (format t "  (load (expand-file-name ~S))~%" enough)
      (format t "  ;; Replace \"sbcl\" with the path to your implementation~%")
      (format t "  (setq inferior-lisp-program \"sbcl\")~%")
      (format t "~%"))))


;; -*- Syntax: Ansi-Common-Lisp; Mode: lisp; -*-

(asdf:defsystem :cl-dot
  :version "0.9.0"
  :description "Generate Dot Output from Arbitrary Lisp Data"
  :author "Juho Snellman <jsnell@iki.fi>"
  :maintainer "Michael Weber <michaelw@foldr.org>"
  :depends-on (:uiop)
  :serial t
  :components
  ((:file "package")
   (:file "config-graphviz")
   (:file "attribute")
   (:file "raw-attributes") ; generated
   (:file "attributes")
   (:file "cl-dot")
   (:file "deprecated")
   (:static-file "README.md")
   (:static-file "COPYING")
   (:static-file "ChangeLog")
   (:module "examples"
            :components
            ((:static-file "class-example" :pathname "class-example.lisp")
             (:static-file "list-example" :pathname "list-example.lisp")
             (:static-file "list-example-old" :pathname "list-example-old.lisp")
             (:static-file "sb-c-example" :pathname "sb-c-example.lisp")))
   (:module "docs"
            :components
            ((:html-file "cl-dot")))))

Clean up the ASD file.

;; -*- Syntax: Ansi-Common-Lisp; Mode: lisp; -*-

(asdf:defsystem :cl-dot
  :version "0.9.0"
  :description "Generate Dot Output from Arbitrary Lisp Data"
  :author "Juho Snellman <jsnell@iki.fi>"
  :maintainer "Michael Weber <michaelw@foldr.org>"
  :depends-on (:uiop)
  :serial t
  :components
  ((:file "package")
   (:file "config-graphviz")
   (:file "attribute")
   (:file "raw-attributes") ; generated
   (:file "attributes")
   (:file "cl-dot")
   (:file "deprecated")
   (:static-file "README.md")
   (:static-file "COPYING")
   (:static-file "ChangeLog")
   (:module "examples"
    :components
    ((:static-file "class-example" :pathname "class-example.lisp")
     (:static-file "list-example" :pathname "list-example.lisp")
     (:static-file "list-example-old" :pathname "list-example-old.lisp")
     (:static-file "sb-c-example" :pathname "sb-c-example.lisp")
     (:static-file "subgraph-example" :pathname "subgraph-example.lisp")))))


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

(asdf:defsystem :sicl-compiler
  :depends-on (:sicl-code-utilities
	       :sicl-compiler-utilities
	       :sicl-compiler-basic-blocks
	       :sicl-compiler-dominance
	       :sicl-compiler-liveness
	       :sicl-compiler-reaching-definitions
	       :sicl-compiler-def-use-chains
	       :sicl-compiler-ssa-form
	       :sicl-compiler-loops
	       :sicl-environment
	       :sicl-reader-simple)
  :components
  ((:file "packages" :depends-on ())
   (:file "abstract-syntax-tree"
    :depends-on ("packages"))
   (:file "mir"
    :depends-on ("packages"))
   (:file "phase1"
    :depends-on ("packages" "abstract-syntax-tree"))
   (:file "ast-transformations"
    :depends-on ("packages"))
   (:file "phase2"
    :depends-on ("packages" "abstract-syntax-tree" "mir"))
   (:file "graph-coloring" :depends-on ("packages"))
   (:file "make"
    :depends-on ("packages"))
   (:file "program"
    :depends-on ("packages" "mir" "make"))
   (:file "type-descriptor"
    :depends-on ("packages"))
   (:file "compile-file"
    :depends-on ("program"
		 "ast-transformations"
		 "type-descriptor"
		 "graph-coloring"
		 "phase1"
		 "phase2"))))

Add file compile-time-compile.lisp. Depend on system sicl-type.

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

(asdf:defsystem :sicl-compiler
  :depends-on (:sicl-code-utilities
	       :sicl-compiler-utilities
	       :sicl-compiler-basic-blocks
	       :sicl-compiler-dominance
	       :sicl-compiler-liveness
	       :sicl-compiler-reaching-definitions
	       :sicl-compiler-def-use-chains
	       :sicl-compiler-ssa-form
	       :sicl-compiler-loops
	       :sicl-environment
	       :sicl-reader-simple
	       :sicl-type)
  :components
  ((:file "packages" :depends-on ())
   (:file "abstract-syntax-tree"
    :depends-on ("packages"))
   (:file "mir"
    :depends-on ("packages"))
   (:file "phase1"
    :depends-on ("packages" "abstract-syntax-tree"))
   (:file "ast-transformations"
    :depends-on ("packages"))
   (:file "phase2"
    :depends-on ("packages" "abstract-syntax-tree" "mir"))
   (:file "graph-coloring" :depends-on ("packages"))
   (:file "make"
    :depends-on ("packages"))
   (:file "program"
    :depends-on ("packages" "mir" "make"))
   (:file "type-descriptor"
    :depends-on ("packages"))
   (:file "compile-file"
    :depends-on ("program"
		 "ast-transformations"
		 "type-descriptor"
		 "graph-coloring"
		 "phase1"
		 "phase2"))
   (:file "compile-time-compile"
    :depends-on ("phase1"))))


;;;; -*- lisp -*-

(in-package :it.bese.arnesi)

;;;; * Portable lexical environment access

;;;; ** OpenMCL

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

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

;;;; ** SBCL

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

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

;;;; ** CMUCL

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

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

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

;;;; -*- lisp -*-

(in-package :it.bese.arnesi)

;;;; * Portable lexical environment access

;;;; ** OpenMCL

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

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

;;;; ** SBCL

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

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

;;;; ** CMUCL

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

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


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

(defparameter *syntax-trees* '())

(defun read (&optional
	       (input-stream *standard-input*)
	       (eof-error-p t)
	       (eof-value nil)
	       (recursive-p nil))
  (let ((*preserve-whitespace* recursive-p)
	(*syntax-trees* (cons (list nil) *syntax-trees*)))
    (let ((result (read-common input-stream eof-error-p eof-value)))
      (push result (cadr *syntax-trees*))
      result)))

(defun read-with-source-tracking
    (&optional (a nil a-p) (b nil b-p) (c nil c-p) (d nil d-p))
  (let* ((*syntax-trees* (list nil))
	 (result (if a-p
		     (if b-p
			 (if c-p
			     (if d-p
				 (read a b c d)
				 (read a b c))
			     (read a b))
			 (read a))
		     (read))))
    (values result (car *syntax-trees*))))

Rename stream argument and give it a reasonable default value.

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

(defparameter *syntax-trees* '())

(defun read (&optional
	       (input-stream *standard-input*)
	       (eof-error-p t)
	       (eof-value nil)
	       (recursive-p nil))
  (let ((*preserve-whitespace* recursive-p)
	(*syntax-trees* (cons (list nil) *syntax-trees*)))
    (let ((result (read-common input-stream eof-error-p eof-value)))
      (push result (cadr *syntax-trees*))
      result)))

(defun read-with-source-tracking
    (&optional
       (stream *standard-input* stream-p)
       (b nil b-p) (c nil c-p) (d nil d-p))
  (let* ((*syntax-trees* (list nil))
	 (result (if stream-p
		     (if b-p
			 (if c-p
			     (if d-p
				 (read stream b c d)
				 (read stream b c))
			     (read stream b))
			 (read stream))
		     (read))))
    (values result (car *syntax-trees*))))


;;;;; TRE transpiler environment
;;;;; Copyright (c) 2008-2009 Sven Klose <pixel@copei.de>

(defun eq (x y)
  (%%%eq x y))

(defun eql (x y)
  (unless x			; Convert falsity to 'null'.
	(setq x nil))
  (unless y
	(setq y nil))
  (or (eq x y)
	  (%%%= x y)))

Use = insteal of %%%=.

;;;;; TRE transpiler environment
;;;;; Copyright (c) 2008-2009,2011 Sven Klose <pixel@copei.de>

(defun eq (x y)
  (%%%eq x y))

(defun eql (x y)
  (unless x			; Convert falsity to 'null'.
	(setq x nil))
  (unless y
	(setq y nil))
  (or (%%%eq x y)
	  (= x y)))


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

(loop for symbol being each external-symbol in '#:common-lisp
      when (special-operator-p symbol)
	do (setf (sicl-env:special-operator symbol *environment*) t))

(setf (sicl-env:constant-variable t *environment*) t)
(setf (sicl-env:constant-variable nil *environment*) nil)

(setf (sicl-env:macro-function 'defmacro *environment*)
      (compile nil
	       (cleavir-code-utilities:parse-macro
		'defmacro
		'(name lambda-list &body body)
		`((eval-when (:compile-toplevel :load-toplevel :execute)
		    (setf (sicl-env:macro-function name *environment*)
			  (compile nil
				   (cleavir-code-utilities:parse-macro
				    name
				    lambda-list
				    body))))))))

Add default SETF expander to extrinsic environment.

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

(loop for symbol being each external-symbol in '#:common-lisp
      when (special-operator-p symbol)
	do (setf (sicl-env:special-operator symbol *environment*) t))

(setf (sicl-env:constant-variable t *environment*) t)
(setf (sicl-env:constant-variable nil *environment*) nil)

(setf (sicl-env:macro-function 'defmacro *environment*)
      (compile nil
	       (cleavir-code-utilities:parse-macro
		'defmacro
		'(name lambda-list &body body)
		`((eval-when (:compile-toplevel :load-toplevel :execute)
		    (setf (sicl-env:macro-function name *environment*)
			  (compile nil
				   (cleavir-code-utilities:parse-macro
				    name
				    lambda-list
				    body))))))))

(setf (sicl-env:default-setf-expander *environment*)
      (lambda (form)
	(if (symbolp form)
	    (let ((new (gensym)))
	      (values '()
		      '()
		      `(,new)
		      `(setq ,form ,new)
		      form))
	    (let ((temps (loop for arg in (rest form) collect (gensym)))
		  (new (gensym)))
	      (values temps
		      (rest form)
		      `(,new)
		      `(funcall #'(setf ,(first form) ,new ,@temps))
		      `(,(first form) ,@temps))))))


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

(defgeneric iterative-traversal (tree visit))

(defmethod iterative-traversal ((tree node-with-parent) visit)
  (let ((current-node tree))
    (loop do (if (or (not (funcall visit 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 (setf current-node parent)
		       finally (if (null parent)
				   (return-from iterative-traversal)
				   (setf current-node (right parent))))
		 (setf current-node
		       (or (left current-node)
			   (right current-node)))))))

Rename parameter in preparation for adding another.

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

(defgeneric iterative-traversal (tree enter))

(defmethod iterative-traversal ((tree node-with-parent) enter)
  (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 (setf current-node parent)
		       finally (if (null parent)
				   (return-from iterative-traversal)
				   (setf current-node (right parent))))
		 (setf current-node
		       (or (left current-node)
			   (right current-node)))))))


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

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

Use LISP-UNIT:RUN-TESTS rather than LISP-UNIT:RUN.

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

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


(asdf:defsystem #:neo4cl-test
  :serial t
  :license "MIT license"
  :author "James Fleming <james@electronic-quill.net>"
  :description "Test suite for neo4cl"
  :depends-on (#:neo4cl
               #:fiveam)
  :components ((:file "neo4cl-test")))

(defpackage #:neo4cl-test
  (:use #:cl
        #:neo4cl)
  (:export neo4cl))

Remove unnecessary :use statement from defpackage

(asdf:defsystem #:neo4cl-test
  :serial t
  :license "MIT license"
  :author "James Fleming <james@electronic-quill.net>"
  :description "Test suite for neo4cl"
  :depends-on (#:neo4cl
               #:fiveam)
  :components ((:file "neo4cl-test")))

(defpackage #:neo4cl-test
  (:use #:cl)
  (:export neo4cl))


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

(defun define-ensure-generic-function-r1 (boot)
  (setf (sicl-genv:fdefinition 'ensure-generic-function (r1 boot))
	(lambda (function-name &rest arguments)
	  (if (sicl-genv:fboundp function-name (r1 boot))
	      (sicl-genv:fdefinition function-name (r1 boot))
	      (setf (sicl-genv:fdefinition function-name (r1 boot))
		    (apply #'make-instance 'standard-generic-function
			   arguments))))))

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

Remove the :ENVIRONMENT keyword argument before calling MAKE-INSTANCE.

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

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

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


;;;; 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 never-clause (termination-test-clause)
  ((%form :initarg :form :reader form)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parsers.

(define-parser never-clause-parser
  (consecutive (lambda (never form)
		 (declare (ignore never))
		 (make-instance 'never-clause
		   :form form))
	       (keyword-parser 'never)
	       'anything-parser))

(add-clause-parser 'never-clause-parser)

Use existing FORM-MIXIN class as a superclass.

;;;; 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 never-clause (termination-test-clause form-mixin) ())

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parsers.

(define-parser never-clause-parser
  (consecutive (lambda (never form)
		 (declare (ignore never))
		 (make-instance 'never-clause
		   :form form))
	       (keyword-parser 'never)
	       'anything-parser))

(add-clause-parser 'never-clause-parser)


(in-package :freetype2-ffi)

 ;; Initialization

(defcfun ("FT_Init_FreeType" ft-init-freetype) ft-error
  (library (:pointer ft-library)))

(export 'ft-init-freetype)

(defcfun ("FT_Done_FreeType" ft-done-freetype) ft-error
  (library ft-library))

(export 'ft-done-freetype)

Change parameter type for finalization

(in-package :freetype2-ffi)

 ;; Initialization

(defcfun ("FT_Init_FreeType" ft-init-freetype) ft-error
  (library (:pointer ft-library)))

(export 'ft-init-freetype)

;; This takes an FT_Library, which is natively a pointer, but if
;; we make it ft-library here, CFFI will expect a wrapper, which
;; is undesirable in the finalizer.
(defcfun ("FT_Done_FreeType" ft-done-freetype) ft-error
  (library :pointer))

(export 'ft-done-freetype)


(defpackage :docker/images
  (:use :common-lisp :docker/request)
  (:export #:list-images))

(in-package :docker/images)

(defun list-images (&optional all)
  (request-json (format nil "/images/json~@[?all=1~]" all)))

(defun inspect-images (name)
  (request-json (format nil "/images/~a/json" name)))

(defun image-history (name)
  (request-json (format nil "/images/~a/history" name)))

Use keyword instead of optional arguments

(defpackage :docker/images
  (:use :common-lisp :docker/request)
  (:export #:list-images))

(in-package :docker/images)

(defun list-images (&key all)
  (request-json (format nil "/images/json~:[~;?all=1~]" all)))

(defun inspect-images (name)
  (request-json (format nil "/images/~a/json" name)))

(defun image-history (name)
  (request-json (format nil "/images/~a/history" name)))


(in-package :6502-tests)

(def-suite opcodes :in 6502-tests)
(in-suite opcodes)

(deftest brk-sets-flags
  "brk flag (4) and disable interrupts flag (2) must be set."
  (6502::brk #x00)
  (is (plusp (status-bit :break cpu)))
  (is (plusp (status-bit :interrupt cpu))))

(deftest brk-adds-3-bytes-to-stack
  "Program Counter (2) + Stack Pointer (1) == 3 bytes
   The stack is decremented from #xFF giving #xFC."
  (6502::brk #x00)
  (is (= (cpu-sp cpu) #xfc)))

(deftest ora-sets-zero-flag
  "Zero flag must be set after calling ORA."
  (6502::ora #x05)
  (is (plusp (status-bit :zero cpu))))

Update tests for new cpu passing.

(in-package :6502-tests)

(def-suite opcodes :in 6502-tests)
(in-suite opcodes)

(deftest brk-sets-flags
  "brk flag (4) and disable interrupts flag (2) must be set."
  (6502::brk #x00 cpu)
  (is (plusp (status-bit :break cpu)))
  (is (plusp (status-bit :interrupt cpu))))

(deftest brk-adds-3-bytes-to-stack
  "Program Counter (2) + Stack Pointer (1) == 3 bytes
   The stack is decremented from #xFF giving #xFC."
  (6502::brk #x00 cpu)
  (is (= (cpu-sp cpu) #xfc)))


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

(defun define-validate-superclass (boot)
  (setf (sicl-genv:fdefinition 'sicl-clos:validate-superclass (r2 boot))
	(constantly t)))

(defun define-ensure-generic-function (boot)
  (setf (sicl-genv:fdefinition 'ensure-generic-function (r2 boot))
	(lambda (function-name &rest arguments)
	  (declare (ignore arguments))
	  (sicl-genv:fdefinition function-name (r3 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)
    (define-validate-superclass boot)
    (define-ensure-generic-function boot)
    (ld "default-superclasses-temporary-defun.lisp" c r)
    (ld "../CLOS/ensure-generic-function-using-class-support.lisp" c r)))

Check that generic function has been properly defined in R3.

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

(defun define-validate-superclass (boot)
  (setf (sicl-genv:fdefinition 'sicl-clos:validate-superclass (r2 boot))
	(constantly t)))

(defun define-ensure-generic-function (boot)
  (setf (sicl-genv:fdefinition 'ensure-generic-function (r2 boot))
	(lambda (function-name &rest arguments)
	  (declare (ignore arguments))
	  (assert (sicl-genv:fboundp function-name (r3 boot)))
	  (let ((result (sicl-genv:fdefinition function-name (r3 boot))))
	    (assert (eq (class-of result)
			(sicl-genv:find-class 'standard-generic-function
					      (r1 boot))))
	    result))))

(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)
    (define-validate-superclass boot)
    (define-ensure-generic-function boot)
    (ld "default-superclasses-temporary-defun.lisp" c r)
    (ld "../CLOS/ensure-generic-function-using-class-support.lisp" c r)))


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

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

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

Increment column count in default case.

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

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

(defmethod trivial-gray-streams:stream-read-char
    ((stream source-tracking-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))


;;;; tools.lisp
;;;; Copyright (c) 2015 Thayne McCombs <astrothayne@gmail.com>

(uiop:define-package :garten/tools
    (:use :cl :garten/grower)
  (:import-from :alexandria :with-gensyms)
  (:export #:with-grower))

(in-package :garten/tools)

(defmacro with-grower ((feeder type &rest args) &body body)
  "Execute BODY where FEEDER is a function that takes a single argument, which is added
to the resulting data structure.
TYPE is the type of the structure to create. And ARGS are passed through to MAKE-GROWER.

WITH-GROWER returns the result (fruit) of the grower."
  (with-gensyms (grower item)
    `(let ((,grower (make-grower ,type ,@args)))
       (flet ((,feeder (,item)
                (feed ,grower ,item)))
         ,@body)
       (fruit ,grower))))

Add iterate macro clause for growing sequences.

;;;; tools.lisp
;;;; Copyright (c) 2015 Thayne McCombs <astrothayne@gmail.com>

(uiop:define-package :garten/tools
    (:use :cl :garten/grower :iterate)
  (:import-from :alexandria #:with-gensyms)
  (:export #:with-grower
           #:growing #:feeding))

(in-package :garten/tools)

(defmacro with-grower ((feeder type &rest args) &body body)
  "Execute BODY where FEEDER is a function that takes a single argument, which is added
to the resulting data structure.
TYPE is the type of the structure to create. And ARGS are passed through to MAKE-GROWER.

WITH-GROWER returns the result (fruit) of the grower."
  (with-gensyms (grower item)
    `(let ((,grower (make-grower ,type ,@args)))
       (flet ((,feeder (,item)
                (feed ,grower ,item)))
         ,@body)
       (fruit ,grower))))

(defmacro-clause (GROWING type FROM expr &optional INTO var WITH grower-args)
  "Iterate clause similar to COLLECT but can grow any growable structure.

TYPE is the type of growable to create. If TYPE is a symbol it doesn't need to be quoted.

If provided, GROWER-ARGS should be a plist of arguments to pass to MAKE-GROWER
after the TYPE parameter.

Note that VAR will contain the grower object, not the end result. If you store
the grower in a variable it is up to you to call FRUIT on the grower when needed.

EXPR is the actual expression to store in the grower."
  (let ((grower (or var iterate::*result-var*)))
    (when (symbolp type)
      (setf type (list 'quote type)))
    `(progn
       (with ,grower = (make-grower ,type ,@grower-args))
       (feed ,grower ,expr))))

(defsynonym feeding growing)


;;;; utils.lisp

(in-package #:githappy)

(defun url-encode (string)
  (drakma:url-encode string :utf-8))

(defun utf8-string (octets)
  (trivial-utf-8:utf-8-bytes-to-string octets))

(defun jref (json key)
  "Extract KEY from JSON. If KEY is an integer, use ELT; if it's a
  string, use GETHASH; if it's a list, call jref recursively on the
  first element."
  (etypecase key
    (string
     (gethash key json))
    (integer
     (elt json key))
    (null
     json)
    (cons
     (jref (jref (first key) json) (rest key)))))

(defun jdump (json &optional (stream *standard-output*))
  "Write JSON formatting of JSON object to STREAM."
  (yason:encode json (yason:make-json-output-stream stream
                                                    :indent t)))

(defun jdump-to-string (json)
  (with-output-to-string (s) (jdump json s)))

(defun split (delimiter string)
  (ppcre:split (ppcre:quote-meta-chars delimiter) string))

(defun starts-with (subseq seq &key (test 'eql))
  (and (<= (length subseq)
           (length seq))
       (= (mismatch subseq seq :test test)
          (length subseq))))

Add SLEEP-UNTIL, for future rate limiting perhaps.

;;;; utils.lisp

(in-package #:githappy)

(defun url-encode (string)
  (drakma:url-encode string :utf-8))

(defun utf8-string (octets)
  (trivial-utf-8:utf-8-bytes-to-string octets))

(defun jref (json key)
  "Extract KEY from JSON. If KEY is an integer, use ELT; if it's a
  string, use GETHASH; if it's a list, call jref recursively on the
  first element."
  (etypecase key
    (string
     (gethash key json))
    (integer
     (elt json key))
    (null
     json)
    (cons
     (jref (jref (first key) json) (rest key)))))

(defun jdump (json &optional (stream *standard-output*))
  "Write JSON formatting of JSON object to STREAM."
  (yason:encode json (yason:make-json-output-stream stream
                                                    :indent t)))

(defun jdump-to-string (json)
  (with-output-to-string (s) (jdump json s)))

(defun split (delimiter string)
  (ppcre:split (ppcre:quote-meta-chars delimiter) string))

(defun starts-with (subseq seq &key (test 'eql))
  (and (<= (length subseq)
           (length seq))
       (= (mismatch subseq seq :test test)
          (length subseq))))

(defun sleep-until (universal-time)
  (let ((delta (- universal-time (get-universal-time))))
    (when (plusp delta)
      (sleep delta))))


(in-package :robray)

(defun scene-file-type (filename)
  (let ((filetype (file-type filename)))
    (if filetype
        (string-case (string-downcase filetype)
          ("urdf" :urdf)
          (("robray" "curly") :curly)
          (otherwise (error "Unrecognized scene file suffix: ~A" filetype)))
        :curly)))

(defun load-scene-file (filename
                        &key
                          type
                          reload-meshes
                          (mesh-up-axis "Z")
                          (mesh-forward-axis "Y"))

  (let* ((filename (if (pathnamep filename)
                       filename
                       (rope-string filename)))
         (type (or type (scene-file-type filename))))
    (ecase type
      (:urdf (urdf-parse filename
                         :reload-meshes reload-meshes
                         :mesh-up-axis mesh-up-axis
                         :mesh-forward-axis mesh-forward-axis))
      (:curly (load-curly-scene filename :reload-meshes reload-meshes))
      (:moveit (load-moveit-scene filename
                                  :reload-meshes reload-meshes)))))

Use PATHNAME as a rope

(in-package :robray)

(defun scene-file-type (filename)
  (let ((filetype (file-type filename)))
    (if filetype
        (string-case (string-downcase filetype)
          ("urdf" :urdf)
          (("robray" "curly") :curly)
          (otherwise (error "Unrecognized scene file suffix: ~A" filetype)))
        :curly)))

(defun load-scene-file (filename
                        &key
                          type
                          reload-meshes
                          (mesh-up-axis "Z")
                          (mesh-forward-axis "Y"))

  (let* ((filename (rope-string (rope filename)))
         (type (or type (scene-file-type filename))))
    (ecase type
      (:urdf (urdf-parse filename
                         :reload-meshes reload-meshes
                         :mesh-up-axis mesh-up-axis
                         :mesh-forward-axis mesh-forward-axis))
      (:curly (load-curly-scene filename :reload-meshes reload-meshes))
      (:moveit (load-moveit-scene filename
                                  :reload-meshes reload-meshes)))))


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

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

(defmethod trivial-gray-streams:stream-read-char
    ((stream source-tracking-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))

Create a one-char buffer for UNREAD-CHAR.

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


;;; Copyright 2008 Gabor Balazs
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;     http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.
;;;
;;; $Date$

(in-package #:org.rl-community.rl-glue-codec)

(defun get-svn-codec-version ()
  (let ((glue-ver "$Revision$"))
    (subseq glue-ver 11 (- (length glue-ver) 2))))

(defun get-codec-version ()
  "1.0-RC2")

Change version from RC2 to RC3.

;;; Copyright 2008 Gabor Balazs
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;     http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.
;;;
;;; $Date$

(in-package #:org.rl-community.rl-glue-codec)

(defun get-svn-codec-version ()
  (let ((glue-ver "$Revision$"))
    (subseq glue-ver 11 (- (length glue-ver) 2))))

(defun get-codec-version ()
  "1.0-RC3")


(in-package :cl-user)
(defpackage cl-emoji-test
  (:use :cl
        :cl-emoji
        :prove))
(in-package :cl-emoji-test)

;; NOTE: To run this test file, execute `(asdf:test-system :cl-emoji)' in your Lisp.

(with-open-file (s (asdf:system-relative-pathname
		    :cl-emoji (pathname (format nil "data/emoji_~a.lisp"
                                        cl-emoji::*current-version*))))
  (let ((emoji-list (read s)))
    (plan (+ 6 (length emoji-list)))
    (dolist (u emoji-list)
      (is (length u) 12))
    (is "😀" (emoji:codepoint '("U+1F600")))
    (is "😁" (emoji:name "grinning face with smiling eyes"))
    (ok (< 0 (length (emoji:annotation "blue"))))
    (ok (< 0 (length (emoji:group "Smileys & People"))))
    (ok (< 0 (length (emoji:subgroup "clothing"))))
    (with-emoji-list (emoji-list)
      (is (emoji:with-emoji-list (el)
            (reduce (lambda (s e) (concatenate 'string s (getf e :characters)))
                    (subseq el 0 5) :initial-value ""))
          "😀😁😂🤣😃"))))

(finalize)

Reduce over-nesting not be needed

(in-package :cl-user)
(defpackage cl-emoji-test
  (:use :cl
        :cl-emoji
        :prove))
(in-package :cl-emoji-test)

;; NOTE: To run this test file, execute `(asdf:test-system :cl-emoji)' in your Lisp.

(with-open-file (s (asdf:system-relative-pathname
		    :cl-emoji (pathname (format nil "data/emoji_~a.lisp"
                                        cl-emoji::*current-version*))))
  (let ((emoji-list (read s)))
    (plan (+ 6 (length emoji-list)))
    (dolist (u emoji-list)
      (is (length u) 12))
    (is "😀" (emoji:codepoint '("U+1F600")))
    (is "😁" (emoji:name "grinning face with smiling eyes"))
    (ok (< 0 (length (emoji:annotation "blue"))))
    (ok (< 0 (length (emoji:group "Smileys & People"))))
    (ok (< 0 (length (emoji:subgroup "clothing"))))
    (is (emoji:with-emoji-list (el)
          (reduce (lambda (s e) (concatenate 'string s (getf e :characters)))
                  (subseq el 0 5) :initial-value ""))
        "😀😁😂🤣😃")))

(finalize)


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

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

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


;; Common Lisp Script
;; Manoel Vilela

(defpackage :lisp-chat/config
  (:use :cl)
  (:export :*debug*
           :*host*
           :*port*))

(in-package :lisp-chat/config)

(defparameter *debug* t "Run application in debug mode with extra info in terminal")
(defparameter *host* "localhost" "Host used in server and client")
(defparameter *port* 5558 "Default port")

Use bikelis.com as default host

;; Common Lisp Script
;; Manoel Vilela

(defpackage :lisp-chat/config
  (:use :cl)
  (:export :*debug*
           :*host*
           :*port*))

(in-package :lisp-chat/config)

(defparameter *debug* t "Run application in debug mode with extra info in terminal")
(defparameter *host* "bikelis.com" "Host used in server and client")
(defparameter *port* 5558 "Default port")


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

(defsystem cleavir-type-inference
  :depends-on (:cleavir-hir)
  :serial t
  :components
  ((:file "packages")
   (:file "dictionary")
   (:file "type-descriptor")
   (:file "sanity-checks")
   (:file "filter")
   (:file "bag-equal")
   (:file "bag-join")
   (:file "update")
   (:file "transfer")))

Add new component to system definition.

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

(defsystem cleavir-type-inference
  :depends-on (:cleavir-hir)
  :serial t
  :components
  ((:file "packages")
   (:file "dictionary")
   (:file "type-descriptor")
   (:file "sanity-checks")
   (:file "filter")
   (:file "bag-equal")
   (:file "bag-join")
   (:file "update")
   (:file "transfer")
   (:file "type-inference")))


(in-package #:spinneret)

(declaim (stream *html*))

(defparameter *html* (make-synonym-stream '*standard-output*)
  "Output stream for HTML generation.")

(declaim (string *html-lang* *html-charset*))

(defparameter *html-lang* "en")

(defparameter *html-charset* "UTF-8")

(declaim (type (integer -1 #.(1- most-positive-fixnum)) *depth*))

(defvar *depth* -1
  "Depth of the tag being output.")

(defvar *indent*)

(defun get-indent ()
  (or (serapeum:bound-value '*indent*)
      *depth*))

(defvar *pre* nil)

(defparameter *fill-column* 80
  "Column at which to wrap text.
This is always measured from the start of the tag.")

(declaim (boolean *pending-space*))

(defvar *pending-space* nil)

(defvar *html-path* nil
  "List (in ascending order) of parent nodes.")

Add assertion that the var is null at the top level.

(in-package #:spinneret)

(declaim (stream *html*))

(defparameter *html* (make-synonym-stream '*standard-output*)
  "Output stream for HTML generation.")

(declaim (string *html-lang* *html-charset*))

(defparameter *html-lang* "en")

(defparameter *html-charset* "UTF-8")

(declaim (type (integer -1 #.(1- most-positive-fixnum)) *depth*))

(defvar *depth* -1
  "Depth of the tag being output.")

(defvar *indent*)

(defun get-indent ()
  (or (serapeum:bound-value '*indent*)
      *depth*))

(defvar *pre* nil)

(defparameter *fill-column* 80
  "Column at which to wrap text.
This is always measured from the start of the tag.")

(declaim (boolean *pending-space*))

(defvar *pending-space* nil)

(defvar *html-path* nil
  "List (in ascending order) of parent nodes.")
(assert (null *html-path*))


;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-

#+(or allegro cmu ecl sbcl)
(eval-when (:compile-toplevel :load-toplevel :execute)
  (asdf:oos 'asdf:load-op :cffi-grovel))

(asdf:defsystem :static-vectors
  :description "Create vectors allocated in static memory."
  :author "Stelian Ionescu <sionescu@cddr.org>"
  :version "1.0"
  :licence "MIT"
  :depends-on (:alexandria :cffi)
  :components ((:file "pkgdcl")
               (:file "constantp" :depends-on ("pkgdcl"))
               (:file "initialize" :depends-on ("pkgdcl" "constantp"))
               #+(or allegro cmu ecl sbcl)
               (cffi-grovel:grovel-file "ffi-types" :depends-on ("pkgdcl"))
               (:file "impl"
                      :depends-on ("pkgdcl" "constantp" "initialize"
                                   #+(or allegro cmu ecl sbcl) "ffi-types")
                      :pathname #+allegro   "impl-allegro"
                                #+ccl       "impl-clozure"
                                #+cmu       "impl-cmucl"
                                #+ecl       "impl-ecl"
                                #+lispworks "impl-lispworks"
                                #+sbcl      "impl-sbcl")
               (:file "constructor" :depends-on ("pkgdcl" "constantp" "initialize" "impl"))
               (:file "cffi-type-translator" :depends-on ("pkgdcl" "impl"))))

Move dependency on cffi-grovel into :defsystem-depends-on

;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-

(defsystem :static-vectors
  :description "Create vectors allocated in static memory."
  :author "Stelian Ionescu <sionescu@cddr.org>"
  :version "1.0"
  :licence "MIT"
  :defsystem-depends-on (#+(or allegro cmu ecl sbcl) :cffi-grovel)
  :depends-on (:alexandria :cffi)
  :components ((:file "pkgdcl")
               (:file "constantp" :depends-on ("pkgdcl"))
               (:file "initialize" :depends-on ("pkgdcl" "constantp"))
               #+(or allegro cmu ecl sbcl)
               (cffi-grovel:grovel-file "ffi-types" :depends-on ("pkgdcl"))
               (:file "impl"
                      :depends-on ("pkgdcl" "constantp" "initialize"
                                   #+(or allegro cmu ecl sbcl) "ffi-types")
                      :pathname #+allegro   "impl-allegro"
                                #+ccl       "impl-clozure"
                                #+cmu       "impl-cmucl"
                                #+ecl       "impl-ecl"
                                #+lispworks "impl-lispworks"
                                #+sbcl      "impl-sbcl")
               (:file "constructor" :depends-on ("pkgdcl" "constantp" "initialize" "impl"))
               (:file "cffi-type-translator" :depends-on ("pkgdcl" "impl"))))


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

(defun make-vice-commands (out-name)
  (format t "Writing VICE monitor commands to '~A'.~%" out-name)
  (with-output-file o out-name
    (adolist ((+ (reverse *previous-labels*) *next-labels*))
      (format o "al ~A .~A~%" (print-hexword .! nil) !.))))

Add comment on how to use the generated file.

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

(defun make-vice-commands (out-name)
  (format t "Writing VICE monitor commands to '~A'.~%" out-name)
  (with-output-file o out-name
    (format o "; For VICE with command line option -moncommands ~A" out-name)
    (adolist ((+ (reverse *previous-labels*) *next-labels*))
      (format o "al ~A .~A~%" (print-hexword .! nil) !.))))


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

(defmethod acclimation:report-condition
    ((condition no-variable-info) stream (langauge acclimation:english))
  (let ((*package* (find-package '#:keyword)))
    (format stream "Undefined variable named ~s" (name condition))))

(defmethod acclimation:report-condition
    ((condition no-function-info) stream (langauge acclimation:english))
  (let ((*package* (find-package '#:keyword)))
    (format stream "Undefined function named ~s" (name condition))))

(defmethod acclimation:report-condition
    ((condition no-block-info) stream (langauge acclimation:english))
  (let ((*package* (find-package '#:keyword)))
    (format stream "Undefined block named ~s" (name condition))))

(defmethod acclimation:report-condition
    ((condition no-tag-info) stream (langauge acclimation:english))
  (let ((*package* (find-package '#:keyword)))
    (format stream "Undefined tag named ~s" (name condition))))

Fix typo in parameter name.

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

(defmethod acclimation:report-condition
    ((condition no-variable-info) stream (language acclimation:english))
  (let ((*package* (find-package '#:keyword)))
    (format stream "Undefined variable named ~s" (name condition))))

(defmethod acclimation:report-condition
    ((condition no-function-info) stream (language acclimation:english))
  (let ((*package* (find-package '#:keyword)))
    (format stream "Undefined function named ~s" (name condition))))

(defmethod acclimation:report-condition
    ((condition no-block-info) stream (language acclimation:english))
  (let ((*package* (find-package '#:keyword)))
    (format stream "Undefined block named ~s" (name condition))))

(defmethod acclimation:report-condition
    ((condition no-tag-info) stream (language acclimation:english))
  (let ((*package* (find-package '#:keyword)))
    (format stream "Undefined tag named ~s" (name condition))))


(in-package :next)

(defvar *dw-keymap* (make-keymap)
  "Keymap for `dw-mode'.")

(define-mode dw-mode ()
  "Custom mode for the custom key bindings in `*dw-keymap*'."
  ((keymap-schemes :initform (list :emacs-map *dw-keymap*
                                   :vi-normal *dw-keymap*))))

;; Gimmie that Qutebrowser feel
(define-key :keymap *dw-keymap* "C-d" #'scroll-page-down)
(define-key :keymap *dw-keymap* "C-u" #'scroll-page-up)
(define-key :keymap *dw-keymap* "J" #'switch-buffer-next)
(define-key :keymap *dw-keymap* "K" #'switch-buffer-previous)

(add-to-default-list 'vi-normal-mode 'buffer 'default-modes)
(add-to-default-list 'dw-mode 'buffer 'default-modes)

(defun my-buffer-defaults (buffer)
  (setf (zoom-ratio-default buffer) 1.6)
  (unzoom-page :buffer buffer))          ; Needed for non-web-mode buffers.

(defun my-interface-defaults ()
  (hooks:add-to-hook (hooks:object-hook *interface* 'buffer-make-hook)
                     #'my-buffer-defaults))

(hooks:add-to-hook '*after-init-hook* #'my-interface-defaults)

Swap direction of buffer movement keybindings

(in-package :next)

(defvar *dw-keymap* (make-keymap)
  "Keymap for `dw-mode'.")

(define-mode dw-mode ()
  "Custom mode for the custom key bindings in `*dw-keymap*'."
  ((keymap-schemes :initform (list :emacs-map *dw-keymap*
                                   :vi-normal *dw-keymap*))))

;; Gimmie that Qutebrowser feel
(define-key :keymap *dw-keymap* "C-d" #'scroll-page-down)
(define-key :keymap *dw-keymap* "C-u" #'scroll-page-up)
(define-key :keymap *dw-keymap* "J" #'switch-buffer-previous)
(define-key :keymap *dw-keymap* "K" #'switch-buffer-next)

(add-to-default-list 'vi-normal-mode 'buffer 'default-modes)
(add-to-default-list 'dw-mode 'buffer 'default-modes)

(defun my-buffer-defaults (buffer)
  (setf (zoom-ratio-default buffer) 1.6)
  (unzoom-page :buffer buffer))          ; Needed for non-web-mode buffers.

(defun my-interface-defaults ()
  (hooks:add-to-hook (hooks:object-hook *interface* 'buffer-make-hook)
                     #'my-buffer-defaults))

(hooks:add-to-hook '*after-init-hook* #'my-interface-defaults)


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

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

(in-package :cl-user)

(defpackage #:rsn-mtg
    (:nicknames #:mtg)
    (:use :cl
          :hunchentoot
          :cl-who
          :cl-css
          :postmodern
          :split-sequence)
    (:export #:*rsn-mtg-version*
             #:sync-db-from-gatherer))

;; see asdf system definition
(defvar rsn-mtg:*rsn-mtg-version*
  #.rsn-mtg-asd::*rsn-mtg-version*)

;; EOF

Add default directory pathname global variables, to be set in RSN app config files

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

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

(in-package :cl-user)

(defpackage #:rsn-mtg
    (:nicknames #:mtg)
    (:use :cl
          :hunchentoot
          :cl-who
          :cl-css
          :postmodern
          :split-sequence)
    (:export #:*rsn-mtg-version*
             #:*default-img-dir*
             #:sync-db-from-gatherer))

;; see asdf system definition
(defvar rsn-mtg:*rsn-mtg-version*
  #.rsn-mtg-asd::*rsn-mtg-version*)

(defvar rsn-mtg:*default-dir*
  (pathname (directory-namestring #.(or *compile-file-truename*
                                        *load-truename*)))
    "The directory path of the current file.")

(defvar rsn-mtg:*default-img-dir*
  (merge-pathnames "static/images/rsn-mtg/" rsn-mtg:*default-dir*))

;; EOF


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

(asdf:defsystem :cleavir-reaching-definitions-test
  :depends-on (:cleavir-utilities
	       :cleavir-test-utilities
	       :cleavir-reaching-definitions)
  :components
  ((:file "test-packages")
   (:file "test-reaching-definitions" :depends-on ("test-packages"))))

Define ASDF system in package ASDF-USER.

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

(defsystem :cleavir-reaching-definitions-test
  :depends-on (:cleavir-utilities
	       :cleavir-test-utilities
	       :cleavir-reaching-definitions)
  :components
  ((:file "test-packages")
   (:file "test-reaching-definitions" :depends-on ("test-packages"))))


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

Define root class for optimize ASTs.

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

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Class OPTIMIZE-AST.

(defclass optimize-ast (ast)
  ((%child-ast :initarg :child-ast :reader child-ast)))

(defun make-optimize-ast (child-ast &key origin)
  (make-instance 'optimize-ast
    :origin origin
    :child-ast child-ast))

(cleavir-io:define-save-info optimize-ast
  (:child-ast child-ast))

(defmethod children ((ast optimize-ast))
  (list (child-ast ast)))


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

;;;; A CONCRETE SYNTAX TREE (or CST for short) is a representation of
;;;; a Common Lisp expression such that the source location of each
;;;; object in the expression can be associated with that object.
;;;;
;;;; This system contains functions for manipulating such
;;;; representations in various ways.
;;;;
;;;; Notice that there is obviously no way to distinguish between a
;;;; CST and a Common Lisp expression that happens to be an atom in
;;;; the form of a CST.  Client code that uses functions of this
;;;; system must therefore be sure that CSTs are being used.

(defsystem :cleavir-cst
  :depends-on (:cleavir-code-utilities
	       :alexandria
	       :smug)
  :serial t
  :components
  ((:file "packages")
   (:file "concrete-syntax-tree")
   (:file "complete")
   (:file "rebuild")
   (:file "declarations")
   (:file "body")
   (:file "lambda-list")))

Add new component to system definition.

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

;;;; A CONCRETE SYNTAX TREE (or CST for short) is a representation of
;;;; a Common Lisp expression such that the source location of each
;;;; object in the expression can be associated with that object.
;;;;
;;;; This system contains functions for manipulating such
;;;; representations in various ways.
;;;;
;;;; Notice that there is obviously no way to distinguish between a
;;;; CST and a Common Lisp expression that happens to be an atom in
;;;; the form of a CST.  Client code that uses functions of this
;;;; system must therefore be sure that CSTs are being used.

(defsystem :cleavir-cst
  :depends-on (:cleavir-code-utilities
	       :alexandria
	       :smug)
  :serial t
  :components
  ((:file "packages")
   (:file "concrete-syntax-tree")
   (:file "complete")
   (:file "rebuild")
   (:file "declarations")
   (:file "body")
   (:file "lambda-list")
   (:file "lambda-list-parsing")))


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

(proclaim '(ftype (function (datum &rest arguments) nil)
	    error))

(proclaim '(ftype (function (number &rest more-numbers) t)
	    >))

(proclaim '(ftype (function (number &rest more-numbers) t)
	    <))

(proclaim '(ftype (function (number &rest more-numbers) t)
	    >=))

(proclaim '(ftype (function (number &rest more-numbers) t)
	    <=))

Use explicit package marker with IN-PACKAGE.

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

(proclaim '(ftype (function (datum &rest arguments) nil)
	    error))

(proclaim '(ftype (function (number &rest more-numbers) t)
	    >))

(proclaim '(ftype (function (number &rest more-numbers) t)
	    <))

(proclaim '(ftype (function (number &rest more-numbers) t)
	    >=))

(proclaim '(ftype (function (number &rest more-numbers) t)
	    <=))


;;;; p34.lisp
;;;; Calculate Euler's totient function phi(m)

(in-package :99-questions)

;;; Evaluates to the amount of relatively price numbers less than or equql to
;;; the given integer
(defun totient-phi (number)
  (loop for candidate from 1 to number
     count (coprimep number candidate)))

Use documentation strings instead of comments

;;;; p34.lisp
;;;; Calculate Euler's totient function phi(m)

(in-package :99-questions)

(defun totient-phi (number)
  "Evaluates to the amount of relatively prime numbers less than or equal to the
   given integer"
  (loop for candidate from 1 to number
     count (coprimep number candidate)))


(in-package #:sicl-clos)

(defmethod class-prototype :before ((class class))
  (unless (class-finalized-p class)
    (error "the class is not finalized")))

Use explicit package marker with IN-PACKAGE.

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

(defmethod class-prototype :before ((class class))
  (unless (class-finalized-p class)
    (error "the class is not finalized")))


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

(defsystem :sicl-sequences
  :depends-on (:lisp-unit)
  :serial t
  :components
  ((:file "packages")
   (:file "conditions")
   (:file "sequences")
   (:file "condition-reporters-en")
   (:file "docstrings-en")))

Change system name to correspond to file name.

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

(defsystem :sicl-sequence
  :depends-on (:lisp-unit)
  :serial t
  :components
  ((:file "packages")
   (:file "conditions")
   (:file "sequences")
   (:file "condition-reporters-en")
   (:file "docstrings-en")))


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

(in-package :common-lisp-user)

(asdf:defsystem :conditional-commands
  :depends-on (:mcclim)
  :components ((:file "package")
               (:file "command-and-command-table-utilities" :depends-on ("package"))
               (:file "creating-assoc" :depends-on ("package"))
               (:file "entity-enabledness-handling" :depends-on ("command-and-command-table-utilities"
                                                                 "creating-assoc"))))

Define system in package ASDF-USER.

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

(in-package #:asdf-user)

(defsystem :conditional-commands
  :depends-on (:mcclim)
  :components ((:file "package")
               (:file "command-and-command-table-utilities" :depends-on ("package"))
               (:file "creating-assoc" :depends-on ("package"))
               (:file "entity-enabledness-handling" :depends-on ("command-and-command-table-utilities"
                                                                 "creating-assoc"))))


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

;;; This software is in the public domain and is
;;; provided with absolutely no warranty.

(in-package :swap-bytes)

#+(or x86 x86-64)
(defun swap-bytes-16 (integer)
  (declare (type (unsigned-byte 16) integer))
  (swap-bytes-16 integer))

#+(or x86 x86-64)
(defun swap-bytes-32 (integer)
  (declare (type (unsigned-byte 32) integer))
  (swap-bytes-32 integer))

#+(or x86-64)
(defun swap-bytes-64 (integer)
  (declare (type (unsigned-byte 64) integer))
  (%swap-bytes-64 integer))

Fix SWAP-BYTES-64 on SBCL x86_64

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

;;; This software is in the public domain and is
;;; provided with absolutely no warranty.

(in-package :swap-bytes)

#+(or x86 x86-64)
(defun swap-bytes-16 (integer)
  (declare (type (unsigned-byte 16) integer))
  (swap-bytes-16 integer))

#+(or x86 x86-64)
(defun swap-bytes-32 (integer)
  (declare (type (unsigned-byte 32) integer))
  (swap-bytes-32 integer))

#+(or x86-64)
(defun swap-bytes-64 (integer)
  (declare (type (unsigned-byte 64) integer))
  (swap-bytes-64 integer))


;;;; -*- lisp -*-

(in-package :it.bese.arnesi)

;;;; * Portable lexical environment access

;;;; ** OpenMCL

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

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

;;;; ** SBCL

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

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

;;;; ** CMUCL

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

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

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

;;;; -*- lisp -*-

(in-package :it.bese.arnesi)

;;;; * Portable lexical environment access

;;;; ** OpenMCL

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

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

;;;; ** SBCL

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

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

;;;; ** CMUCL

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

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


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

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

Use :SERIAL T for a simpler system.

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

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


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

(defsystem :sicl-sequence-tiny
  :depends-on (:lisp-unit)
  :serial t
  :components
  ((:file "packages")
   (:file "conditions")
   (:file "Tiny/sequences-tiny")
   (:file "condition-reporters-en")
   (:file "docstrings-en")))

Update component locations according to new file orgainzation.

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

(defsystem :sicl-sequence-tiny-support
  :serial t
  :components
  ((:file "Common/packages")
   (:file "Common/conditions")
   (:file "Common/condition-reporters-en")
   (:file "Common/docstrings-en")
   (:file "Common/utilities")
   (:file "Tiny/utilities")
   (:file "Tiny/find")
   (:file "Tiny/position")
   (:file "Tiny/count")))


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

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

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

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

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