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

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

Use unexported names for slot writers.

Use unexported names for slot writers.


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

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

Load a file containing the definition of the macro DEFCLASS.


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

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

Change load order so WRAPPER is available to SFFI


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

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

Change soname of syscall wrapper library.


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

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

Fix test to reflect change to scheme style reduce.


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

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

Test finding multiple package versions.

libraries/ospama: Test finding multiple package versions.


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

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

Comment out the in-package form by default


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

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

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


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

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

Define a function for defining ALLOCATE-GENERAL-INSTANCE.


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

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

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

Load file containing support code for class finalization.


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

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

Remove log4cl from the dependencies for the freetype system


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

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

Update calls to renamed function.

Update calls to renamed function.


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

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

Replace dependency mpc with maxpc.

Replace dependency mpc with maxpc.


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

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

Fix incorrect terminology in PRINT-OBJECT methods.


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

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

Set the Google jump URL to the proper thing


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

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

Define ASDF system in package ASDF-USER.


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

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

Fix symbol exporting from IOLIB.BASE

Fix symbol exporting from IOLIB.BASE

Signed-off-by: Stelian Ionescu <c3ad3339b5ffc3418808e627431a7cb60f2334f3@common-lisp.net>


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

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

Stop stack overflow when loaded from sys.int.


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

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

Save new definition in environment.

Save new definition in 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))

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

Put deprecated symbols into extra export

git-svn-id: c85a71f3e7cf752db9973e11a7b5f9797dd6d327@58 3eedd062-5d29-411c-93cb-ccde70ca5252


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

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

Add info about setting inferior-lisp-program.


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

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

Clean up the ASD file.

Clean up the ASD file.

The docs module specification was erroneous and served no real purpose.
This commit removes the module to stop ASDF from complaining.


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

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

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


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

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

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

darcs-hash:20050719152230-dd2a1-020627dbba3080ad3dd9b8086e892978f81028d3


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

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

Rename stream argument and give it a reasonable default value.


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

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

Use = insteal of %%%=.

EQUAL: Use = insteal of %%%=.


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

Add default SETF expander to extrinsic environment.


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

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

Rename parameter in preparation for adding another.


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

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

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


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

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

Remove unnecessary :use statement from defpackage


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

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

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


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

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

Use existing FORM-MIXIN class as a superclass.


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

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

Change parameter type for finalization

Change parameter type for finalization


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

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

Use keyword instead of optional arguments


Use COMMON-LISP package in mysqlnd

Use COMMON-LISP package in mysqlnd


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

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

Update tests for new cpu passing.

Update tests for new cpu passing.


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

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

Check that generic function has been properly defined in R3.


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

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

Increment column count in default case.

Increment column count in default case.


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

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

Add iterate macro clause for growing sequences.


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

Add SLEEP-UNTIL, for future rate limiting perhaps.


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

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

Use PATHNAME as a rope

Use PATHNAME as a rope


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

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

Create a one-char buffer for UNREAD-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")

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

Change version from RC2 to RC3.

Change version from RC2 to 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)

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

Reduce over-nesting not be needed

Reduce over-nesting not be needed


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

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

(in-package :cl-user)

#+lispworks (require "comm")

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

             #:with-connected-socket ; macros

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

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

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

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

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

(in-package :cl-user)

#+lispworks (require "comm")

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

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

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

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

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

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


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

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

Use bikelis.com as default host

Use bikelis.com as default host


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

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

Add new component to system definition.

Add new component to system definition.


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

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


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

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

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


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

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

Add comment on how to use the generated file.


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

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

Fix typo in parameter name.

Fix typo in parameter name.


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

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

Swap direction of buffer movement keybindings


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

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

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


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

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

Define ASDF system in package ASDF-USER.


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

Define root class for optimize ASTs.

Define root class for optimize ASTs.


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

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

Add new component to system definition.

Add new component to system definition.


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

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

