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

Make the compiler depend on the reader.

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


;; Common Lisp bindings for GTK+ v2.0
;; Copyright (C) 2001 Espen S. Johnsen <esj@stud.cs.uit.no>
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 2 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

;; $Id: pango.lisp,v 1.1 2001-05-20 23:13:08 espen Exp $

(in-package "PANGO")

(eval-when (:compile-toplevel :load-toplevel :execute)
  (init-types-in-library
   "/opt/gnome/lib/libpango.so"
   :ignore ("_pango_fribidi_get_type")))

(define-types-by-introspection "Pango")

Define types at both compile and run time

;; Common Lisp bindings for GTK+ v2.0
;; Copyright (C) 2001 Espen S. Johnsen <esj@stud.cs.uit.no>
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 2 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

;; $Id: pango.lisp,v 1.2 2001-05-29 16:56:13 espen Exp $

(in-package "PANGO")

(eval-when (:compile-toplevel :load-toplevel :execute)
  (init-types-in-library
   "/opt/gnome/lib/libpango.so"
   :ignore ("_pango_fribidi_get_type"))

  (define-types-by-introspection "Pango"))


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

(declaim (inline consp car cdr rplaca rplacd))

;;; It might seem backward to define CONSP in terms of TYPEP, but
;;; TYPEP with a quoted arguments is transformed by a compiler macro
;;; into (SICL-TYPE:TYPEQ OBJECT CONS), which is processed by the type
;;; inference mechanism.  Should there be any remaining instances of
;;; (SICL-TYPE:TYPEQ OBJECT CONS) when the type inference is finished,
;;; it is transformed into a low-level operation that tests the tag
;;; bits.  In the implementation of TYPEP, when it turns out that the
;;; type being tested for is CONS, there might very well be a call to
;;; CONSP, which might then look circular, but it really is not
;;; because of what was said above.
(defun consp (object)
  (typep object 'cons))

(defun car (list)
  (declare (type list list))
  (if (consp list)
      (load-car list)
      nil))

(defun cdr (list)
  (declare (type list list))
  (if (consp list)
      (load-cdr list)
      nil))

(defun rplaca (cons object)
  (declare (type cons cons))
  (store-car cons object)
  cons)

(defun rplacd (cons object)
  (declare (type cons cons))
  (store-cdr cons object)
  cons)

Simplify and use recently introduced Cleavir PRIMOPs.

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

(defun car (list)
  (declare (type list list))
  (if (consp list)
      (cleavir-primop:car list)
      nil))

(defun cdr (list)
  (declare (type list list))
  (if (consp list)
      (cleavir-primop:cdr list)
      nil))

(defun rplaca (cons object)
  (declare (type cons cons))
  (cleavir-primop:rplaca cons object)
  cons)

(defun rplacd (cons object)
  (declare (type cons cons))
  (cleavir-primop:rplacd cons object)
  cons)


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

(defun remove-if (fun x)
  (when x
    (if (funcall fun (car x))
        (remove-if fun (cdr x))
        (cons (car x)
			  (remove-if fun (cdr x))))))

(defun remove-if-not (fun x)
  (remove-if (fn not (funcall fun _))
			 x))

(defun remove (elm x &optional (test #'eq))
  (remove-if (fn funcall test elm _)
			 x))

TEST ist a keyword argument.

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

(defun remove-if (fun x)
  (when x
    (if (funcall fun (car x))
        (remove-if fun (cdr x))
        (cons (car x)
			  (remove-if fun (cdr x))))))

(defun remove-if-not (fun x)
  (remove-if (fn not (funcall fun _))
			 x))

(defun remove (elm x &key (test #'eq))
  (remove-if (fn funcall test elm _)
			 x))


;;;; Reusable algorithms.

(defpackage erlangen.algorithms
  (:documentation "Reusable algorithms.")
  (:use :cl)
  (:export :with-poll-timeout))

(in-package :erlangen.algorithms)

(defun poll-timeout% (predicate timeout poll-interval success-fn fail-fn)
  (loop for elapsed = 0 then (+ elapsed poll-interval) do
       (cond ((> elapsed timeout)
              (return-from poll-timeout% (funcall fail-fn)))
             ((funcall predicate)
              (return-from poll-timeout% (funcall success-fn)))
             (t
              (sleep poll-interval)))))

(defmacro with-poll-timeout ((predicate-form &key timeout poll-interval)
                             &key succeed fail)
  "Poll every POLL-INTERVAL seconds until PREDICATE-FORM returns a true
value or TIMEOUT seconds have elapsed. In the former case evaluate and
return the result of SUCCEED. Otherwise evaluate and return the result of
FAIL."
  `(poll-timeout% (lambda () ,predicate-form) ,timeout ,poll-interval
                  (lambda () ,succeed)
                  (lambda () ,fail)))

Add a special branch for (= timeout 0) to ERLANGEN.ALGORITHMS:WITH-POLL-TIMEOUT, effectively causing a timeout of 0 to mean non-blocking.

;;;; Reusable algorithms.

(defpackage erlangen.algorithms
  (:documentation "Reusable algorithms.")
  (:use :cl)
  (:export :with-poll-timeout))

(in-package :erlangen.algorithms)

(defun poll-timeout% (predicate timeout poll-interval success-fn fail-fn)
  (when (= timeout 0)
    (if (funcall predicate)
        (return-from poll-timeout% (funcall success-fn))
        (return-from poll-timeout% (funcall fail-fn))))
  (loop for elapsed = 0 then (+ elapsed poll-interval) do
       (cond ((> elapsed timeout)
              (return-from poll-timeout% (funcall fail-fn)))
             ((funcall predicate)
              (return-from poll-timeout% (funcall success-fn)))
             (t
              (sleep poll-interval)))))

(defmacro with-poll-timeout ((predicate-form &key timeout poll-interval)
                             &key succeed fail)
  "Poll every POLL-INTERVAL seconds until PREDICATE-FORM returns a true
value or TIMEOUT seconds have elapsed. In the former case evaluate and
return the result of SUCCEED. Otherwise evaluate and return the result of
FAIL."
  `(poll-timeout% (lambda () ,predicate-form) ,timeout ,poll-interval
                  (lambda () ,succeed)
                  (lambda () ,fail)))


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

(defclass dynamic-environment-entry () ())

(defclass variable-binding (dynamic-environment-entry)
  ((%symbol :initarg :symbol :reader symbol)
   (%value :initarg :value :reader value)))

(defclass unwind-protect (dynamic-environment-entry)
  ((%thunk :initarg :thunk :reader thunk)))

(defclass catch-tag (dynamic-environment-entry)
  ((%value :initarg :value :reader value)
   ;; The thunk in this slot executes a non-local GO in the host,
   ;; which unwinds the host stack.
   (%thunk :initarg :thunk :reader thunk)))

;;; The dynamic environment is a list of instances of the class
;;; DYNAMIC-ENVIRONMENT-ENTRY.
(defparameter *dynamic-environment* '())

Make it possible to transmit values to CATCH.

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

(defclass dynamic-environment-entry () ())

(defclass variable-binding (dynamic-environment-entry)
  ((%symbol :initarg :symbol :reader symbol)
   (%value :initarg :value :reader value)))

(defclass unwind-protect (dynamic-environment-entry)
  ((%thunk :initarg :thunk :reader thunk)))

(defclass catch-tag (dynamic-environment-entry)
  ((%value :initarg :value :reader value)
   ;; The function in this slot takes a single argument which must be
   ;; a list of values to return from the CATCH.  When invoked, this
   ;; function executes the host form (RETURN-FROM <block-name> (APPLY
   ;; #'VALUES ARG)).
   (%function :initarg :function :reader function)))

;;; The dynamic environment is a list of instances of the class
;;; DYNAMIC-ENVIRONMENT-ENTRY.
(defparameter *dynamic-environment* '())


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

(defgeneric rotate-left (tree))

(defgeneric rotate-right (tree))

(defmethod rotate-left (tree)
  (error 'invalid-binary-tree :tree tree))

;;; Given a tree with the following shape:
;;;
;;;         tree
;;;        /    \
;;;       /      \
;;;      l       r
;;;             / \
;;;            /   \
;;;           rl   rr
;;;
;;; we turn it into a tree with this shape:
;;;
;;;           r
;;;          / \
;;;         /   \
;;;       tree  rr
;;;       /   \
;;;      /     \
;;;     l      rl
;;;
;;; The node R is returned
(defmethod rotate-left ((tree node))
  (when (null (right tree))
    (error 'right-subtree-must-be-non-nil :tree tree))
  (let* ((r (right tree))
	 (rl (left r)))
    (setf (right tree) rl
	  (left r) tree)
    r))

Add method on ROTATE-RIGHT specialized to NODE.

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

(defgeneric rotate-left (tree))

(defgeneric rotate-right (tree))

(defmethod rotate-left (tree)
  (error 'invalid-binary-tree :tree tree))

;;; Given a tree with the following shape:
;;;
;;;         tree
;;;         /  \
;;;        /    \
;;;       l     r
;;;            / \
;;;           /   \
;;;          rl   rr
;;;
;;; we turn it into a tree with this shape:
;;;
;;;           r
;;;          / \
;;;         /   \
;;;       tree  rr
;;;       /  \
;;;      /    \
;;;     l     rl
;;;
;;; The node R is returned
(defmethod rotate-left ((tree node))
  (when (null (right tree))
    (error 'right-subtree-must-be-non-nil :tree tree))
  (let* ((r (right tree))
	 (rl (left r)))
    (setf (right tree) rl
	  (left r) tree)
    r))

;;; Given a tree with the following shape:
;;;
;;;          tree
;;;          /  \
;;;         /    \
;;;        l      r
;;;       / \
;;;      /   \
;;;     ll   lr
;;;
;;; we turn it into a tree with this shape:
;;;
;;;         l
;;;        / \
;;;       /   \
;;;      ll   tree
;;;           /  \
;;;          /    \
;;;         lr     r
;;;
;;; The node L is returned
(defmethod rotate-right ((tree node))
  (when (null (left tree))
    (error 'left-subtree-must-be-non-nil :tree tree))
  (let* ((l (left tree))
	 (lr (right l)))
    (setf (left tree) lr
	  (right l) tree)
    l))


;;;; site-generator.asd

(asdf:defsystem #:site-generator
  :serial t
  :description "Describe site-generator here"
  :author "Alex Charlton <alex.n.charlton@gmail.com>"
  :license "BSD-2"
  :depends-on (:let-plus :alexandria :iterate :hunchentoot :com.dvlsoft.clon :cl-ppcre :cl-fad :bordeaux-threads :osicat :cl-who)
  :components ((:file "package")
	       (:file "utility")
	       (:file "content")
	       (:file "templates")
	       (:file "publish")
	       (:file "test-server")
               (:file "site-generator"))
  :in-order-to ((test-op (load-op :site-generator-test)))
  :perform (test-op :after (op c)
		    (funcall (intern (string '#:run!) :it.bese.fiveam)
			     :site-generator)))

(asdf:defsystem :site-generator-test
  :author "Alex Charlton <alex.n.charlton@gmail.com>"
  :licence "BSD-3"
  :depends-on (:fiveam)
  :pathname "tests/"
  :serial t
  :components ((:file "suite")
	       (:file "tests")))

Add :local-time to asd file

;;;; site-generator.asd

(asdf:defsystem #:site-generator
  :serial t
  :description "Describe site-generator here"
  :author "Alex Charlton <alex.n.charlton@gmail.com>"
  :license "BSD-2"
  :depends-on (:let-plus :alexandria :iterate :hunchentoot :com.dvlsoft.clon :cl-ppcre :cl-fad :bordeaux-threads :osicat :cl-who :local-time)
  :components ((:file "package")
	       (:file "utility")
	       (:file "content")
	       (:file "templates")
	       (:file "publish")
	       (:file "test-server")
               (:file "site-generator"))
  :in-order-to ((test-op (load-op :site-generator-test)))
  :perform (test-op :after (op c)
		    (funcall (intern (string '#:run!) :it.bese.fiveam)
			     :site-generator)))

(asdf:defsystem :site-generator-test
  :author "Alex Charlton <alex.n.charlton@gmail.com>"
  :licence "BSD-3"
  :depends-on (:fiveam)
  :pathname "tests/"
  :serial t
  :components ((:file "suite")
	       (:file "tests")))


#|
  This file is a part of cl-oclapi project.
  Copyright (c) 2015 gos-k (mag4.elan@gmail.com)
|#

(in-package :cl-user)
(defpackage cl-oclapi
  (:use :cl
        :cffi
        :cl-reexport))
(in-package :cl-oclapi)

(reexport-from :cl-oclapi.constants)
(reexport-from :cl-oclapi.types)
(reexport-from :cl-oclapi.functions)
(reexport-from :cl-oclapi.information)

(reexport-from :cl-oclapi.helpers.safe-call)
(reexport-from :cl-oclapi.helpers.with-macro)
(reexport-from :cl-oclapi.helpers.memory)

(eval-when (:load-toplevel)
  (define-foreign-library libopencl
    (:windows (:default "OpenCL"))
    (t        (:default "libOpenCL")))

  (unless (foreign-library-loaded-p 'libopencl)
    (use-foreign-library libopencl)))

Add OpenCL framework on OSX.

#|
  This file is a part of cl-oclapi project.
  Copyright (c) 2015 gos-k (mag4.elan@gmail.com)
|#

(in-package :cl-user)
(defpackage cl-oclapi
  (:use :cl
        :cffi
        :cl-reexport))
(in-package :cl-oclapi)

(reexport-from :cl-oclapi.constants)
(reexport-from :cl-oclapi.types)
(reexport-from :cl-oclapi.functions)
(reexport-from :cl-oclapi.information)

(reexport-from :cl-oclapi.helpers.safe-call)
(reexport-from :cl-oclapi.helpers.with-macro)
(reexport-from :cl-oclapi.helpers.memory)

(eval-when (:load-toplevel)
  (define-foreign-library libopencl
    (:windows (:default "OpenCL"))
    (:darwin (:framework "OpenCL"))
    (t        (:default "libOpenCL")))

  (unless (foreign-library-loaded-p 'libopencl)
    (use-foreign-library libopencl)))


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

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

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

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

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

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

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

Use new generic function in main function.

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

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

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

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

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

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

(defun remove-useless-instructions (initial-instruction)
  (cleavir-ir:reinitialize-data initial-instruction)
  (let ((useless-instructions '()))
    (cleavir-ir:map-instructions-arbitrary-order
     (lambda (instruction)
       (when (instruction-may-be-removed-p instruction)
	 (push instruction useless-instructions)))
     initial-instruction)
    (mapc #'cleavir-ir:delete-instruction useless-instructions)))


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

(defpackage #:cleavir-cst
  (:use #:common-lisp)
  (:export
   #:canonicalize-declaration-specifier
   #:cst-is-declaration-p
   #:cst-is-literal-string-p
   #:separate-ordinary-body
   #:separate-function-body
   #:facultative-parameter
   #:variables-cst
   #:init-form-cst
   #:supplied-p-parameter-cst
   #:facultative-parameter
   #:optional-parameter
   #:facultative-parameters
   #:optional-parameters
   #:keyword-cst
   #:parameters
   #:keyword-parameter
   #:keyword-name-cst
   #:keyword-parameters))

Remove duplicate export entry for FACULATIVE-PARAMETER.

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

(defpackage #:cleavir-cst
  (:use #:common-lisp)
  (:export
   #:canonicalize-declaration-specifier
   #:cst-is-declaration-p
   #:cst-is-literal-string-p
   #:separate-ordinary-body
   #:separate-function-body
   #:variables-cst
   #:init-form-cst
   #:supplied-p-parameter-cst
   #:facultative-parameter
   #:optional-parameter
   #:facultative-parameters
   #:optional-parameters
   #:keyword-cst
   #:parameters
   #:keyword-parameter
   #:keyword-name-cst
   #:keyword-parameters))


(defvar *dist-url* "http://beta.quicklisp.org/dist/quicklisp/2016-08-25/distinfo.txt")

(load "quicklisp.lisp")

(quicklisp-quickstart:install :path "/opt/app-root/quicklisp/" :dist-url *dist-url*)

; Pre-load/compile useful content...
(ql:quickload :hunchentoot)
(ql:quickload :swank)

(with-open-file (out "/opt/app-root/.sbclrc" :direction :output)
  (format out "(load \"/opt/app-root/quicklisp\/setup.lisp\")")
  (format out "(swank:create-server :port 4005 :dont-close t :coding-system \"utf-8-unix\")"))

Load swank before running it

(defvar *dist-url* "http://beta.quicklisp.org/dist/quicklisp/2016-08-25/distinfo.txt")

(load "quicklisp.lisp")

(quicklisp-quickstart:install :path "/opt/app-root/quicklisp/" :dist-url *dist-url*)

; Pre-load/compile useful content...
(ql:quickload :hunchentoot)
(ql:quickload :swank)

(with-open-file (out "/opt/app-root/.sbclrc" :direction :output)
  (format out "(load \"/opt/app-root/quicklisp\/setup.lisp\")")
  (format out "(ql:quickload :swank)")
  (format out "(swank:create-server :port 4005 :dont-close t :coding-system \"utf-8-unix\")"))


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

(defsystem :cleavir-basic-blocks
  :depends-on (:cleavir-utilities
	       :cleavir-hir)
  :components
  ((:file "packages")
   (:file "basic-blocks" :depends-on ("packages"))))

Use option :SERIAL T to simplify system.

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

(defsystem :cleavir-basic-blocks
  :depends-on (:cleavir-utilities
	       :cleavir-hir)
  :serial t
  :components
  ((:file "packages")
   (:file "basic-blocks")))


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

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

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

(asdf:defsystem :sicl-string
  :serial t
  :components
  ((:file "packages")
   (:file "conditions")
   (:file "condition-reporters-en")
   (:file "utilities")
   (:file "copy")
   (:file "case-conversion")
   (:file "string")
   (:file "trim")
   (:file "comparison")))

Use package ASDF-USER for system definition.

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

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

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

(defsystem :sicl-string
  :serial t
  :components
  ((:file "packages")
   (:file "conditions")
   (:file "condition-reporters-en")
   (:file "utilities")
   (:file "copy")
   (:file "case-conversion")
   (:file "string")
   (:file "trim")
   (:file "comparison")))


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

;;; For the specification of this function, see
;;; http://metamodular.com/CLOS-MOP/ensure-generic-function.html
;;;
;;; This function is also specified in the CLHS.
;;; http://www.lispworks.com/documentation/HyperSpec/Body/f_ensure.htm#ensure-generic-function

(defun ensure-generic-function
    (name
     &rest keys
     &key (environment sicl-env:*global-environment*)
     &allow-other-keys)
  (let ((generic-function
	  (if (sicl-environment:fboundp name environment)
	      (let ((fun (sicl-environment:fdefinition name)))
		(if (typep fun 'generic-function)
		    fun
		    (error 'type-error
			   :datum fun
			   :expected-type '(or null generic-function))))
	      nil)))
    (apply #'ensure-generic-function-using-class
	   generic-function name keys)))

Use function GLOBAL-ENVIRONMENT rather than deprecated variable *GLOBAL-ENVIRONMENT*.

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

;;; For the specification of this function, see
;;; http://metamodular.com/CLOS-MOP/ensure-generic-function.html
;;;
;;; This function is also specified in the CLHS.
;;; http://www.lispworks.com/documentation/HyperSpec/Body/f_ensure.htm#ensure-generic-function

(defun ensure-generic-function
    (name
     &rest keys
     &key (environment (sicl-genv:global-environment))
     &allow-other-keys)
  (let ((generic-function
	  (if (sicl-environment:fboundp name environment)
	      (let ((fun (sicl-environment:fdefinition name)))
		(if (typep fun 'generic-function)
		    fun
		    (error 'type-error
			   :datum fun
			   :expected-type '(or null generic-function))))
	      nil)))
    (apply #'ensure-generic-function-using-class
	   generic-function name keys)))


(in-package #:cl-user)
(eval-when (:load-toplevel :compile-toplevel :execute)
  (push :verbose-no-init *features*)
  #+quicklisp (ql:quickload :verbose)
  #-quicklisp (asdf:load-system :verbose))

(asdf:defsystem ld33
  :author "Nicolas Hafner <shinmera@tymoon.eu>"
  :maintainer "Nicolas Hafner <shinmera@tymoon.eu>"
  :homepage "https://github.com/Shinmera/ld33"
  :version "0.0.0"
  :components ((:file "package")
               (:file "toolkit")
               (:file "fixed-queue")
               (:file "world")
               (:file "planet")
               (:file "player")
               (:file "windowing"))
  :defsystem-depends-on (:qtools)
  :depends-on (:flare
               :qtools
               :qtcore
               :qtgui
               :qtopengl)
  :build-operation "qt-program-op"
  :build-pathname "the-end"
  :entry-point "ld33:standalone")

Remove in-package from ASD file.


;;; The symbols that are shadowed from the COMMON-LISP package
;;; are also symbols that we want to export.  To avoid repeating
;;; that list of symbols, we use the reader macros #= and ##.
;;; It is interesting to note that we would normally write
;;; (:shadow <string1> <string2> ...), but in order to put a
;;; reader label on the list (<string1> <string2> ...) we need to
;;; express that as (:shadow . (<string1> <string2> ...)) instead.
(defpackage #:sicl-loop
  (:use #:common-lisp
	#:sicl-additional-conditions)
  (:shadow . #1=(#:loop))
  (:export . #1#))

;;; In the test package, we want to import all symbols of the
;;; COMMON-LISP package, except the ones that were shadowed in
;;; the package that we are testing.  We do that by programatically
;;; getting the list of those symbols using the function
;;; package-shadowing symbols.  But since defpackage doesn't evaluate
;;; the symbols in the :shadowing-import-from list, we need to
;;; have the reader produce that list, hence the use of the #. reader
;;; macro and again of the consing dot followed by a list.
(defpackage #:sicl-loop-test
  (:shadowing-import-from #:sicl-loop .
			  #.(package-shadowing-symbols '#:sicl-loop))
  (:use #:sicl-loop #:cl #:lisp-unit))

Remove test package and don't shadow LOOP.

;;;; Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013
;;;;
;;;;     Robert Strandh (robert.strandh@gmail.com)
;;;;
;;;; Copyright (c) 2010, 2011
;;;;
;;;;     Matthieu Villeneuve (matthieu.villeneuve@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 loop module of the SICL project.
;;;; See the file SICL.text for a description of the project.

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

(defpackage #:sicl-loop
  (:use #:common-lisp
	#:sicl-additional-conditions))


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

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

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

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

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


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

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

Load a file containing the definition of the class REGULAR-CLASS.

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

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


(defpackage #:squares
  (:use #:cl)
  (:export #:sum-of-squares
           #:square-of-sums
           #:difference))

(in-package #:squares)

Rename square-of-sums to square-of-sum to match the tests

(defpackage #:squares
  (:use #:cl)
  (:export #:sum-of-squares
           #:square-of-sum
           #:difference))

(in-package #:squares)


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

(defsystem :cleavir-primop
  :components
  ((:file "packages")))

Add comment explaining the need for primops and what their purpose is.

;;;; Primitive operations (or primops for short) are similar to Common
;;;; Lisp special operators in that the compiler handles them
;;;; specially.  They are different from Common Lisp special operators
;;;; in that a primop does not necessarily have an evaluation rule
;;;; that is different from that of a function call.
;;;;
;;;; Generally speaking, primops should not be used directly in
;;;; application code.  Instead, they are used in system code for
;;;; implementing certain basic Common Lisp function.  So, for
;;;; example, the CONSP primop would typically be used only in the
;;;; code for the Common Lisp function CONSP.  That function would
;;;; then be inlined by the compiler, so that the resulting AST and
;;;; ultimately the resulting HIR instruction that the CONSP primop
;;;; translates to will be present also in application code.
;;;;
;;;; Frequently, the need for a primop comes from arises because some
;;;; HIR instruction is needed.  Take, for example, the HIR
;;;; instruction named EQ-INSTRUCTION for comparing two pointer values
;;;; for equality.  The existence of that instruction requires an AST
;;;; doing the same thing, and it is called EQ-AST.  When compiled to
;;;; HIR, the EQ-AST generates the an EQ-INSTRUCTION.  Finally, in
;;;; order to produce the source for the Common Lisp function EQ, it
;;;; must be possible to produce the EQ-AST from some Common Lisp
;;;; code, which is why the EQ primop is needed.

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

(defsystem :cleavir-primop
  :components
  ((:file "packages")))


(in-package :de.anvi.croatoan)

(defun add-string (window string &key attributes color-pair y x n)
  "Add the unrendered string to the window.

If n is given, write at most n chars from the string. If n is -1, as
many chars will be added that will fit on the line.

If the coordinates y and x are given, move to the destination first
and then add the string."
  (when (and y x) (move window y x))
  (let ((count (if n
                   (if (= n -1)
                       (- (.width window) (cadr (.cursor-position window)))
                       n)
                   (length string))))
    (typecase string
      (string
       (if (or attributes color-pair)
           ;; lisp string combined with attributes and colors
           (loop
              repeat count
              for ch across string
              do (add-char window ch :attributes attributes :color-pair color-pair))
           ;; simple lisp string, no attributes or colors
           (if n
               (%waddnstr (.winptr window) string n)
               (%waddstr  (.winptr window) string))))
      (complex-string
       (loop
          repeat count
          for ch across (.complex-char-array string)
          do (add-char window ch))))))

Make add-string work with complex-string types.

(in-package :de.anvi.croatoan)

(defun add-string (window string &key attributes color-pair y x n)
  "Add the unrendered string to the window.

If n is given, write at most n chars from the string. If n is -1, as
many chars will be added that will fit on the line.

If the coordinates y and x are given, move to the destination first
and then add the string."
  (when (and y x) (move window y x))
  (let ((count (if n
                   (if (= n -1)
                       (- (.width window) (cadr (.cursor-position window)))
                       n)
                   ;; we cant use length to determine the length of a complex string
                   ;; because it is not a sequence.
                   (typecase string
                     (string (length string))
                     (complex-string (length (.complex-char-array string)))))))
    (typecase string
      (string
       (if (or attributes color-pair)
           ;; lisp string combined with attributes and colors
           (loop
              repeat count
              for ch across string
              do (add-char window ch :attributes attributes :color-pair color-pair))
           ;; simple lisp string, no attributes or colors
           (if n
               (%waddnstr (.winptr window) string n)
               (%waddstr  (.winptr window) string))))
      (complex-string
       (loop
          repeat count
          for ch across (.complex-char-array string)
          do (add-char window ch))))))


(asdf:defsystem :sicl
  :name "sicl"
  :components ((:file "packages")
	       (:file "tags" :depends-on ("packages"))
	       (:file "cons" :depends-on ("tags"))
	       (:file "backends-cl" :depends-on ("packages" "tags"))))

Define ASDF system in package ASDF-USER.

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

(defsystem :sicl
  :name "sicl"
  :components ((:file "packages")
	       (:file "tags" :depends-on ("packages"))
	       (:file "cons" :depends-on ("tags"))
	       (:file "backends-cl" :depends-on ("packages" "tags"))))


(in-package :cl-user)

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

(in-package :js.system)

(defsystem :js
    :name "js"
    :author "Manuel Odendahl <manuel@bl0rg.net>"
    :version "0"
    :maintainer "Manuel Odendahl <manuel@bl0rg.net>"
    :licence "BSD"
    :description "js - javascript compiler"

    :depends-on (#-allegro
                 :htmlgen)

    :components ((:file "package")
		 (:file "utils" :depends-on ("package"))
		 (:file "js" :depends-on ("package" "utils"))
		 (:file "js-html" :depends-on ("package" "js" "utils"))
		 (:file "css" :depends-on ("package" "utils"))))

Rename the system/package in the system definition.

;;;; -*- lisp -*-

(in-package :cl-user)

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

(in-package :parenscript.system)

(defsystem :parenscript
    :name "parenscript"
    :author "Manuel Odendahl <manuel@bl0rg.net>"
    :version "0"
    :maintainer "Manuel Odendahl <manuel@bl0rg.net>"
    :licence "BSD"
    :description "js - javascript compiler"

    :depends-on (#-allegro :htmlgen)

    :components ((:file "package")
		 (:file "utils" :depends-on ("package"))
		 (:file "js" :depends-on ("package" "utils"))
		 (:file "js-html" :depends-on ("package" "js" "utils"))
		 (:file "css" :depends-on ("package" "utils"))))


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

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

(defclass type-spec () ())

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

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

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

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

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

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

Fix names of individual parsers.

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

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

(defclass type-spec () ())

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

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

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

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

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

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


(in-package #:turtle-geometry)

(defun initialize ()
  (initialize-shaders *shader-directory*))

(defun handle-input ()
  (when (key-pressed-p :escape)
    (close-window)))
(defun render ())
(defun update ())
(defun cleanup ())

(defun run ()
  (err-run "turtle geometry"
           :init-code (initialize)
           :input-code (handle-input)
           :render-code (render)
           :update-code (update)
           :cleanup-code (cleanup)))

Add update and render timers.

(in-package #:turtle-geometry)

(defun initialize ()
  (initialize-shaders *shader-directory*))

(defun handle-input ()
  (when (key-pressed-p :escape)
    (close-window)))

(let ((render-timer (make-timer :end (/ 1.0 60.0))))
  (defun render ()
    (timer-update render-timer)
    (when (timer-ended-p render-timer)
      )))

(let ((update-timer (make-timer :end (/ 1.0 120.0))))
  (defun update ()
    (timer-update update-timer)
    (iter (while (timer-ended-p update-timer))
      (timer-keep-overflow update-timer)
      )))

(defun cleanup ())

(defun run ()
  (err-run "turtle geometry"
           :init-code (initialize)
           :input-code (handle-input)
           :render-code (render)
           :update-code (update)
           :cleanup-code (cleanup)))


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

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

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

(defun test-one-splay-with-node (tree node)
  (let* ((traversal1 (in-order-traversal tree))
	 (ignore (clump-splay-tree:splay node))
	 (traversal2 (in-order-traversal node)))
    (declare (ignore ignore))
    (assert (equal traversal1 traversal2))))

(defun test-one-splay (tree)
  (test-one-splay-with-node tree (select-random-node tree)))

Replace obsolete package prefix with correct one.

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

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

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

(defun test-one-splay-with-node (tree node)
  (let* ((traversal1 (in-order-traversal tree))
	 (ignore (clump-binary-tree:splay node))
	 (traversal2 (in-order-traversal node)))
    (declare (ignore ignore))
    (assert (equal traversal1 traversal2))))

(defun test-one-splay (tree)
  (test-one-splay-with-node tree (select-random-node tree)))


#|
This file is a part of cl-transmission project.
Copyright (c) 2017 Thomas Schaper (Thomas@libremail.nl)
|#

#|
Author: Thomas Schaper (Thomas@libremail.nl)
|#

(asdf:defsystem "cl-transmission"
  :version "0.1"
  :author "Thomas Schaper"
  :license "MIT"
  :depends-on ("rutils"
               "drakma"
               "named-readtables"
               "x.let-star"
               "bordeaux-threads"
               "cl-ppcre"
               "uiop"
               "jonathan")
  :components ((:module "src"
                :components
                ((:file "cl-transmission" :depends-on ("util" "constants"))
                 (:file "constants" :depends-on ("util"))
                 (:file "util"))))
  :description ""
  :long-description
  #.(with-open-file (stream (merge-pathnames
                             #p"README.org"
                             (or *load-pathname* *compile-file-pathname*))
                            :if-does-not-exist nil
                            :direction :input)
      (when stream
        (let ((seq (make-array (file-length stream)
                               :element-type 'character
                               :fill-pointer t)))
          (setf (fill-pointer seq) (read-sequence seq stream))
          seq)))
  :in-order-to ((test-op (test-op cl-transmission-test))))

Remove useless dependency on ``bordeaux-threads''

#|
This file is a part of cl-transmission project.
Copyright (c) 2017 Thomas Schaper (Thomas@libremail.nl)
|#

#|
Author: Thomas Schaper (Thomas@libremail.nl)
|#

(asdf:defsystem "cl-transmission"
  :version "0.1"
  :author "Thomas Schaper"
  :license "MIT"
  :depends-on ("rutils"
               "drakma"
               "named-readtables"
               "x.let-star"
               "cl-ppcre"
               "uiop"
               "jonathan")
  :components ((:module "src"
                :components
                ((:file "cl-transmission" :depends-on ("util" "constants"))
                 (:file "constants" :depends-on ("util"))
                 (:file "util"))))
  :description ""
  :long-description
  #.(with-open-file (stream (merge-pathnames
                             #p"README.org"
                             (or *load-pathname* *compile-file-pathname*))
                            :if-does-not-exist nil
                            :direction :input)
      (when stream
        (let ((seq (make-array (file-length stream)
                               :element-type 'character
                               :fill-pointer t)))
          (setf (fill-pointer seq) (read-sequence seq stream))
          seq)))
  :in-order-to ((test-op (test-op cl-transmission-test))))


;;;; © 2016-2019 Marco Heisig         - license: GNU AGPLv3 -*- coding: utf-8 -*-

(in-package #:petalisp.type-inference)

(define-rule coerce (object result-type)
  (let ((object-ntype (wrapper-ntype object))
        (result-ntype (wrapper-ntype result-type)))
    (with-constant-folding (coerce (object-ntype t)
                                   (result-ntype type-specifier))
      (if (eql-ntype-p result-type)
          (let ((result-ntype (ntype result-type)))
            (ntype-subtypecase result-ntype
              (short-float
               (rewrite-as
                (coerce-to-short-float object)))
              (single-float
               (rewrite-as
                (coerce-to-single-float object)))
              (double-float
               (rewrite-as
                (coerce-to-double-float object)))
              (long-float
               (rewrite-as
                (coerce-to-long-float object)))
              (complex-short-float
               (rewrite-as
                (coerce-to-complex-short-float)))
              (complex-single-float
               (rewrite-as
                (coerce-to-complex-single-float)))
              (complex-double-float
               (rewrite-as
                (coerce-to-complex-double-float)))
              (complex-long-float
               (rewrite-as
                (coerce-to-complex-long-float)))
              (t
               (rewrite-default result-ntype))))))))

Fix the type inference rule of COERCE.

;;;; © 2016-2019 Marco Heisig         - license: GNU AGPLv3 -*- coding: utf-8 -*-

(in-package #:petalisp.type-inference)

(define-rule coerce (object result-type)
  (let ((object-ntype (wrapper-ntype object))
        (result-ntype (wrapper-ntype result-type)))
    (with-constant-folding (coerce (object-ntype t)
                                   (result-ntype type-specifier))
      (if (eql-ntype-p result-ntype)
          (let ((result-ntype (ntype result-ntype)))
            (ntype-subtypecase result-ntype
              (short-float
               (rewrite-as
                (coerce-to-short-float object)))
              (single-float
               (rewrite-as
                (coerce-to-single-float object)))
              (double-float
               (rewrite-as
                (coerce-to-double-float object)))
              (long-float
               (rewrite-as
                (coerce-to-long-float object)))
              (complex-short-float
               (rewrite-as
                (coerce-to-complex-short-float)))
              (complex-single-float
               (rewrite-as
                (coerce-to-complex-single-float)))
              (complex-double-float
               (rewrite-as
                (coerce-to-complex-double-float)))
              (complex-long-float
               (rewrite-as
                (coerce-to-complex-long-float)))
              (t
               (rewrite-default result-ntype))))))))


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

(defgeneric delete (leaf))

(defgeneric delete-child (parent child))

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

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

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

(defmethod delete-child ((node 2-node) child)
  (replace-and-shrink (parent node)
		      (if (eq child (left node))
			  (right node)
			  (left node))))

Define method on DELETE-CHILD specialized to 3-NODE.

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

(defgeneric delete (leaf))

(defgeneric delete-child (parent child))

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

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

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

(defmethod delete-child ((node 2-node) child)
  (replace-and-shrink (parent node)
		      (if (eq child (left node))
			  (right node)
			  (left node))))

(defmethod delete-child ((node 3-node) child)
  (let ((2-node-class (2-node-class (tree node))))
    (if (eq child (left node))
	(replace-and-shrink (parent node)
			    (make-instance 2-node-class
			      :left (middle node)
			      :right (right node)))
	(if (eq child (middle node))
	    (replace-and-shrink (parent node)
				(make-instance 2-node-class
				  :left (left node)
				  :right (right node)))
	    (replace-and-shrink (parent node)
				(make-instance 2-node-class
				  :left (left node)
				  :right (middle node)))))))


(cl:in-package #:sicl-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))

Put code in specific package.

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


(defpackage :sdl2-image.asdf
  (:use #:cl #:asdf))

(in-package :sdl2-image.asdf)

(defsystem :sdl2-image
  :description "Bindings for sdl2_image using autowrap"
  :author "Ryan Pavlik"
  :license "MIT"
  :version "1.0"

  :depends-on (:alexandria :defpackage-plus :cl-autowrap :sdl2 :trivial-garbage)
  :pathname "src"
  :serial t

  :components
  ((:file "package")
   (:file "library")
   (:file "autowrap")
   (:file "conditions")
   (:file "general")

   (:module autowrap-spec
    :pathname "spec"
    :components
    ((:static-file "SDL_image.h")))))

Add myself as current maintainer

(defpackage :sdl2-image.asdf
  (:use #:cl #:asdf))

(in-package :sdl2-image.asdf)

(defsystem :sdl2-image
  :description "Bindings for sdl2_image using autowrap"
  :author "Ryan Pavlik"
  :maintainer ("Michael Fiano <mail@michaelfiano.com>")
  :license "MIT"
  :version "1.0"

  :depends-on (:alexandria :defpackage-plus :cl-autowrap :sdl2 :trivial-garbage)
  :pathname "src"
  :serial t

  :components
  ((:file "package")
   (:file "library")
   (:file "autowrap")
   (:file "conditions")
   (:file "general")

   (:module autowrap-spec
    :pathname "spec"
    :components
    ((:static-file "SDL_image.h")))))


(in-package #:cliki2)

;;; unreferenced uri checking
(dolist (unreferenced-uri (set-difference %referenced-uris %defined-uris
                                          :key #'car :test #'string-equal))
  (warn "Reference warning: referencing unknown URI resource ~a in file ~a"
        (car unreferenced-uri) (cdr unreferenced-uri)))

;; BKNR's policy of storing *random-state*, besides being annoying in
;; SBCL, is also a security hole
(defmethod bknr.datastore::ensure-store-random-state :around ((store store))
  (bknr.datastore::initialize-store-random-state store))

(defun load-cliki-store ()
  (close-store)
  (open-store (merge-pathnames "store/" *datadir*))

  (init-recent-revisions)

  (bt:make-thread
   (lambda ()
     (loop (sleep (* 7 24 60 60)) (snapshot)))))

(defun start-cliki-server ()
  (let ((acceptor (make-instance
                   'easy-acceptor
                   :port (read-config-file "port")
                   :access-log-destination nil
                   :message-log-destination *error-log*)))
    (start acceptor)
    acceptor))

Set *random-state* to a fresh random state on load

(in-package #:cliki2)

;;; unreferenced uri checking
(dolist (unreferenced-uri (set-difference %referenced-uris %defined-uris
                                          :key #'car :test #'string-equal))
  (warn "Reference warning: referencing unknown URI resource ~a in file ~a"
        (car unreferenced-uri) (cdr unreferenced-uri)))

;; BKNR's policy of storing *random-state*, besides being annoying in
;; SBCL, is also a security hole
(defmethod bknr.datastore::ensure-store-random-state :around ((store store))
  (bknr.datastore::initialize-store-random-state store))

;; SBCL and CCL use same random on each startup
(setf *random-state* (make-random-state t))

(defun load-cliki-store ()
  (close-store)
  (open-store (merge-pathnames "store/" *datadir*))

  (init-recent-revisions)

  (bt:make-thread
   (lambda ()
     (loop (sleep (* 7 24 60 60)) (snapshot)))))

(defun start-cliki-server ()
  (let ((acceptor (make-instance
                   'easy-acceptor
                   :port (read-config-file "port")
                   :access-log-destination nil
                   :message-log-destination *error-log*)))
    (start acceptor)
    acceptor))


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

(defsystem :static-vectors
  :description "Create vectors allocated in static memory."
  :author "Stelian Ionescu <sionescu@cddr.org>"
  :version "1.1"
  :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"))))

Use keyword to specify cffi-grovel file class

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

(defsystem :static-vectors
  :description "Create vectors allocated in static memory."
  :author "Stelian Ionescu <sionescu@cddr.org>"
  :version "1.1"
  :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-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"))))


;;;; restas.asd
;;;;
;;;; This file is part of the RESTAS library, released under Lisp-LGPL.
;;;; See file COPYING for details.
;;;;
;;;; Author: Moskvitin Andrey <archimag@gmail.com>

(defsystem #:restas
    :depends-on (#:hunchentoot #:bordeaux-threads #:routes #:alexandria #:data-sift)
    :pathname "src"
    :components ((:file "packages")
                 (:file "special" :depends-on ("packages"))
                 (:file "declarations" :depends-on ("packages"))
                 (:file "errors" :depends-on ("special"))
                 (:file "render" :depends-on ("special"))
                 (:file "context" :depends-on ("special"))
                 (:file "module" :depends-on ("context" "declarations"))
                 (:file "route" :depends-on ("module" "render"))
                 (:file "decorators" :depends-on ("route"))
                 (:file "vhost" :depends-on ("special"))
                 (:file "hunchentoot" :depends-on ("vhost" "module" "errors"))
                 (:file "policy" :depends-on ("packages"))))

     ;; #+swank-archimag
     ;; (:module "slime"
     ;;          :components ((:file "restas-swank"))
     ;;          :depends-on ("src"))))

Add explicit dependency on CFFI to provide a call to CFFI-SYS:NATIVE-NAMESTRING in decorators.lisp for LispWorks.

;;;; restas.asd
;;;;
;;;; This file is part of the RESTAS library, released under Lisp-LGPL.
;;;; See file COPYING for details.
;;;;
;;;; Author: Moskvitin Andrey <archimag@gmail.com>

(defsystem #:restas
    :depends-on (#:cffi #:hunchentoot #:bordeaux-threads
                 #:routes #:alexandria #:data-sift)
    :pathname "src"
    :components ((:file "packages")
                 (:file "special" :depends-on ("packages"))
                 (:file "declarations" :depends-on ("packages"))
                 (:file "errors" :depends-on ("special"))
                 (:file "render" :depends-on ("special"))
                 (:file "context" :depends-on ("special"))
                 (:file "module" :depends-on ("context" "declarations"))
                 (:file "route" :depends-on ("module" "render"))
                 (:file "decorators" :depends-on ("route"))
                 (:file "vhost" :depends-on ("special"))
                 (:file "hunchentoot" :depends-on ("vhost" "module" "errors"))
                 (:file "policy" :depends-on ("packages"))))

     ;; #+swank-archimag
     ;; (:module "slime"
     ;;          :components ((:file "restas-swank"))
     ;;          :depends-on ("src"))))


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

(asdf:defsystem :cleavir-loops
  :depends-on (:cleavir-utilities)
  :components
  ((:file "packages")
   (:file "loops" :depends-on ("packages"))))

Define system in package ASDF-USER.

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

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


(in-package :med)

(defclass buffer-stream (sys.gray::fundamental-character-output-stream)
  ((buffer :initarg :buffer-name :reader buffer-stream-buffer-name)))

(defmethod sys.gray::stream-line-column ((stream buffer-stream))
  (col-index-of stream))

(defmethod sys.gray::stream-write-char ((stream buffer-stream) char)
  (insert (get-buffer-create (buffer-stream-buffer-name stream)) char))

(setf *messages* (make-instance 'buffer-stream :buffer-name "*Messages*"))

Update how characters are written to the end of the buffer.

(in-package :med)

(defclass buffer-stream (sys.gray::fundamental-character-output-stream)
  ((buffer :initarg :buffer-name :reader buffer-stream-buffer-name)))

(defmethod sys.gray::stream-line-column ((stream buffer-stream))
  (col-index-of stream))

(defmethod sys.gray::stream-write-char ((stream buffer-stream) char)
  (let ((buffer (get-buffer-create (buffer-stream-buffer-name stream))))
    (save-excursion (buffer)
      (move-end-of-buffer buffer)
      (insert buffer char))))


(require :asdf)

(defparameter *vlime-home* (make-pathname :directory (pathname-directory *load-truename*)))

(defun load-vlime ()
  (asdf/find-system:initialize-source-registry
    `(:source-registry
       (:directory ,*vlime-home*)
       :inherit-configuration))
  (asdf/operate:load-system :vlime-sbcl))

(load-vlime)
(swank:create-server :port 4005 :style :spawn :dont-close t)
#-win32
(vlime-sbcl:main #(0 0 0 0) 7002 #(127 0 0 1) 4005)
#+win32
(vlime-sbcl:main-threaded #(0 0 0 0) 7002 #(127 0 0 1) 4005)

Use a more generic feature flag

(require :asdf)

(defparameter *vlime-home* (make-pathname :directory (pathname-directory *load-truename*)))

(defun load-vlime ()
  (asdf/find-system:initialize-source-registry
    `(:source-registry
       (:directory ,*vlime-home*)
       :inherit-configuration))
  (asdf/operate:load-system :vlime-sbcl))

(load-vlime)
(swank:create-server :port 4005 :style :spawn :dont-close t)
#-windows
(vlime-sbcl:main #(0 0 0 0) 7002 #(127 0 0 1) 4005)
#+windows
(vlime-sbcl:main-threaded #(0 0 0 0) 7002 #(127 0 0 1) 4005)


(asdf:defsystem markdown-docstrings
  :author "Gregory Tod <lisp@gtod.net>"
  :version "0.2.0"
  :license "MIT"
  :description "Horrible little docstrings to Markdown converter"
  :depends-on (#:alexandria
               #:uiop/filesystem
               #:cl-ppcre)
  :components ((:file "markdown-docstrings")))

Fix system :uiop dependency of markdown-doscstrings

(asdf:defsystem markdown-docstrings
  :author "Gregory Tod <lisp@gtod.net>"
  :version "0.2.0"
  :license "MIT"
  :description "Horrible little docstrings to Markdown converter"
  :depends-on (#:alexandria
               #:uiop
               #:cl-ppcre)
  :components ((:file "markdown-docstrings")))


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

(asdf:defsystem :sicl-clos-phase3
  :depends-on (:sicl-clos-phase1 :sicl-clos-phase2)
  ;; We use :SERIAL T so as to reduce the clutter with respect to the
  ;; dependencies, and to make the order completely predictable.
  :serial t
  :components
  ((:file "heap-instance")
   (:file "allocate-instance-support")
   (:file "allocate-instance-defuns")
   (:file "fmakunbound-make-instance")
   ))

Include recently added symbolic links as components.

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

(asdf:defsystem :sicl-clos-phase3
  :depends-on (:sicl-clos-phase1 :sicl-clos-phase2)
  ;; We use :SERIAL T so as to reduce the clutter with respect to the
  ;; dependencies, and to make the order completely predictable.
  :serial t
  :components
  ((:file "heap-instance")
   (:file "allocate-instance-support")
   (:file "allocate-instance-defuns")
   (:file "fmakunbound-make-instance")
   (:file "standard-instance-access")
   (:file "initialize-support")
   ))


(describe simple-let
          (== (let ())
              nil)
          (== (let ()
                42)
              42))

(describe let-with-multiple-expr-body
          (== (let ()
                1
                2)
              2))

(describe let-bindings
          (== (let* ((x 1)
                     (y 2))
                (+ x y))
              3)
          (let ((x 2))
            (== (let ((x 1)
                      (y (+ x 1)))
                  y)
                3)))

(describe let-binding-scope
          (== (begin (let ((zz 2)) zz)
                     zz)
              nil))

(describe named-let
          (== (let loop
                ((numbers ’(3 -2 1 6 -5))
                 (nonneg ’())
                 (neg ’()))
                (cond ((null? numbers)
                       (list nonneg neg))
                      ((>= (car numbers) 0)
                       (loop (cdr numbers)
                          (cons (car numbers) nonneg)
                          neg))
                      (else
                       (loop (cdr numbers)
                          nonneg
                          (cons (car numbers) neg)))))
              '((6 1 3) (-5 -2))))

Fix typo (copy-paste single quotes).

(describe simple-let
          (== (let ())
              nil)
          (== (let ()
                42)
              42))

(describe let-with-multiple-expr-body
          (== (let ()
                1
                2)
              2))

(describe let-bindings
          (== (let* ((x 1)
                     (y 2))
                (+ x y))
              3)
          (let ((x 2))
            (== (let ((x 1)
                      (y (+ x 1)))
                  y)
                3)))

(describe let-binding-scope
          (== (begin (let ((zz 2)) zz)
                     zz)
              nil))

(describe named-let
          (== (let loop
                ((numbers '(3 -2 1 6 -5))
                 (nonneg '())
                 (neg '()))
                (cond ((null? numbers)
                       (list nonneg neg))
                      ((>= (car numbers) 0)
                       (loop (cdr numbers)
                          (cons (car numbers) nonneg)
                          neg))
                      (else
                       (loop (cdr numbers)
                          nonneg
                          (cons (car numbers) neg)))))
              '((6 1 3) (-5 -2))))


#+xcvb (module ())

(in-package :cl)

(defpackage :inferior-shell
  (:use :cl :fare-utils :fare-matcher :xcvb-driver :named-readtables :fare-mop)
  (:export
   #:run #:run/s #:run/ss #:run/lines
   #:simple-command-line-token #:token-string
   #:process-spec #:command-spec #:pipe-spec
   #:or-spec #:and-spec #:progn-spec #:fork-spec
   #:print-process-spec #:parse-process-spec
   #:command-arguments #:command-redirections
   #:redirection #:file-redirection #:fd-redirection #:close-redirection
   #:! #:- #:< #:> #:<> #:>! #:>> #:>>! #:<& #:>& #:>&! #:>>&!
   #:>& #:>> #:>>& #:pipe #:or #:and #:progn #:fork
   #:zglobcmd #:zglob
   #:*backend*))

Fix package wrt newer fare-utils.

#+xcvb (module ())

(in-package :cl)

(defpackage :inferior-shell
  (:use :cl :fare-utils :fare-matcher :xcvb-driver :named-readtables :fare-mop :alexandria)
  (:shadowing-import-from :xcvb-driver #:emptyp) ;; also in alexandria
  (:shadowing-import-from :fare-matcher #:of-type) ;; also in alexandria
  (:export
   #:run #:run/s #:run/ss #:run/lines
   #:simple-command-line-token #:token-string
   #:process-spec #:command-spec #:pipe-spec
   #:or-spec #:and-spec #:progn-spec #:fork-spec
   #:print-process-spec #:parse-process-spec
   #:command-arguments #:command-redirections
   #:redirection #:file-redirection #:fd-redirection #:close-redirection
   #:! #:- #:< #:> #:<> #:>! #:>> #:>>! #:<& #:>& #:>&! #:>>&!
   #:>& #:>> #:>>& #:pipe #:or #:and #:progn #:fork
   #:zglobcmd #:zglob
   #:*backend*))


(in-package :cl-user)

(ql:quickload :arrow-macros)
(defpackage #:lisp-interface
  (:use #:cl #:cl-neovim #:arrow-macros)
  (:shadowing-import-from #:cl #:defun #:eval))
(in-package :lisp-interface)

(nvim:defcommand/s lisp (&rest form)
  (declare (opts nargs))
  (let ((output (with-output-to-string (*standard-output*)
                  (->> form  ; == '("(+" "1" "2)")
                    (format nil "~{~A~^ ~}")
                    read-from-string
                    eval))))
    (nvim:command (format nil "echo '~A'" output))))

(in-package :cl-user)

Make :Lisp function more readable

(in-package :cl-user)

(defpackage #:lisp-interface
  (:use #:cl #:cl-neovim)
  (:shadowing-import-from #:cl #:defun #:eval))
(in-package :lisp-interface)

(defmacro echo-output (&body forms)
  (let ((output (gensym)))
    `(let ((,output (with-output-to-string (*standard-output*)
                     ,@forms)))
       (nvim:command (format nil "echo '~A'" ,output)))))

(defun eval-string (str)
  (eval (read-from-string str)))

(nvim:defcommand/s lisp (&rest form)
  (declare (opts nargs))
  (echo-output (eval-string (format nil "~{~A~^ ~}" form))))

(in-package :cl-user)


(defpackage #:sodium
  (:use :cl :cffi)
  (:nicknames :cr))

(defpackage #:sodium.accessors
  (:use :cl :cffi :sodium)
  (:nicknames :cr-a))

(in-package :sodium)

(eval-when (:load-toplevel)
  (unless (cffi:foreign-symbol-pointer "sodium_init")
    (define-foreign-library libsodium
      (:darwin (:or "libsodium.dylib"))
      (:unix (:or "libsodium"))
      (:windows (:or "libsodium-10.dll"
                     "libsodium.dll"))
      (t (:default "libsodium")))
    (unless (foreign-library-loaded-p 'libsodium)
      (use-foreign-library libsodium))))

Fix library name on unix (needs .so extension).

(defpackage #:sodium
  (:use :cl :cffi)
  (:nicknames :cr))

(defpackage #:sodium.accessors
  (:use :cl :cffi :sodium)
  (:nicknames :cr-a))

(in-package :sodium)

(eval-when (:load-toplevel)
  (unless (cffi:foreign-symbol-pointer "sodium_init")
    (define-foreign-library libsodium
      (:darwin (:or "libsodium.dylib"))
      (:unix (:or "libsodium.so"))
      (:windows (:or "libsodium-10.dll"
                     "libsodium.dll"))
      (t (:default "libsodium")))
    (unless (foreign-library-loaded-p 'libsodium)
      (use-foreign-library libsodium))))


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

(loop for entry in *bridge-generic-functions*
      do (load-call-history (cdr entry)))

Use new function for satiating a generic function.

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

(loop for entry in *bridge-generic-functions*
      do (satiate-generic-function (cdr entry)))


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

(defsystem sicl-source-tracking-reader
  :depends-on (:sicl-reader-simple
	       :cleavir-cst)
  :serial t
  :components
  ())

Add new component to system definition.

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

(defsystem sicl-source-tracking-reader
  :depends-on (:sicl-reader-simple
	       :cleavir-cst)
  :serial t
  :components
  ((:file "read")))


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

(defclass size-mixin ()
  ((%size :initarg :size :reader size)))

(defclass leaf-size (size-mixin clump-2-3-tree:leaf)
  ()
  (:default-initargs :size 1))

(defclass 2-node-size (size-mixin clump-2-3-tree:2-node)
  ())

(defgeneric recompute-size (node))

(defmethod recompute-size ((node 2-node-size))
  (reinitialize-instance
   node
   :size (+ (size (clump-2-3-tree:left node))
	    (size (clump-2-3-tree:right node)))))

(defmethod initialize-instance :after ((object 2-node-size) &key)
  (recompute-size object))

(defclass 3-node-size (size-mixin clump-2-3-tree:3-node)
  ())

(defmethod initialize-instance :after ((object 3-node-size) &key)
  (reinitialize-instance
   object
   :size (+ (size (clump-2-3-tree:left object))
	    (size (clump-2-3-tree:middle object))
	    (size (clump-2-3-tree:right object)))))

(defclass size-tree (clump-2-3-tree:tree)
  ()
  (:default-initargs
   :2-node-class '2-node-size
   :3-node-class '3-node-size))

Use slot writer rather than REINITIALIZE-INSTANCE.

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

(defclass size-mixin ()
  ((%size :initarg :size :accessor size)))

(defclass leaf-size (size-mixin clump-2-3-tree:leaf)
  ()
  (:default-initargs :size 1))

(defclass 2-node-size (size-mixin clump-2-3-tree:2-node)
  ())

(defgeneric recompute-size (node))

(defmethod recompute-size ((node 2-node-size))
  (setf (size node)
	(+ (size (clump-2-3-tree:left node))
	   (size (clump-2-3-tree:right node)))))

(defmethod initialize-instance :after ((object 2-node-size) &key)
  (recompute-size object))

(defclass 3-node-size (size-mixin clump-2-3-tree:3-node)
  ())

(defmethod initialize-instance :after ((object 3-node-size) &key)
  (reinitialize-instance
   object
   :size (+ (size (clump-2-3-tree:left object))
	    (size (clump-2-3-tree:middle object))
	    (size (clump-2-3-tree:right object)))))

(defclass size-tree (clump-2-3-tree:tree)
  ()
  (:default-initargs
   :2-node-class '2-node-size
   :3-node-class '3-node-size))


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

(asdf:defsystem :sicl-clos-phase3
  :depends-on (:sicl-clos-phase1 :sicl-clos-phase2)
  ;; We use :SERIAL T so as to reduce the clutter with respect to the
  ;; dependencies, and to make the order completely predictable.
  :serial t
  :components
  ((:file "finalize-classes")
   (:file "install-generic-functions")
   (:file "heap-instance")
   (:file "class-of")
   (:file "allocate-instance-support")
   (:file "allocate-instance-defuns")
   (:file "fmakunbound-make-instance")
   (:file "standard-instance-access")
   (:file "slot-value-etc-support")
   (:file "slot-value-etc-defuns")
   (:file "fmakunbound-slot-value")
   (:file "slot-value-etc-specified-defuns")
   (:file "initialize-support")
   (:file "generic-function-database")
   (:file "defgeneric-defmacro")
   (:file "accessor-defgenerics")
   (:file "class-database")
   ))

Install bridge generic functions later in the pase.

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

(asdf:defsystem :sicl-clos-phase3
  :depends-on (:sicl-clos-phase1 :sicl-clos-phase2)
  ;; We use :SERIAL T so as to reduce the clutter with respect to the
  ;; dependencies, and to make the order completely predictable.
  :serial t
  :components
  ((:file "finalize-classes")
   (:file "heap-instance")
   (:file "class-of")
   (:file "allocate-instance-support")
   (:file "allocate-instance-defuns")
   (:file "fmakunbound-make-instance")
   (:file "standard-instance-access")
   (:file "slot-value-etc-support")
   (:file "slot-value-etc-defuns")
   (:file "fmakunbound-slot-value")
   (:file "slot-value-etc-specified-defuns")
   (:file "initialize-support")
   (:file "install-generic-functions")
   (:file "generic-function-database")
   (:file "defgeneric-defmacro")
   (:file "accessor-defgenerics")
   (:file "class-database")
   ))


(defpackage :shcl/test/main
  (:use :common-lisp)
  (:import-from :shcl/test/lexer)
  (:import-from :shcl/test/utility)
  (:import-from :shcl/test/posix)
  (:import-from :shcl/test/lisp-interpolation)
  (:import-from :shcl/test/data)
  (:import-from :shcl/test/iterator)
  (:import-from :shcl/test/command)
  (:import-from :shcl/test/fd-table)
  (:import-from :shcl/test/foundation
                #:run-test-set #:all-tests #:package-test-set #:symbol-test)
  (:import-from :shcl/core/command)
  (:import-from :prove)
  (:import-from :fset)
  (:export #:run-all-tests))
(in-package :shcl/test/main)

(shcl/core/command:define-builtin -shcl-run-tests (&option package)
  "Run unit tests."
  (let ((prove:*enable-colors* nil)
        (prove:*test-result-output* *standard-output*)
        (test-set (fset:empty-set)))
    (cond
      ((zerop (length package))
       (setf test-set (all-tests)))

      (t
       (loop :for package :across package :do
          (fset:unionf test-set (package-test-set package)))))
    (if (run-test-set test-set)
        0
        1)))

Test should be run in a subshell

(defpackage :shcl/test/main
  (:use :common-lisp)
  (:import-from :shcl/test/lexer)
  (:import-from :shcl/test/utility)
  (:import-from :shcl/test/posix)
  (:import-from :shcl/test/lisp-interpolation)
  (:import-from :shcl/test/data)
  (:import-from :shcl/test/iterator)
  (:import-from :shcl/test/command)
  (:import-from :shcl/test/fd-table)
  (:import-from :shcl/test/foundation
                #:run-test-set #:all-tests #:package-test-set #:symbol-test)
  (:import-from :shcl/core/command)
  (:import-from :shcl/core/shell-environment #:with-subshell)
  (:import-from :prove)
  (:import-from :fset)
  (:export #:run-all-tests))
(in-package :shcl/test/main)

(shcl/core/command:define-builtin -shcl-run-tests (&option package)
  "Run unit tests."
  (with-subshell
    (let ((prove:*enable-colors* nil)
          (prove:*test-result-output* *standard-output*)
          (test-set (fset:empty-set)))
      (cond
        ((zerop (length package))
         (setf test-set (all-tests)))

        (t
         (loop :for package :across package :do
            (fset:unionf test-set (package-test-set package)))))
      (if (run-test-set test-set)
          0
          1))))


(defpackage #:hello-world
  (:use #:cl)
  (:export #:hello))
(in-package #:hello-world)

(defun hello NIL)

Replace `NIL` with `()` in stub function definition.

(defpackage #:hello-world
  (:use #:cl)
  (:export #:hello))
(in-package #:hello-world)

(defun hello ())


;;;; lazy-susan.asd

(asdf:defsystem #:lazy-susan
  :serial t
  :description "A readtable which provides more flexible symbol reading"
  :author "Matt Niemeir <matt.niemeir@gmail.com>"
  :license "BSD 2-clause"
  :depends-on (#:mcn-utils)
  :components ((:file "package")
               (:file "utils")
               (:file "syntax")
               (:file "token-reader")
               (:file "lazy-susan")))

(asdf:defsystem #:lazy-susan-test
  :serial t
  :depends-on (:lazy-susan)
  :components ((:file tests)))

(defmethod asdf:perform ((o asdf:test-op)
                         (c (eql (asdf:find-system :lazy-susan))))
  (asdf:operate 'load-op :lazy-susan-test)
  (funcall (intern (symbol-name :run-tests)
                   (find-package :lazy-susan-test))))

Remove stray MCN-UTILS dependency (sorry!)

;;;; lazy-susan.asd

(asdf:defsystem #:lazy-susan
  :serial t
  :description "A readtable which provides more flexible symbol reading"
  :author "Matt Niemeir <matt.niemeir@gmail.com>"
  :license "BSD 2-clause"
  :components ((:file "package")
               (:file "utils")
               (:file "syntax")
               (:file "token-reader")
               (:file "lazy-susan")))

(asdf:defsystem #:lazy-susan-test
  :serial t
  :depends-on (:lazy-susan)
  :components ((:file tests)))

(defmethod asdf:perform ((o asdf:test-op)
                         (c (eql (asdf:find-system :lazy-susan))))
  (asdf:operate 'load-op :lazy-susan-test)
  (funcall (intern (symbol-name :run-tests)
                   (find-package :lazy-susan-test))))


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

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

(defun class-of (object)
  (heap-instance-class object))

Handle any CL object without error.

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

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

(defun class-of (object)
  (if (heap-instance-p object)
      (heap-instance-class object)
      (cdr (assoc t *classes*))))


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

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

Use option :SERIAL T to simplify system definition.

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

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


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

(defun fill-boot (boot)
  (fill1 boot))

(defmethod initialize-instance :after ((boot boot) &key &allow-other-keys)
  (fill-boot boot))

Call function for customizing compilation environment C1.

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

(defun fill-boot (boot)
  (customize-c1 boot)
  (fill1 boot))

(defmethod initialize-instance :after ((boot boot) &key &allow-other-keys)
  (fill-boot boot))


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

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

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

Define system in package ASDF-USER.

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

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

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

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


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

(defun fill-environment (environment)
  (import-from-host-common-lisp environment)
  (import-from-sicl-global-environment environment)
  (import-loop-support environment)
  (define-defmacro environment)
  (define-default-setf-expander environment))

Call function that defines backquote macros.

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

(defun fill-environment (environment)
  (import-from-host-common-lisp environment)
  (import-from-sicl-global-environment environment)
  (import-loop-support environment)
  (define-backquote-macros environment)
  (define-defmacro environment)
  (define-default-setf-expander environment))


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

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

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

Load the definition of CL:FDEFINITION.

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

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

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


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

(defmacro incf (&environment env place &optional (delta-form 1))
  (multiple-value-bind (vars vals store-vars writer-form reader-form)
      (get-setf-expansion place env)
    (if (null vars)
	`(let (,(first store-vars) (+ ,reader-form ,delta-form))
	   ,writer-form)
	`(let* ((,(first vars) ,(first vals))
		(,(first store-vars) (+ ,reader-form ,delta-form)))
	   ,writer-form))))

(defmacro decf (&environment env place &optional (delta-form 1))
  (multiple-value-bind (vars vals store-vars writer-form reader-form)
      (get-setf-expansion place env)
    (if (null vars)
	`(let (,(first store-vars) (- ,reader-form ,delta-form))
	   ,writer-form)
	`(let* ((,(first vars) ,(first vals))
		(,(first store-vars) (- ,reader-form ,delta-form)))
	   ,writer-form))))

Create list of bindings for the case of a variable.

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

(defmacro incf (&environment env place &optional (delta-form 1))
  (multiple-value-bind (vars vals store-vars writer-form reader-form)
      (get-setf-expansion place env)
    (if (null vars)
	`(let ((,(first store-vars) (+ ,reader-form ,delta-form)))
	   ,writer-form)
	`(let* ((,(first vars) ,(first vals))
		(,(first store-vars) (+ ,reader-form ,delta-form)))
	   ,writer-form))))

(defmacro decf (&environment env place &optional (delta-form 1))
  (multiple-value-bind (vars vals store-vars writer-form reader-form)
      (get-setf-expansion place env)
    (if (null vars)
	`(let ((,(first store-vars) (- ,reader-form ,delta-form)))
	   ,writer-form)
	`(let* ((,(first vars) ,(first vals))
		(,(first store-vars) (- ,reader-form ,delta-form)))
	   ,writer-form))))


;;;; lisphys.asd

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

Add twist and vector tests to package.

;;;; lisphys.asd

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


(asdf:defsystem #:hexstream-project-template_tests

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

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

  :description "hexstream-project-template unit tests."

  :depends-on ("hexstream-project-template"
               "parachute")

  :serial cl:t
  :components ((:file "tests"))

  :perform (asdf:test-op (op c) (uiop:symbol-call '#:parachute '#:test '#:hexstream-project-template_tests)))

Update old email address. (WTF?!?)

(asdf:defsystem #:hexstream-project-template_tests

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

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

  :description "hexstream-project-template unit tests."

  :depends-on ("hexstream-project-template"
               "parachute")

  :serial cl:t
  :components ((:file "tests"))

  :perform (asdf:test-op (op c) (uiop:symbol-call '#:parachute '#:test '#:hexstream-project-template_tests)))


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

Define generic functions SPLAY-STEP and SPLAY.

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

(defgeneric splay-step (node))

(defgeneric splay (node))


;;; recent-buffers.lisp --- Manage list of recent buffers.

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

@export
(defmethod buffer-match-predicate ((buffer buffer))
  (lambda (other-buffer)
    (when other-buffer
      (and (string= (url buffer) (url other-buffer))
           (string= (title buffer) (title other-buffer))))))

(defun recent-buffer-completion-fn ()
  (let ((buffers (ring:recent-list (recent-buffers *interface*))))
    (lambda (input)
      (fuzzy-match input buffers))))

(define-command reopen-buffer ()
  "Reopen a deleted buffer via minibuffer input."
  (with-result (buffer (read-from-minibuffer
                        (make-instance 'minibuffer
                                       :input-prompt "Reopen buffer:"
                                       :completion-function (recent-buffer-completion-fn))))
    (ring:delete-match (recent-buffers *interface*) (buffer-match-predicate buffer))
    (reload-current-buffer (rpc-buffer-make :dead-buffer buffer))))

(define-command undo-buffer-deletion ()
  "Open a new buffer with the URL of the most recently deleted buffer."
  (if (plusp (ring:item-count (recent-buffers *interface*)))
      (reload-current-buffer (rpc-buffer-make
                              :dead-buffer (ring:pop-most-recent (recent-buffers *interface*))))
      (echo "There are no recently-deleted buffers.")))

Add multi-selection support to reopen-buffer.

;;; recent-buffers.lisp --- Manage list of recent buffers.

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

@export
(defmethod buffer-match-predicate ((buffer buffer))
  (lambda (other-buffer)
    (when other-buffer
      (and (string= (url buffer) (url other-buffer))
           (string= (title buffer) (title other-buffer))))))

(defun recent-buffer-completion-fn ()
  (let ((buffers (ring:recent-list (recent-buffers *interface*))))
    (lambda (input)
      (fuzzy-match input buffers))))

(define-command reopen-buffer ()
  "Reopen a deleted buffer via minibuffer input."
  (with-result (buffers (read-from-minibuffer
                         (make-instance 'minibuffer
                                        :input-prompt "Reopen buffer:"
                                        :multi-selection-p t
                                        :completion-function (recent-buffer-completion-fn))))
    (dolist (buffer buffers)
      (ring:delete-match (recent-buffers *interface*) (buffer-match-predicate buffer))
      (reload-current-buffer (rpc-buffer-make :dead-buffer buffer)))))

(define-command undo-buffer-deletion ()
  "Open a new buffer with the URL of the most recently deleted buffer."
  (if (plusp (ring:item-count (recent-buffers *interface*)))
      (reload-current-buffer (rpc-buffer-make
                              :dead-buffer (ring:pop-most-recent (recent-buffers *interface*))))
      (echo "There are no recently-deleted buffers.")))


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

(defgeneric splay-step-with-parent (node parent))

(defgeneric splay-step (node))

(defgeneric splay (node))

Define default method on function SPLAY-STEP.

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

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Generic function SPLAY-STEP-WITH-PARENT.
;;;
;;; This function should not be called directly by client code.  It is
;;; called by the function SPLAY-STEP with the NODE to splay and the
;;; PARENT of NODE, only when PARENT is not NIL.
;;;
;;; Client code can define methods on this generic function.  Such
;;; methods may be specialized to strict subclasses of the class
;;; NODE-WITH-PARENT.
;;;
;;; This function returns NODE as a single value.

(defgeneric splay-step-with-parent (node parent))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Generic function SPLAY-STEP.
;;;
;;; This function takes a NODE and applies a single splay step to that
;;; node.

(defgeneric splay-step (node))

(defmethod splay-step ((node clump-binary-tree:node-with-parent))
  (let ((parent (clump-binary-tree:parent node)))
    (unless (null parent)
      (splay-step-with-parent node parent)))
  node)

(defgeneric splay (node))


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

(defun eql (x y)
  (| x (setq x nil))
  (| y (setq y nil))
  (| (%%%eq x y)
     (? (| (number? x) (number? y))
        (?
          (& (integer? x) (integer? y)) (integer== x y)
          (& (character? x) (character? y)) (character== x y))
        (== x y))))

Allow more than two arguments to EQL.

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

(defun %eql (x y)
  (| x (setq x nil))
  (| y (setq y nil))
  (| (%%%eq x y)
     (? (| (number? x) (number? y))
        (?
          (& (integer? x) (integer? y)) (integer== x y)
          (& (character? x) (character? y)) (character== x y))
        (== x y))))

(defun eql (&rest x)
  (adolist (.x t)
    (| (%eql x. !)
       (return))))


;;;; -*- lisp -*-

(in-package :it.bese.arnesi)

(def-suite :it.bese.arnesi.numbers :in :it.bese.arnesi)

(in-suite :it.bese.arnesi.numbers)

(test mulf
  (let ((a 0))
    (is (= 0 (mulf a 10)))
    (is (= 0 a)))

  (let ((a 1))
    (is (= 4 (mulf a 4)))
    (is (= 1 (mulf a (/ 4))))
    (is (= 1 a))))

(test minf
  (let ((a 10))
    (is (= 5 (minf a 5)))
    (is (= 5 a)))

  (let ((a 0))
    (is (= 0 (minf a 10)))
    (is (= 0 a))))

(test parse-float
  (is (= 0 (parse-float "0")))
  (is (= -1 (parse-float "-1")))
  (is (= 1 (parse-float "1")))

  (dolist (type '(short-float single-float double-float long-float))
    (dotimes (i 1000)
      (let* ((*print-radix* 10)
             (number (random  (1+ (coerce i type))))
             (string (princ-to-string number))
             (value (parse-float string :type type)))
        (unless (= number value)
          (fail "~S parse-float'd to ~S (not ~S)." string value number))))))

Use FiveAM's new random testing for the parse-float test

;;;; -*- lisp -*-

(in-package :it.bese.arnesi)

(def-suite :it.bese.arnesi.numbers :in :it.bese.arnesi)

(in-suite :it.bese.arnesi.numbers)

(test mulf
  (let ((a 0))
    (is (= 0 (mulf a 10)))
    (is (= 0 a)))

  (let ((a 1))
    (is (= 4 (mulf a 4)))
    (is (= 1 (mulf a (/ 4))))
    (is (= 1 a))))

(test minf
  (let ((a 10))
    (is (= 5 (minf a 5)))
    (is (= 5 a)))

  (let ((a 0))
    (is (= 0 (minf a 10)))
    (is (= 0 a))))

(test parse-float
  (is (= 0 (parse-float "0")))
  (is (= -1 (parse-float "-1")))
  (is (= 1 (parse-float "1")))

  (dolist (type '(short-float single-float double-float long-float))
    (for-all ((float (gen-float :type type :bound 1000)))
      (let* ((*print-base* 10)
             (*print-radix* nil))
        (is (= float (parse-float (princ-to-string float) :type type)))))))


(asdf:defsystem #:closer-mop
  :name "Closer to MOP"
  :description "Closer to MOP is a compatibility layer that rectifies many of the absent or incorrect CLOS MOP features across a broad range of Common Lisp implementations."
  :author "Pascal Costanza"
  :version "1.0.0"
  :licence "MIT-style license"
  :components
  ((:file "closer-mop-packages")
   (:file "closer-mop-shared" :depends-on ("closer-mop-packages"))
   (:file
    #+abcl	"closer-abcl"
    #+allegro   "closer-allegro"
    #+clisp     "closer-clisp"
    #+clozure   "closer-clozure"
    #+cmu       "closer-cmu"
    #+ecl       "closer-ecl"
    #+lispworks "closer-lispworks"
    #+mcl       "closer-mcl"
    #+sbcl      "closer-sbcl"
    #+scl       "closer-scl"
    :depends-on ("closer-mop-packages" "closer-mop-shared"))))

Fix .asd when loading on an unsupported lisp (e.g. clasp).

(asdf:defsystem #:closer-mop
  :name "Closer to MOP"
  :description "Closer to MOP is a compatibility layer that rectifies many of the absent or incorrect CLOS MOP features across a broad range of Common Lisp implementations."
  :author "Pascal Costanza"
  :version "1.0.0"
  :licence "MIT-style license"
  :serial t
  :components
  ((:file "closer-mop-packages")
   (:file "closer-mop-shared")
   (:file "closer-abcl"      :if-feature :abcl)
   (:file "closer-allegro"   :if-feature :allegro)
   (:file "closer-clisp"     :if-feature :clisp)
   (:file "closer-clozure"   :if-feature :clozure)
   (:file "closer-cmu"       :if-feature :cmu)
   (:file "closer-ecl"       :if-feature :ecl)
   (:file "closer-lispworks" :if-feature :lispworks)
   (:file "closer-mcl"       :if-feature :mcl)
   (:file "closer-sbcl"      :if-feature :sbcl)
   (:file "closer-scl"       :if-feature :scl)))