Use explicit package marker with IN-PACKAGE.


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

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

Use documentation strings instead of comments


(in-package #:sicl-clos)

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

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

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

Change system name to correspond to file name.


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

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

Define system in package ASDF-USER.

Define system in package ASDF-USER.


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

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

Fix SWAP-BYTES-64 on SBCL x86_64


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

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

Fix openmcl's definition of lexical-variables to deal with ccl::definition-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 ())))

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

Use :SERIAL T for a simpler system.

Use :SERIAL T for a simpler system.


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

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

Update component locations according to new file orgainzation.


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

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

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

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


;;;; package.lisp

(defpackage #:aviation-formulary
  (:nicknames :af)
  (:use #:cl)
  (:export :2d-point
	   :3d-point
	   :spot-point
	   :pp
	   :point-lat
	   :point-lon
	   :message-type
	   :battery-state
	   :unix-time
	   :point-user
	   :point-generated
	   :point-gps
	   :point-spot
	   :creation-source
	   :rad-to-km
	   :km-to-rad
	   :deg-to-rad
	   :rad-to-deg
	   :deg-to-cardinal-course
	   :url-photo
	   :url-map
	   :google-url-hybrid
	   :google-url-photo
	   :google-url-map
	   :point-serialize
	   :point-deserialize
	   :calc-distance
	   :calc-distance-shorter
	   :calc-gc-bearing
	   :calc-new-point
	   :serialize-points-to-file
	   :deserialize-points-from-file
	   :true-to-magnetic
	   :magnetic-to-true))

;;;; package.lisp

(defpackage #:aviation-formulary
  (:nicknames :af)
  (:use #:cl)
  (:export :2d-point
	   :3d-point
	   :spot-point
	   :gps-point
	   :pp
	   :point-lat
	   :point-lon
	   :message-type
	   :battery-state
	   :unix-time
	   :point-user
	   :point-generated
	   :point-gps
	   :point-spot
	   :creation-source
	   :rad-to-km
	   :km-to-rad
	   :deg-to-rad
	   :rad-to-deg
	   :deg-to-cardinal-course
	   :url-photo
	   :url-map
	   :google-url-hybrid
	   :google-url-photo
	   :google-url-map
	   :point-serialize
	   :point-deserialize
	   :calc-distance
	   :calc-distance-shorter
	   :calc-gc-bearing
	   :calc-new-point
	   :serialize-points-to-file
	   :deserialize-points-from-file
	   :true-to-magnetic
	   :magnetic-to-true))

Support for gps points (ie, gpsd).

Support for gps points (ie, gpsd).


(in-package #:event-loop)

(defclass future ()
  ((finished :initarg :finished :accessor finishedp :initform NIL)
   (result :initarg :result :accessor result :initform NIL)
   (err :initarg :error :accessor err :initform NIL)
   (event-loop :initarg :event-loop :accessor event-loop :initform (error "Must specify event-loop to use."))))

(defmethod finish ((future future) &key result error)
  (setf (finishedp future) T
        (result future) result
        (err future) error))

(defmethod join ((future future))
  (while (not (finishedp future))
    (run-once (event-loop future)))
  (if (err future)
    (error (err future))
    (result future)))

(in-package #:event-loop)

(defclass future ()
  ((finished :initarg :finished :accessor finishedp :initform NIL)
   (result :initarg :result :accessor result :initform NIL)
   (err :initarg :error :accessor err :initform NIL)
   (event-loop :initarg :event-loop :accessor event-loop :initform (error "Must specify event-loop to use."))))

(defmethod finish ((future future) &key result error)
  (setf (finishedp future) T
        (result future) result
        (err future) error))

(defmethod join ((future future))
  (while (not (finishedp future))
    (run-once (event-loop future)))
  (if (err future)
    (error (format NIL "~A" (err future)))
    (result future)))

Fix a bug by always throwing a string error