;;;; grok-arch-hexagonal.asd

;;; The MIT License (MIT)
;;;
;;; Copyright (c) 2016 Michael J. Forster
;;;
;;; Permission is hereby granted, free of charge, to any person obtaining a copy
;;; of this software and associated documentation files (the "Software"), to deal
;;; in the Software without restriction, including without limitation the rights
;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
;;; copies of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be included in all
;;; copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;;; SOFTWARE.

(asdf:defsystem #:grok-arch-hexagonal
  :description "Grokking Alistair Cockburn's Hexagonal Architecture"
  :author "Michael J. Forster <mike@forsterfamily.ca>"
  :license "MIT"
  :depends-on (#:alexandria
               #:lisp-unit)
  :serial t
  :components ((:file "package")
               (:file "grok-arch-hexagonal")))

Add system dependency on wu-decimal

;;;; grok-arch-hexagonal.asd

;;; The MIT License (MIT)
;;;
;;; Copyright (c) 2016 Michael J. Forster
;;;
;;; Permission is hereby granted, free of charge, to any person obtaining a copy
;;; of this software and associated documentation files (the "Software"), to deal
;;; in the Software without restriction, including without limitation the rights
;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
;;; copies of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be included in all
;;; copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;;; SOFTWARE.

(asdf:defsystem #:grok-arch-hexagonal
  :description "Grokking Alistair Cockburn's Hexagonal Architecture"
  :author "Michael J. Forster <mike@forsterfamily.ca>"
  :license "MIT"
  :depends-on (#:alexandria
               #:wu-decimal
               #:lisp-unit)
  :serial t
  :components ((:file "package")
               (:file "grok-arch-hexagonal")))


(import extra/term (colored))

(defun print-error! (msg)
  "Print an error messaage, MSG."
  (unless (string? msg) (set! msg (pretty msg)))
  (with (lines (string/split msg "\n" 1))
    (print! (colored 31 (.. "[ERROR] " (car lines))))
    (when (cadr lines) (print! (cadr lines)))))

(defun print-warning! (msg)
  "Print a warning message, MSG."
  (with (lines (string/split msg "\n" 1))
    (print! (colored 33 (.. "[WARN] " (car lines))))
    (when (cadr lines) (print! (cadr lines)))))

(defun print-verbose! (verbosity msg)
  "Print a verbose message, MSG if VERBOSITy is greater than 0."
  (when (> verbosity 0)
    (print! (.. "[VERBOSE] " msg))))

(defun print-debug! (verbosity msg)
  "Print a debug message, MSG if VERBOSITY is greater than 1."
  (when (> verbosity 1)
    (print! (.. "[DEBUG] " msg))))

(defun print-time! (maximum name time level)
  "Print the TIME NAME took to execute, if LEVEL is <= MAXIMIM."
  (when (<= level maximum)
    (print! (.. "[TIME] " name " took " time))))

(defun print-explain! (explain lines)
  "Put all LINES when explaining is enabled"
  (when explain
    (for-each line (string/split lines "\n")
      (print! (.. "  " line)))))

Change to $ in a couple of places

(import extra/term (colored))

(defun print-error! (msg)
  "Print an error messaage, MSG."
  (unless (string? msg) (set! msg (pretty msg)))
  (with (lines (string/split msg "\n" 1))
    (print! (colored 31 (.. "[ERROR] " (car lines))))
    (when (cadr lines) (print! (cadr lines)))))

(defun print-warning! (msg)
  "Print a warning message, MSG."
  (with (lines (string/split msg "\n" 1))
    (print! (colored 33 (.. "[WARN] " (car lines))))
    (when (cadr lines) (print! (cadr lines)))))

(defun print-verbose! (verbosity msg)
  "Print a verbose message, MSG if VERBOSITy is greater than 0."
  (when (> verbosity 0)
    (print! $"[VERBOSE] ~{msg}")))

(defun print-debug! (verbosity msg)
  "Print a debug message, MSG if VERBOSITY is greater than 1."
  (when (> verbosity 1)
    (print! $"[DEBUG] ~{msg}")))

(defun print-time! (maximum name time level)
  "Print the TIME NAME took to execute, if LEVEL is <= MAXIMIM."
  (when (<= level maximum)
    (print! $"[TIME] ~{name} took ~{time}")))

(defun print-explain! (explain lines)
  "Put all LINES when explaining is enabled"
  (when explain
    (for-each line (string/split lines "\n")
      (print! (.. "  " line)))))


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

;;;; The direct extrinsic compiler is a compiler that runs on some
;;;; host environment perhaps other than SICL.  It supplies a function
;;;; that compiles a single lambda expression in the null lexical
;;;; environment, and it produces a small graph of objects that can be
;;;; turned into target binary code in a straightforward way.

(defsystem :sicl-direct-extrinsic-compiler
  :depends-on (:sicl-extrinsic-environment
	       :cleavir-generate-ast
	       :cleavir-ast-to-hir
	       :sicl-hir-to-mir
	       :cleavir-hir-transformations
	       :cleavir-liveness
	       :cleavir-register-allocation)
  :serial t
  :components
  ((:file "packages")
   (:file "classes")
   (:file "introduce-immediates")
   (:file "process-constants")
   (:file "compile")))

Remove reference to non-existing component in system definition.

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

;;;; The direct extrinsic compiler is a compiler that runs on some
;;;; host environment perhaps other than SICL.  It supplies a function
;;;; that compiles a single lambda expression in the null lexical
;;;; environment, and it produces a small graph of objects that can be
;;;; turned into target binary code in a straightforward way.

(defsystem :sicl-direct-extrinsic-compiler
  :depends-on (:sicl-extrinsic-environment
	       :cleavir-generate-ast
	       :cleavir-ast-to-hir
	       :sicl-hir-to-mir
	       :cleavir-hir-transformations
	       :cleavir-liveness
	       :cleavir-register-allocation)
  :serial t
  :components
  ((:file "packages")
   (:file "classes")
   (:file "process-constants")
   (:file "compile")))


(in-package #:sys.int)

(define-condition unknown-coercion ()
  ((object :initarg :object
           :reader unknown-coercion-object)
   (type :initarg :type
         :reader unknown-coercion-type))
  (:report (lambda (condition stream)
             (format stream "Don't know how to coerce ~S to type ~S."
                     (unknown-coercion-object condition)
                     (unknown-coercion-type condition)))))

(defun coerce (object result-type)
  (when (or (eql result-type 't)
            (typep object result-type))
    (return-from coerce object))
  (cond ((subtypep result-type 'list)
         (map 'list 'identity object))
        ((subtypep result-type 'vector)
         (check-type object sequence)
         (let ((element-type (parse-array-type (typeexpand result-type))))
           (make-array (length object)
                       :element-type element-type
                       :initial-contents object)))
        (t (error 'unknown-coercion :object object :type result-type))))

Support coercing stuff to FLOAT.

(in-package #:sys.int)

(define-condition unknown-coercion ()
  ((object :initarg :object
           :reader unknown-coercion-object)
   (type :initarg :type
         :reader unknown-coercion-type))
  (:report (lambda (condition stream)
             (format stream "Don't know how to coerce ~S to type ~S."
                     (unknown-coercion-object condition)
                     (unknown-coercion-type condition)))))

(defun coerce (object result-type)
  (when (or (eql result-type 't)
            (typep object result-type))
    (return-from coerce object))
  (cond ((subtypep result-type 'list)
         (map 'list 'identity object))
        ((subtypep result-type 'vector)
         (check-type object sequence)
         (let ((element-type (parse-array-type (typeexpand result-type))))
           (make-array (length object)
                       :element-type element-type
                       :initial-contents object)))
        ((subtypep result-type 'float)
         (float object))
        (t (error 'unknown-coercion :object object :type result-type))))


;;;; -*- 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 "Edward Marco Baringer <mb@bese.it>"
  :licence "BSD"
  :description "js - javascript compiler"

  :perform (load-op :after (op araneida)
                    (pushnew :parenscript cl:*features*))
  :components ((:static-file "parenscript.asd")
               (:module :src
                :components ((:file "package")
                             (:file "utils" :depends-on ("package"))
                             (:file "defgenerics" :depends-on ("package"))
                             (:file "js" :depends-on ("package" "utils" "defgenerics"))
                             (:file "js-html" :depends-on ("package" "js" "utils"))
                             (:file "css" :depends-on ("package" "utils"))))))

(defsystem :parenscript.test
  :depends-on (:parenscript :fiveam :cl-ppcre)
  :components ((:module :t
                :components ((:file "test-package")
                             (:file "test" :depends-on ("test-package"))
                             (:file "ref2test" :depends-on ("test"))
                             (:file "reference-tests" :depends-on ("test"))))))

Use an explicit asdf:perform :after method instead of :perform (load-op :after ...)

;;;; -*- 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 "Edward Marco Baringer <mb@bese.it>"
  :licence "BSD"
  :description "js - javascript compiler"
  :components ((:static-file "parenscript.asd")
               (:module :src
                :components ((:file "package")
                             (:file "utils" :depends-on ("package"))
                             (:file "defgenerics" :depends-on ("package"))
                             (:file "js" :depends-on ("package" "utils" "defgenerics"))
                             (:file "js-html" :depends-on ("package" "js" "utils"))
                             (:file "css" :depends-on ("package" "utils"))
                             (:file "compile-js" :depends-on ("package" "js"))))))

(defmethod asdf:perform :after ((op asdf:load-op) (system (eql (asdf:find-system :parenscript))))
  (pushnew :parenscript cl:*features*))

(defsystem :parenscript.test
  :depends-on (:parenscript :fiveam :cl-ppcre)
  :components ((:module :t
                :components ((:file "test-package")
                             (:file "test" :depends-on ("test-package"))
                             (:file "ref2test" :depends-on ("test"))
                             (:file "reference-tests" :depends-on ("test"))))))


(cl:defpackage #:macro-level_tests
  (:use #:cl #:parachute)
  (:import-from #:macro-level #:macro-level))

(cl:in-package #:macro-level_tests)

(define-test "main"
  (is equal
      (let ((alist nil))
        (macro-level `(progn ,@(mapcar (lambda (var value)
                                         (let ((var (intern (format nil "*~A*" var) '#:macro-level_tests)))
                                           `(push '(,var . ,value) alist)))
                                       '(a b c)
                                       '(1 2 3))))
        (nreverse alist))
      '((*a* . 1) (*b* . 2) (*c* . 3))))

Use proper argument order for IS.

(cl:defpackage #:macro-level_tests
  (:use #:cl #:parachute)
  (:import-from #:macro-level #:macro-level))

(cl:in-package #:macro-level_tests)

(define-test "main"
  (is equal '((*a* . 1) (*b* . 2) (*c* . 3))
      (let ((alist nil))
        (macro-level `(progn ,@(mapcar (lambda (var value)
                                         (let ((var (intern (format nil "*~A*" var) '#:macro-level_tests)))
                                           `(push '(,var . ,value) alist)))
                                       '(a b c)
                                       '(1 2 3))))
        (nreverse alist))))


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

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

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

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

Load a file containing the definition of the generic function CLASS-DIRECT-SUPERCLASSES.

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

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

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

(defun fill-environment (environment)
  (define-ensure-generic-function environment)
  (sicl-genv:fmakunbound 'sicl-clos:class-direct-superclasses environment)
  (ld "../../CLOS/class-direct-superclasses-defgeneric.lisp" environment))


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

(defmacro with-default-stream (nstr str &rest body)
"Set 'str' to *standard-output* if 'str' is T or create string-stream
if 'str' is NIL, evaluate 'body' and return the stream-string if 'str'
is NIL."
  (with-gensym g
    `(with (,g ,str
			,nstr nil)
	   (setq ,nstr (if
        		     (eq ,g t)		*standard-output*
        		     (eq ,g nil)	(make-string-stream)
				     ,g))
       ,@body
       (unless ,g
         (get-stream-string ,nstr)))))

Return body result if string is not a string-stream.

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

(defmacro with-default-stream (nstr str &rest body)
"Set 'str' to *standard-output* if 'str' is T or create string-stream
if 'str' is NIL, evaluate 'body' and return the stream-string if 'str'
is NIL."
  (with-gensym (g body-result)
    `(with (,g ,str
			,nstr nil)
	   (setq ,nstr (if
        		     (eq ,g t)		*standard-output*
        		     (eq ,g nil)	(make-string-stream)
				     ,g))
       (let ,body-result (progn
						   ,@body)
         (if ,g
		   ,body-result
           (get-stream-string ,nstr))))))


(fn warn-unused-functions ()
  (!= (defined-functions)
    (@ [hremove ! _]
       (+ (hashkeys (used-functions))
          (hashkeys (expander-macros (transpiler-macro-expander)))
          (hashkeys (expander-macros (codegen-expander)))
          *macros*))
    (@ [!= (symbol-name _)
         (| (tail? ! "_TREEXP")
            (head? ! "~")
            (warn "Unused function ~A." _))]
       (hashkeys !))))

Print one list of names of unused functions.

(fn warn-unused-functions ()
  (!= (defined-functions)
    (@ [hremove ! _]
       (+ (hashkeys (used-functions))
          (hashkeys (expander-macros (transpiler-macro-expander)))
          (hashkeys (expander-macros (codegen-expander)))
          *macros*))
    (!? (mapcan [!= (symbol-name _)
                  (& (not (tail? ! "_TREEXP")
                          (head? ! "~"))
                     (list !))]
           (hashkeys !))
      (warn "Unused functions: ~A." (symbol-names-string !)))))


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

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

Define system in package ASDF-USER.

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

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


(defpackage :info.isoraqathedh.acronyms.asdf
  (:use #:cl #:asdf))
(in-package :info.isoraqathedh.acronyms.asdf)

(defsystem acronyms
  :name "Acronym Expander"
  :version "1.0.0"
  :licence "MIT"
  :description "A program that expands an acronym based on grammatical rules."
  :serial t
  :components ((:file "acronyms")))

Add author and maintainer field.

(defpackage :info.isoraqathedh.acronyms.asdf
  (:use #:cl #:asdf))
(in-package :info.isoraqathedh.acronyms.asdf)

(defsystem acronyms
  :name "Acronym Expander"
  :author "Isoraķatheð Zorethan <isoraqathedh.zorethan@gmail.com>"
  :maintainer "Isoraķatheð Zorethan <isoraqathedh.zorethan@gmail.com>"
  :version "1.0.0"
  :licence "MIT"
  :description "A program that expands an acronym based on grammatical rules."
  :serial t
  :components ((:file "acronyms")))


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

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Mixin classes for instructions according to successor count.

;;; Mixin class for instructions with no successors.
(defclass no-successors-mixin () ())

;;; Mixin class for instructions with a single successor.
(defclass one-successor-mixin () ())

;;; Mixin class for instructions with tow successors.
(defclass two-successors-mixin () ())

Define mixin class for instructions with side effects.

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

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Mixin classes for instructions according to successor count.

;;; Mixin class for instructions with no successors.
(defclass no-successors-mixin () ())

;;; Mixin class for instructions with a single successor.
(defclass one-successor-mixin () ())

;;; Mixin class for instructions with tow successors.
(defclass two-successors-mixin () ())

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Other mixin classes.

;;; Mixin class for instructions that have side effects so that they
;;; should not be removed.
(defclass side-effect-mixin () ())


(in-package :hunchentoot)

(format t "Am I alive??")
(format t "Dispatch ~A~%" *dispatch-table*)

(hunchentoot:define-easy-handler (say-yo :uri "/yo") (name)
  (setf (hunchentoot:content-type*) "text/plain")
  (progn
  	(format nil "Hey~@[ ~A~]!~%" name)
  	(format nil "~A ~A" (lisp-implementation-type) (lisp-implementation-version))))

;(publish :path "/"
;	 :function #'(lambda (req ent)
;		       (with-http-response (req ent)
;			 (with-http-body (req ent)
;			   (html
;			    (:h1 "Hello World")
;			    (:princ "Congratulations, you are running Lisp on Heroku!!!")
;			    :p
;			    ((:img :src "lisp-glossy.jpg"))
;			    )))))
;
;(publish-directory
; :prefix "/"
; :destination "./public/"
; )

Tweak greeting and impl info.

(in-package :hunchentoot)

(format t "Am I alive??")
(format t "Dispatch ~A~%" *dispatch-table*)

(hunchentoot:define-easy-handler (say-yo :uri "/yo") (name)
  (setf (hunchentoot:content-type*) "text/plain")
  (format nil "Hey~@[ ~A~]! ~A ~A" name (lisp-implementation-type) (lisp-implementation-version)))

;(publish :path "/"
;	 :function #'(lambda (req ent)
;		       (with-http-response (req ent)
;			 (with-http-body (req ent)
;			   (html
;			    (:h1 "Hello World")
;			    (:princ "Congratulations, you are running Lisp on Heroku!!!")
;			    :p
;			    ((:img :src "lisp-glossy.jpg"))
;			    )))))
;
;(publish-directory
; :prefix "/"
; :destination "./public/"
; )


;;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-

;;;;     Copyright (C) 2014  Varoun. P

;;;;     This program is free software: you can redistribute it and/or modify
;;;;     it under the terms of the GNU Affero General Public License as
;;;;     published by the Free Software Foundation, either version 3 of the
;;;;     License, or (at your option) any later version.

;;;;     This program is distributed in the hope that it will be useful,
;;;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;;     GNU Affero General Public License for more details.

;;;;     You should have received a copy of the GNU Affero General Public License
;;;;     along with this program.  If not, see <http://www.gnu.org/licenses/>.

(in-package "STREAMLETS-IMPL")

;;;; The foundation class for all tuples.

(defclass tuple ()
  ((metrics
    :initarg :tuple-metrics
    :initform nil
    :accessor tuple-metrics
    :documentation "A list of metrics relevant to tuple processing.")))

Add documentation to the tuple class.

;;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-

;;;;     Copyright (C) 2014  Varoun. P

;;;;     This program is free software: you can redistribute it and/or modify
;;;;     it under the terms of the GNU Affero General Public License as
;;;;     published by the Free Software Foundation, either version 3 of the
;;;;     License, or (at your option) any later version.

;;;;     This program is distributed in the hope that it will be useful,
;;;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;;     GNU Affero General Public License for more details.

;;;;     You should have received a copy of the GNU Affero General Public License
;;;;     along with this program.  If not, see <http://www.gnu.org/licenses/>.

(in-package "STREAMLETS-IMPL")

;;;; Streamlets Tuples

(defclass tuple ()
  ((metrics
    :initarg :tuple-metrics
    :initform nil
    :accessor tuple-metrics
    :documentation "A list of metrics relevant to tuple processing."))
  (:documentation "The foundation for all tuples."))


;   Copyright 2017 James Fleming <james@electronic-quill.net>
;
;   Licensed under the GNU General Public License
;   - for details, see LICENSE.txt in the top-level directory

;;;; Logging infrastructure
;;; We only need something extremely simple

(in-package #:neo4cl)

(defvar *loglevels*
  '(:crit 4
    :critical 4
    :error 3
    :warn 2
    :warning 2
    :info 1
    :debug 0))

;; Set the threshold logging level
(defparameter *loglevel* :debug)

(defparameter *log-stream*
  (make-synonym-stream 'cl:*standard-output*))

(defun make-timestamp ()
  (multiple-value-bind (sec minute hour date month year)
    (get-decoded-time)
    (format nil "[~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d]"
    year month date hour minute sec)))

(defun log-message (severity message)
  (declare (type keyword severity))
  (when (>= (getf *loglevels* severity)
            (getf *loglevels* *loglevel*))
    (format *log-stream* "~%~A ~A ~A"
            (make-timestamp)
            severity
            message)))

Change default loglevel from :debug to :warn

;   Copyright 2017 James Fleming <james@electronic-quill.net>
;
;   Licensed under the GNU General Public License
;   - for details, see LICENSE.txt in the top-level directory

;;;; Logging infrastructure
;;; We only need something extremely simple

(in-package #:neo4cl)

(defvar *loglevels*
  '(:crit 4
    :critical 4
    :error 3
    :warn 2
    :warning 2
    :info 1
    :debug 0))

;; Set the threshold logging level
(defparameter *loglevel* :warn)

(defparameter *log-stream*
  (make-synonym-stream 'cl:*standard-output*))

(defun make-timestamp ()
  (multiple-value-bind (sec minute hour date month year)
    (get-decoded-time)
    (format nil "[~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d]"
    year month date hour minute sec)))

(defun log-message (severity message)
  (declare (type keyword severity))
  (when (>= (getf *loglevels* severity)
            (getf *loglevels* *loglevel*))
    (format *log-stream* "~%~A ~A ~A"
            (make-timestamp)
            severity
            message)))


(bodge-util:define-package :cl-bodge.ui
  (:nicknames :ge.ui)
  (:use :cl :cl-bodge.engine :bodge-util :cl-bodge.graphics
        :cl-bodge.canvas :cl-bodge.resources :claw)
  (:reexport-from :bodge-ui
                  #:defwindow
                  #:on-window-close

                  #:horizontal-layout
                  #:vertical-layout

                  #:label
                  #:radio-group
                  #:radio
                  #:check-box
                  #:button

                  #:custom-widget
                  #:custom-widget-hovered-p
                  #:custom-widget-pressed-p
                  #:render-custom-widget)
  (:export #:make-ui
           #:compose-ui
           #:with-ui-access
           #:add-window
           #:remove-window
           #:remove-all-windows

           #:update-ui-size
           #:update-ui-pixel-ratio

           #:make-host-input-source
           #:attach-host-input-source
           #:detach-host-input-source))

Update for latest bodge-ui changes

(bodge-util:define-package :cl-bodge.ui
  (:nicknames :ge.ui)
  (:use :cl :cl-bodge.engine :bodge-util :cl-bodge.graphics
        :cl-bodge.canvas :cl-bodge.resources :claw)
  (:reexport-from :bodge-ui
                  #:defpanel
                  #:on-window-close

                  #:horizontal-layout
                  #:vertical-layout

                  #:label
                  #:radio-group
                  #:radio
                  #:check-box
                  #:button

                  #:custom-widget
                  #:custom-widget-hovered-p
                  #:custom-widget-pressed-p
                  #:render-custom-widget)
  (:export #:make-ui
           #:compose-ui
           #:with-ui-access
           #:add-window
           #:remove-window
           #:remove-all-windows

           #:update-ui-size
           #:update-ui-pixel-ratio

           #:make-host-input-source
           #:attach-host-input-source
           #:detach-host-input-source))


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

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

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

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

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

Define new class SPEED-AST subclass of OPTIMIZE-AST.

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

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

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

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

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

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Class SPEED-AST.

(defclass speed-ast (optimize-ast)
  ())

(defun make-speed-ast (child-ast value-ast &key origin)
  (make-instance 'speed-ast
    :origin origin
    :child-ast child-ast
    :value-asts value-ast))


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

(asdf:defsystem :cleavir-mir
  :depends-on (:cleavir-ir)
  :serial t
  :components
  ((:file "general")
   (:file "graphviz-drawing")))

Define ASDF system in package ASDF-USER.

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

(defsystem :cleavir-mir
  :depends-on (:cleavir-ir)
  :serial t
  :components
  ((:file "general")
   (:file "graphviz-drawing")))


(in-package #:jumpotron)

(defclass redirecting-jump (jump)
  ((target :initarg :target
           :initform (error "A jump needs a target")
           :reader target
           :documentation "FORMAT-string that will consume the words in the
query to construct a url to redirect the user to.")))

(defmethod jump ((jump redirecting-jump) query-parts)
  (redirect *response*
            (apply #'format nil (target jump) query-parts)))

(defun define-redirect (trigger format-string &optional (exclude-trigger-p t))
  "Defines a new redirecting jump. If a request comes in where a word in the
query is EQUAL to PREFIX, the user will be redirected to the result of calling
FORMAT with FORMAT-STRING and the words in the query. If EXCLUDE-TRIGGER-P is
NIL those words will also still contain TRIGGER.

This is equivalent to, and actually does, the following:

    (add-jump trigger
                (make-instance 'redirecting-jump
                               :target format-string
                               :exclude-trigger-p exclude-trigger-p))"
  (add-jump trigger
            (make-instance 'redirecting-jump
                           :target format-string
                           :exclude-trigger-p exclude-trigger-p)))

Add some rough error handling to REDIRECTING-JUMP

(in-package #:jumpotron)

(defclass redirecting-jump (jump)
  ((target :initarg :target
           :initform (error "A jump needs a target")
           :reader target
           :documentation "FORMAT-string that will consume the words in the
query to construct a url to redirect the user to.")))

(defmethod jump ((jump redirecting-jump) query-parts)
  (handler-case
      (redirect *response*
                (apply #'format nil (target jump) query-parts))
    (serious-condition () "You have an error in your query.")))

(defun define-redirect (trigger format-string &optional (exclude-trigger-p t))
  "Defines a new redirecting jump. If a request comes in where a word in the
query is EQUAL to PREFIX, the user will be redirected to the result of calling
FORMAT with FORMAT-STRING and the words in the query. If EXCLUDE-TRIGGER-P is
NIL those words will also still contain TRIGGER.

This is equivalent to, and actually does, the following:

    (add-jump trigger
                (make-instance 'redirecting-jump
                               :target format-string
                               :exclude-trigger-p exclude-trigger-p))"
  (add-jump trigger
            (make-instance 'redirecting-jump
                           :target format-string
                           :exclude-trigger-p exclude-trigger-p)))


(in-package #:method-combination-utilities)

(defun method-combination-expander-function (method-combination)
  #+ccl (cdr (ccl::method-combination-expander method-combination))
  #-ccl (error "this function is not available on ~A"
               (lisp-implementation-type)))

(defun method-combination-options (method-combination)
  #+ccl (ccl::method-combination-options method-combination)
  #-ccl (error "this function is not available on ~A"
               (lisp-implementation-type)))

(defmacro method-combination-expand (form)
  "Given a function call form, this returns the method-combination form that
   would be generated in the process of satisfying that call. This is only
   expected to work for functions whose method-combination was created using
   the long form of DEFINE-METHOD-COMBINATION.

   NOTE: This is currently CCL-only."
  (let* ((gf (symbol-function (car form)))
         (mc (generic-function-method-combination gf)))
    `(funcall ,(method-combination-expander-function mc)
              ,gf
              (compute-applicable-methods ,gf (list ,@(cdr form)))
              (method-combination-options ,mc))))

Add CLISP support to METHOD-COMBINATION-EXPAND.

(in-package #:method-combination-utilities)

(defun method-combination-expander-function (method-combination)
  #+ccl (cdr (ccl::method-combination-expander method-combination))
  #+clisp (clos::method-combination-expander method-combination)
  #-(or ccl clisp)
  (error "this function is not available on ~A" (lisp-implementation-type)))

(defun method-combination-expansion-form (expander gf mc methods)
  #+ccl `(funcall ,expander ,gf ,methods ,(ccl::method-combination-options mc))
  #+clisp `(values (funcall ,expander
                            ,gf
                            ,mc
                            ,(clos::method-combination-options mc)
                            ,methods))
  #-(or ccl clisp)
  (error "this function is not available on ~A" (lisp-implementation-type)))

(defmacro method-combination-expand (form)
  "Given a function call form, this returns the method-combination form that
   would be generated in the process of satisfying that call. This is only
   expected to work for functions whose method-combination was created using
   the long form of DEFINE-METHOD-COMBINATION."
  (let* ((gf (symbol-function (car form)))
         (mc (generic-function-method-combination gf)))
    (method-combination-expansion-form (method-combination-expander-function mc)
                                       gf
                                       mc
                                       `(compute-applicable-methods
                                         ,gf
                                         (list ,@(cdr form))))))


;;;; slime-helper.lisp

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

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

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

Use QL-DIST:ENSURE-INSTALLED to make sure quicklisp's slime is installed regardless of whether another swank is visible.

;;;; slime-helper.lisp

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

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

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


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

Load a file containing the definition of the class REAL-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)))


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

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

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

(asdf:defsystem :sicl-conditionals
  :depends-on (:cleavir-code-utilities)
  :serial t
  :components
  ((:file "packages")
   (:file "support")
   (:file "conditions")
   (:file "condition-reporters-en")
   (:file "docstrings-en")
   (:file "macros")
   (:file "compiler-macros")))

Define ASDF system in package ASDF-USER.

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

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

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

(defsystem :sicl-conditionals
  :depends-on (:cleavir-code-utilities)
  :serial t
  :components
  ((:file "packages")
   (:file "support")
   (:file "conditions")
   (:file "condition-reporters-en")
   (:file "docstrings-en")
   (:file "macros")
   (:file "compiler-macros")))


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

(defgeneric specialize (instruction implementation processor os))

(defun hir-to-mir (initial-instruction implementation processor os)
  ;; Gather up all instructions in a table
  (let ((table (make-hash-table :test #'eq)))
    (labels ((traverse (instruction)
	       (unless (gethash instruction table)
		 (setf (gethash instruction table) t)
		 (loop for succ in (cleavir-ir:successors instruction)
		       do (traverse succ))
		 (when (typep instruction 'cleavir-ir:enclose-instruction)
		   (traverse (cleavir-ir:code instruction))))))
      (traverse initial-instruction))
    ;; Appply specialize to all instructions in the table.
    (loop for instruction being each hash-key of table
	  do (specialize instruction implementation processor os))))

(defmethod specialize :around (instruction implementation processor os)
  (declare (ignorable implementation processor os))
  (let ((replacement (call-next-method)))
    (unless (eq instruction replacement)
      (setf (cleavir-ir:predecessors replacement)
	    (cleavir-ir:predecessors instruction))
      (loop for predecessor in (cleavir-ir:predecessors instruction)
	    do (nsubstitute replacement instruction
			    (cleavir-ir:successors predecessor))))))

Make use of iterative mapping function.

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

(defgeneric specialize (instruction implementation processor os))

(defun hir-to-mir (initial-instruction implementation processor os)
  (let ((all-instructions '()))
    ;; Gather up all instructions in a list.
    (map-instructions
     (lambda (instruction)
       (push instruction all-instructions))
     initial-instruction)
    ;; Appply specialize to all instructions in the list.
    (loop for instruction in all-instructions
	  do (specialize instruction implementation processor os))))

(defmethod specialize :around (instruction implementation processor os)
  (declare (ignorable implementation processor os))
  (let ((replacement (call-next-method)))
    (unless (eq instruction replacement)
      (setf (cleavir-ir:predecessors replacement)
	    (cleavir-ir:predecessors instruction))
      (loop for predecessor in (cleavir-ir:predecessors instruction)
	    do (nsubstitute replacement instruction
			    (cleavir-ir:successors predecessor))))))


(defsystem "petalisp.ir"
  :author "Marco Heisig <marco.heisig@fau.de>"
  :license "AGPLv3"

  :depends-on
  ("alexandria"
   "ucons"
   "priority-queue"
   "petalisp.utilities"
   "petalisp.core")

  :serial t
  :components
  ((:file "packages")
   (:file "device")
   (:file "ir")
   (:file "ir-checker")
   (:file "ir-conversion")
   (:file "blueprint")
   (:file "kernel-interpreter")
   (:file "kernel-compiler")
   (:file "ir-backend")
   (:file "documentation")))

Introduce missing dependency on split-sequence.

(defsystem "petalisp.ir"
  :author "Marco Heisig <marco.heisig@fau.de>"
  :license "AGPLv3"

  :depends-on
  ("alexandria"
   "ucons"
   "priority-queue"
   "split-sequence"
   "petalisp.utilities"
   "petalisp.core")

  :serial t
  :components
  ((:file "packages")
   (:file "device")
   (:file "ir")
   (:file "ir-checker")
   (:file "ir-conversion")
   (:file "blueprint")
   (:file "kernel-interpreter")
   (:file "kernel-compiler")
   (:file "ir-backend")
   (:file "documentation")))


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

(defgeneric interpret-ast (ast static-env dynamic-env))

(defun interpret (ast)
  (let ((static-env (list (make-hash-table :test #'eq)))
	(dynamic-env '()))
    (interpret-ast ast static-env dynamic-env)))

Define method on INTERPRET-AST specialized to CONSTANT-AST.

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

(defgeneric interpret-ast (ast static-env dynamic-env))

(defun interpret (ast)
  (let ((static-env (list (make-hash-table :test #'eq)))
	(dynamic-env '()))
    (interpret-ast ast static-env dynamic-env)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Methods on INTERPRET-AST.

(defmethod interpret-ast ((ast cleavir-ast:constant-ast)
			  static-env dynamic-env)
  (declare (ignore static-env dynamic-env))
  (cleavir-ast:value ast))


;;;; Depends on the MD5 library

(in-package :cleric)

(defun calculate-digest (challenge cookie)
  (md5:md5sum-string (format nil "~a~a" cookie challenge)))

Make CALCULATE-DIGEST work for all CL implementations.

;;;; Depends on the MD5 library

(in-package :cleric)

(defun calculate-digest (challenge cookie)
  (let ((input (format nil "~a~a" cookie challenge)))
    #+(or :cmu :sbcl (and :lispworks (not :lispworks4)) :ccl :allegro)
    (md5:md5sum-string input)
    #-(or :cmu :sbcl (and :lispworks (not :lispworks4)) :ccl :allegro)
    (md5:md5sum-sequence (map '(vector (unsigned-byte 8)) #'char-code input))))


(in-package :de.anvi.croatoan)

(defun add-string (window string &key 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."
  (let ((winptr (.winptr window)))
    (cond ((and y x n)
           (%mvwaddnstr winptr y x string n))
          ((and y x)
           (%mvwaddstr winptr y x string))
          (n
           (%waddnstr winptr string n))
          (t
           (%waddstr winptr string)))))

;;; TODOs

;; A common function to display both strings and chars.
;;(defun display (window object &key y x n)
;;  (if (typep object 'chtype)

;; rewrite all the addstr and print functions in a way that they use format internally and
;; can accept chars like ~% instead of C's \n.
;;(add-string scr (format nil " upper left corner~%~%~%"))

Modify add-string to accept attributes and colors

(in-package :de.anvi.croatoan)

;; first attempt to create add-string with attributes and colors
;; without adding a complex-string type first.
(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 ((winptr (.winptr window))
        (pos1 (.cursor-position window)))
    (if n
        (%waddnstr winptr string n)
        (%waddstr winptr string))
    (when (or attributes color-pair)
      (let ((pos2 (.cursor-position window))
            (count (if n n (length string))))
        (move window (car pos1) (cadr pos1))
        (change-attributes window count attributes color-pair)
        (move window (car pos2) (cadr pos2))))))

;;; TODOs

;; A common function to display both strings and chars.
;;(defun display (window object &key y x n)
;;  (if (typep object 'chtype)

;; rewrite all the addstr and print functions in a way that they use format internally and
;; can accept chars like ~% instead of C's \n.
;;(add-string scr (format nil " upper left corner~%~%~%"))


(cl:in-package #:cleavir-simple-value-numbering)

;;; We attribute a unique number to each value designator.  That way,
;;; we can keep the value designators in a partition sorted by the
;;; unique number which makes operations on partitions faster.
;;;
;;; This variable should be bound to some small integer at the
;;; beginning of processing.
(defvar *unique-number*)

;;; We use instances of this class to designate values.
(defclass value-designator ()
  ((%unique-number :initform (incf *unique-number*) :reader unique-number)))

;;; This variable holds and EQ hash table mapping constants to value
;;; designators.
(defvar *constant-designators*)

(defun constant-designator (constant)
  (let ((result (gethash constant *constant-designators*)))
    (when (null result)
      (setf result (make-instance 'value-designator))
      (setf (gethash constant *constant-designators*) result))
    result))

(defun simple-value-numbering (initial-instruction)
  (declare (ignore initial-instruction))
  (let ((*unique-number* 0)
	(*constant-designators* (make-hash-table :test #'eq)))))

;;  LocalWords:  designator designators

Remove unique number. We will use a different technique.

(cl:in-package #:cleavir-simple-value-numbering)

;;; We use instances of this class to designate values.
(defclass value-designator ()
  ())

;;; This variable holds and EQ hash table mapping constants to value
;;; designators.
(defvar *constant-designators*)

(defun constant-designator (constant)
  (let ((result (gethash constant *constant-designators*)))
    (when (null result)
      (setf result (make-instance 'value-designator))
      (setf (gethash constant *constant-designators*) result))
    result))

(defun simple-value-numbering (initial-instruction)
  (declare (ignore initial-instruction))
  (let ((*constant-designators* (make-hash-table :test #'eq)))))

;;  LocalWords:  designator designators


;;;; cl-singleton-mixin.lisp
;;;;
;;;; Copyright 2015 hipeta (rhipeta@gmail.com)
;;;;
;;;; This software is released under the MIT License.
;;;; http://opensource.org/licenses/mit-license.php

(in-package :cl-user)
(defpackage cl-singleton-mixin
  (:use :cl)
  (:export :singleton-class
           :singleton-mixin
           :remove-singleton-instance))
(in-package :cl-singleton-mixin)

(defclass singleton-class (standard-class)
  ((%the-singleton-instance :initform nil)))
(defclass singleton-mixin () ())

(defmethod make-instance ((class singleton-class) &key)
  (with-slots (%the-singleton-instance) class
    (or %the-singleton-instance (setf %the-singleton-instance (call-next-method)))))

(defgeneric remove-singleton-instance (class)
  (:method ((class singleton-class))
    (with-slots (%the-singleton-instance) class
      (setf %the-singleton-instance nil))))

(defmethod reinitialize-instance :after ((class singleton-class) &key)
  (remove-singleton-instance class))

(metap:validate-superclass* (singleton-class standard-class t)
                            (singleton-class singleton-class t)
                            (standard-class singleton-class nil))
(metap:register-m1-m2-pair 'singleton-mixin 'singleton-class)

Add method remove-singleton-instance (class symbol)

;;;; cl-singleton-mixin.lisp
;;;;
;;;; Copyright 2015 hipeta (rhipeta@gmail.com)
;;;;
;;;; This software is released under the MIT License.
;;;; http://opensource.org/licenses/mit-license.php

(in-package :cl-user)
(defpackage cl-singleton-mixin
  (:use :cl)
  (:export :singleton-class
           :singleton-mixin
           :remove-singleton-instance))
(in-package :cl-singleton-mixin)

(defclass singleton-class (standard-class)
  ((%the-singleton-instance :initform nil)))
(defclass singleton-mixin () ())

(defmethod make-instance ((class singleton-class) &key)
  (with-slots (%the-singleton-instance) class
    (or %the-singleton-instance (setf %the-singleton-instance (call-next-method)))))

(defgeneric remove-singleton-instance (class)
  (:method ((class symbol))
    (remove-singleton-instance (find-class class)))
  (:method ((class singleton-class))
    (with-slots (%the-singleton-instance) class
      (setf %the-singleton-instance nil))))

(defmethod reinitialize-instance :after ((class singleton-class) &key)
  (remove-singleton-instance class))

(metap:validate-superclass* (singleton-class standard-class t)
                            (singleton-class singleton-class t)
                            (standard-class singleton-class nil))
(metap:register-m1-m2-pair 'singleton-mixin 'singleton-class)


;;;; packagedef.lisp
;;;; Author: Elliot Penson

(defpackage :knight-owl
  (:use :common-lisp))

Use cl-ppcre in the knight-owl package

;;;; packagedef.lisp
;;;; Author: Elliot Penson

(ql:quickload "cl-ppcre")

(defpackage :knight-owl
  (:use :common-lisp :cl-ppcre))


;;;; quickproject.asd

(asdf:defsystem #:quickproject
  :serial t
  :components ((:file "package")
               (:file "quickproject")))

Add :description to system definition.

;;;; quickproject.asd

(asdf:defsystem #:quickproject
  :description "Creates the skeleton of a new Common Lisp project"
  :serial t
  :components ((:file "package")
               (:file "quickproject")))


(in-package #:deb-package)

(ftype get-item list symbol list)
(defun get-item (list keyword)
  (rest
   (find-if #'(lambda (item)
                (getf item keyword))
            list)))

(defmacro define-deb-package (name &body forms)
  `(let ((name (string-downcase (symbol-name ',name)))
         (changelog-entries
          (make-array
           ,(length (get-item forms :changelog))
           :initial-contents (list ,@(mapcar
                                      #'(lambda (entry)
                                          `(make-instance 'changelog-entry ,@entry))
                                      (get-item forms :changelog))))))
     (format t "~A: ~A~%" name changelog-entries)))

(defclass changelog-entry ()
  ((version :initarg :version
            :type string
            :initform (error "Version required."))
   (author :initarg :author
           :type string
           :initform (error "Author required."))
   (message :initarg :message
            :type string
            :initform (error "Message required.")))
  (:documentation "A single changelog entry."))

(defclass deb-package ()
  ((changelog :initarg :changelog
              :type (vector changelog-entry)))
  (:documentation "Holds all the data required to generate a debian package."))

Create the "generate" function and use it.

(in-package #:deb-package)

(ftype get-item list symbol list)
(defun get-item (list keyword)
  (rest
   (find-if #'(lambda (item)
                (getf item keyword))
            list)))

(defmacro define-deb-package (name &body forms)
  `(let ((changelog-entries
          (make-array
           ,(length (get-item forms :changelog))
           :initial-contents (list ,@(mapcar
                                      #'(lambda (entry)
                                          `(make-instance 'changelog-entry ,@entry))
                                      (get-item forms :changelog))))))
     (generate (make-instance 'deb-package
                              :name ',name
                              :changelog changelog-entries))))

(defclass changelog-entry ()
  ((version :initarg :version
            :type string
            :initform (error "Version required."))
   (author :initarg :author
           :type string
           :initform (error "Author required."))
   (message :initarg :message
            :type string
            :initform (error "Message required.")))
  (:documentation "A single changelog entry."))

(defclass deb-package ()
  ((name :initarg :name
         :type symbol
         :reader name
         :initform (error "Name required."))
   (changelog :initarg :changelog
              :type (vector changelog-entry)
              :reader changelog
              :initform (error "Changelog required.")))
  (:documentation "Holds all the data required to generate a debian package."))

(ftype generate deb-package null)
(defun generate (package)
  "Generates a debian package."
  (format t "~A: ~A"
          (string-downcase (symbol-name (name package)))
          (changelog package)))


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

(defun fill-boot (boot)
  (customize-c1 boot)
  (customize-r1 boot)
  (phase1 boot)
  (customize-r2 boot)
  (customize-c2 boot)
  (phase2 boot)
  (phase3 boot))

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

Reorder calls and remove calls that are no longer needed.

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

(defun fill-boot (boot)
  (customize-c1 boot)
  (customize-r2 boot)
  (phase1 boot)
  (phase2 boot)
  (phase3 boot))

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


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

(env-load "transpiler/targets/javascript/config.lisp")
(env-load "transpiler/targets/javascript/expand.lisp")
;(env-load "transpiler/targets/javascript/class.lisp")
(env-load "transpiler/targets/javascript/codegen.lisp")
;(env-load "transpiler/targets/javascript/codegen-inline.lisp")
(env-load "transpiler/targets/javascript/codegen-inline-cons.lisp")
(env-load "transpiler/targets/javascript/env-load.lisp")
(env-load "transpiler/targets/javascript/toplevel.lisp")

Use class macros in this directory.

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

(env-load "transpiler/targets/javascript/config.lisp")
(env-load "transpiler/targets/javascript/expand.lisp")
(env-load "transpiler/targets/javascript/class.lisp")
(env-load "transpiler/targets/javascript/codegen.lisp")
;(env-load "transpiler/targets/javascript/codegen-inline.lisp")
(env-load "transpiler/targets/javascript/codegen-inline-cons.lisp")
(env-load "transpiler/targets/javascript/env-load.lisp")
(env-load "transpiler/targets/javascript/toplevel.lisp")


(defsystem :named-readtables
  :description "Library that creates a namespace for named readtable akin to the namespace of packages."
  :author "Tobias C. Rittweiler <trittweiler@common-lisp.net>"
  :version "1.0"
  :licence "BSD"
  :serial t
  :components
  ((:file "package")
   (:file "destructure-case")
   (:file "cruft")
   (:file "named-readtables")))

Add dependencies to DEFSYSTEM definition.

(defsystem :named-readtables
  :description "Library that creates a namespace for named readtable akin to the namespace of packages."
  :author "Tobias C. Rittweiler <trittweiler@common-lisp.net>"
  :version "1.0 (unpublished so far)"
  :licence "BSD"
  :serial t
  :components
  ((:file "package")
   (:file "utils"            :depends-on ("package"))
   (:file "cruft"            :depends-on ("package" "utils"))
   (:file "named-readtables" :depends-on ("package" "utils" "cruft"))))


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

(defun concat-stringtree (&rest x)
  (apply #'string-concat (tree-list x)))

Concatenate from leaves to root to use less heap.

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

(defun %concat-stringtree (x)
  (& x
     (? (string? x)
        x
        (apply #'string-concat (@ #'%concat-stringtree x)))))

(defun concat-stringtree (&rest x)
  (%concat-stringtree x))


(test-case 'test-case-qsort
           '((test test-qsort
                   ((assert-equal '() (qsort '()))
                    (assert-equal '(1) (qsort '(1)))
                    (assert-equal '(1 2) (qsort '(1 2)))
                    (assert-equal '(1 2 3) (qsort '(3 1 2)))
                    (assert-equal '(1 2 2 3) (qsort '(2 3 1 2)))))))

Test qsort with and without getter

(test-case 'test-case-qsort
           '((test test-qsort-without-getter
                   ((assert-equal '() (qsort '()))
                    (assert-equal '(1) (qsort '(1)))
                    (assert-equal '(1 2) (qsort '(1 2)))
                    (assert-equal '(1 2 3) (qsort '(3 1 2)))
                    (assert-equal '(1 2 2 3) (qsort '(2 3 1 2)))))
             (test test-qsort-with-getter
                   ((assert-equal '((1 . 4) (2 . 3)) (qsort '((2 . 3) (1 . 4)) car))
                    (assert-equal '((2 . 3) (1 . 4)) (qsort '((1 . 4) (2 . 3)) cdr))))))


(in-package #:cl-user)

(asdf:defsystem :sicl-loop-test
  :depends-on (:sicl-loop-support)
  :serial t
  :components
  ((:file "test-packages")
   (:file "loop-defmacro")
   (:file "loop-test")
   (:file "simple-loop")
   (:file "loop1")
   (:file "loop2")
   (:file "loop3")
   (:file "loop4")
   (:file "loop5")
   (:file "loop6")
   (:file "loop7")
   (:file "loop8")
   (:file "loop9")
   (:file "loop10")
   (:file "loop11")
   (:file "loop12")
   (:file "loop13")
   (:file "loop14")
   (:file "loop15")
   (:file "loop16")
   (:file "loop17")))

Define system in package ASDF-USER.

(in-package #:asdf-user)

(defsystem :sicl-loop-test
  :depends-on (:sicl-loop-support)
  :serial t
  :components
  ((:file "test-packages")
   (:file "loop-defmacro")
   (:file "loop-test")
   (:file "simple-loop")
   (:file "loop1")
   (:file "loop2")
   (:file "loop3")
   (:file "loop4")
   (:file "loop5")
   (:file "loop6")
   (:file "loop7")
   (:file "loop8")
   (:file "loop9")
   (:file "loop10")
   (:file "loop11")
   (:file "loop12")
   (:file "loop13")
   (:file "loop14")
   (:file "loop15")
   (:file "loop16")
   (:file "loop17")))


(eval-when (:compile-toplevel :load-toplevel)
  (ql:quickload 'docutils))

(defpackage :coleslaw-rst
  (:use :cl)
  (:import-from :coleslaw #:render-content)
  (:import-from :cl-docutils #:read-rst
                             #:write-html)
  (:export #:enable))

(in-package :coleslaw-rst)

(defmethod render-content (text (format (eql :rst)))
  (with-output-to-string (str)
    (write-html str (read-rst text))))

(defun enable ())

Package fix to rst plugin.

(eval-when (:compile-toplevel :load-toplevel)
  (ql:quickload 'docutils))

(defpackage :coleslaw-rst
  (:use :cl)
  (:import-from :coleslaw #:render-content)
  (:import-from :docutils #:read-rst
                          #:write-html)
  (:export #:enable))

(in-package :coleslaw-rst)

(defmethod render-content (text (format (eql :rst)))
  (with-output-to-string (str)
    (write-html str (read-rst text))))

(defun enable ())


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

(defconstant nil 'nil)
(defconstant t 't)

Use explicit package marker with IN-PACKAGE.

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

(defconstant nil 'nil)
(defconstant t 't)


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

(defgeneric rotate-left (tree))

(defgeneric rotate-right (tree))

Add method on ROTATE-LEFT specialized to NODE.

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

(defgeneric rotate-left (tree))

(defgeneric rotate-right (tree))

(defmethod rotate-left ((tree node))
  (when (null (right tree))
    (error 'right-subtree-must-be-non-nil :tree tree))


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

(asdf:defsystem cleavir-code-utilities
  :serial t
  :components
  ((:file "packages")
   (:file "conditions")
   (:file "argcount")
   (:file "form")
   (:file "general")
   (:file "declarations")
   (:file "lambda-lists")
   (:file "destructuring")))

Make the system depend on the internationalization system.

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

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


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

(defun butlast-path-component (x)
  (apply #'+ (pad (butlast (path-pathlist x)) "/")))

(defun url-without-filename (x)
  (? x
     (butlast-path-component x)
	 ""))

(defun url-schema (x)
  (car (split #\/ x)))

(defun url-has-schema? (x)
  (alet (split #\/ x)
    (& (tail? !. ":")
	   (empty-string? .!.))))

(defun url-without-schema (x)
  (? (url-has-schema? x)
     (subseq x (+ 2 (length (url-schema x))))
     x))

(defun url-path (x)
  (& x (apply #'+ (pad (cdr (path-pathlist (url-without-schema x))) "/"))))

(defun url-without-path (x)
  (apply #'+ (pad (subseq (path-pathlist x) 0 3) "/")))

Use PATHLIST-PATH to deal with empty names.

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

(defun butlast-path-component (x)
  (pathlist-path (pad (butlast (path-pathlist x)) "/")))

(defun url-without-filename (x)
  (? x
     (butlast-path-component x)
	 ""))

(defun url-schema (x)
  (car (path-pathlist x)))

(defun url-has-schema? (x)
  (alet (path-pathlist x)
    (& (tail? !. ":")
	   (empty-string? .!.))))

(defun url-without-schema (x)
  (? (url-has-schema? x)
     (subseq x (+ 2 (length (url-schema x))))
     x))

(defun url-path (x)
  (pathlist-path (pad (cdr (path-pathlist (url-without-schema x))) "/")))

(defun url-without-path (x)
  (pathlist-path (pad (subseq (path-pathlist x) 0 3) "/")))


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

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

Define function VALIDATE-SUPERCLASS in run-time environment R2, always returning true.

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

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

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


(in-package #:asdf-user)

(defsystem #:sicl-additional-types
  :components
  ((:file "packages")
   (:file "types" :depends-on ("packages"))))

Use explicit package prefix for IN-PACKAGE.

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

(defsystem #:sicl-additional-types
  :components
  ((:file "packages")
   (:file "types" :depends-on ("packages"))))


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

(defun create-bridge-class-accessors (boot)
  (let ((c (c2 boot))
	(r (r3 boot)))
  (ld "../CLOS/method-function-defgeneric.lisp" c r)))

Load more files containing definitions of class accessors.

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

(defun create-bridge-class-accessors (boot)
  (let ((c (c2 boot))
	(r (r3 boot)))
  (ld "../CLOS/method-function-defgeneric.lisp" c r)
  (ld "../CLOS/method-generic-function-defgeneric.lisp" c r)
  (ld "../CLOS/method-lambda-list-defgeneric.lisp" c r)
  (ld "../CLOS/method-qualifiers-defgeneric.lisp" c r)
  (ld "../CLOS/method-specializers-defgeneric.lisp" c r)
  (ld "../CLOS/accessor-method-slot-definition-defgeneric.lisp" c r)
  (ld "../CLOS/slot-definition-name-defgeneric.lisp" c r)
  (ld "../CLOS/slot-definition-allocation-defgeneric.lisp" c r)
  (ld "../CLOS/slot-definition-type-defgeneric.lisp" c r)
  (ld "../CLOS/slot-definition-initargs-defgeneric.lisp" c r)
  (ld "../CLOS/slot-definition-initform-defgeneric.lisp" c r)
  (ld "../CLOS/slot-definition-initfunction-defgeneric.lisp" c r)
  (ld "../CLOS/slot-definition-readers-defgeneric.lisp" c r)
  (ld "../CLOS/slot-definition-writers-defgeneric.lisp" c r)
  (ld "../CLOS/slot-definition-location-defgeneric.lisp" c r)
  (ld "../CLOS/class-name-defgeneric.lisp" c r)
  (ld "../CLOS/class-direct-superclasses-defgeneric.lisp" c r)
  (ld "../CLOS/class-direct-slots-defgeneric.lisp" c r)
  (ld "../CLOS/class-direct-default-initargs-defgeneric.lisp" c r)
  (ld "../CLOS/class-precedence-list-defgeneric.lisp" c r)
  (ld "../CLOS/class-slots-defgeneric.lisp" c r)
  (ld "../CLOS/class-default-initargs-defgeneric.lisp" c r)
  (ld "../CLOS/class-finalized-p-defgeneric.lisp" c r)
  (ld "../CLOS/class-prototype-defgeneric.lisp" c r)))


(in-package #:asdf-user)

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

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

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

Use explicit package marker with IN-PACKAGE.

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

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

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

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


(in-package :cl-user)
(uiop/package:define-package :clutils/all
    (:nicknames :clutils)
  (:use :cl)
  (:use-reexport
   :clutils/functional
   :clutils/math
   :clutils/strings
   :clutils/macros
   :clutils/lists
   :clutils/sequences
   :clutils/packages
   :clutils/project))

Add package nickname :clu as shortcut.

(in-package :cl-user)
(uiop/package:define-package :clutils/all
    (:nicknames :clutils :clu)
  (:use :cl)
  (:use-reexport
   :clutils/functional
   :clutils/math
   :clutils/strings
   :clutils/macros
   :clutils/lists
   :clutils/sequences
   :clutils/packages
   :clutils/project))


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

(asdf:defsystem #:sicl-hir-to-mir
  :depends-on (:cleavir-hir-to-mir
	       :cleavir-processor-x86-64
	       :sicl-target-sicl)
  :serial t
  :components
  ((:file "packages")
   (:file "general")
   (:file "cons")
   (:file "integer")
   (:file "environment-related-instructions")))

Define system in package ASDF-USER.

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

(defsystem #:sicl-hir-to-mir
  :depends-on (:cleavir-hir-to-mir
	       :cleavir-processor-x86-64
	       :sicl-target-sicl)
  :serial t
  :components
  ((:file "packages")
   (:file "general")
   (:file "cons")
   (:file "integer")
   (:file "environment-related-instructions")))


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

(asdf:defsystem glop
  :license "MIT"
  :version "git"
  :description "Direct FFI bindings for OpenGL window and context management"
  :author "Morgan Veyret <patzy at appart kicks-ass net>"
  :depends-on (:cffi)
  :components
  ((:module "src"
            :serial t
            :components
            ((:file "package")
             (:file "utils")
             #+unix(:module "x11"
                            :serial t
                            :components ((:file "package")
                                         (:file "keysymdef")
                                         (:file "xlib")
                                         (:file "xkb")
                                         (:file "glx")
                                         (:file "display-ctrl")
                                         (:file "glop-x11")))
             #+(or win32 windows)(:module "win32"
                                          :serial t
                                          :components ((:file "package")
                                                       (:file "win32")
                                                       (:file "wgl")
                                                       (:file "glop-win32")))
             (:file "glop")))))

Fix invalid asdf version string and contact email

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

(asdf:defsystem glop
  :license "MIT"
  :version "0.1.0"
  :description "Direct FFI bindings for OpenGL window and context management"
  :author "Morgan Veyret <patzy at oxyde dot org>"
  :depends-on (:cffi)
  :components
  ((:module "src"
            :serial t
            :components
            ((:file "package")
             (:file "utils")
             #+unix(:module "x11"
                            :serial t
                            :components ((:file "package")
                                         (:file "keysymdef")
                                         (:file "xlib")
                                         (:file "xkb")
                                         (:file "glx")
                                         (:file "display-ctrl")
                                         (:file "glop-x11")))
             #+(or win32 windows)(:module "win32"
                                          :serial t
                                          :components ((:file "package")
                                                       (:file "win32")
                                                       (:file "wgl")
                                                       (:file "glop-win32")))
             (:file "glop")))))


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

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

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

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

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

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

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

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

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

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

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

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


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

(defclass slot-definition (metaobject)
  ((%name
    :initarg :name
    :reader slot-definition-name)
   (%allocation
    :initarg :allocation
    :initform :instance
    :reader slot-definition-allocation)
   (%type
    :initarg :type
    :initform t
    :reader slot-definition-type)
   (%initargs
    :initform '()
    :initarg :initargs
    :reader slot-definition-initargs)
   (%initform
    :initarg :initform
    :initform nil
    :reader slot-definition-initform)
   (%initfunction
    :initform nil
    :initarg :initfunction
    :reader slot-definition-initfunction)))

Add copyright dates and license statement.

;;;; Copyright (c) 2013 - 2015
;;;;
;;;;     Robert Strandh (robert.strandh@gmail.com)
;;;;
;;;; All rights reserved.
;;;;
;;;; Redistribution and use in source and binary forms, with or
;;;; without modification, are permitted provided that the following
;;;; conditions are met:
;;;;
;;;; 1. Redistributions of source code must retain the above copyright
;;;;    notice, this list of conditions and the following disclaimer.
;;;; 2. Redistributions in binary form must reproduce the above
;;;;    copyright notice, this list of conditions and the following
;;;;    disclaimer in the documentation and/or other materials
;;;;    provided with the distribution.
;;;;
;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND
;;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
;;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
;;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS
;;;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
;;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
;;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
;;;; ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
;;;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
;;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
;;;; POSSIBILITY OF SUCH DAMAGE.

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

(defclass slot-definition (metaobject)
  ((%name
    :initarg :name
    :reader slot-definition-name)
   (%allocation
    :initarg :allocation
    :initform :instance
    :reader slot-definition-allocation)
   (%type
    :initarg :type
    :initform t
    :reader slot-definition-type)
   (%initargs
    :initform '()
    :initarg :initargs
    :reader slot-definition-initargs)
   (%initform
    :initarg :initform
    :initform nil
    :reader slot-definition-initform)
   (%initfunction
    :initform nil
    :initarg :initfunction
    :reader slot-definition-initfunction)))


;;;; SPDX-FileCopyrightText: Atlas Engineer LLC
;;;; SPDX-License-Identifier: BSD-3-Clause

(in-package :cl-user)
(uiop:define-package download-manager/tests
  (:use #:common-lisp #:prove)
  (:import-from #:download-manager))
(in-package :download-manager/tests)

(plan nil)

(subtest "Simple HTTP/HTTPS downloads"
  (let ((urls '("https://abcl.org"
                "http://en.wikipedia.org/wiki/Main_Page"
                "https://duckduckgo.com"
                "https://atlas.engineer")))
    (dolist (url urls)
      (ok
       (download-manager:resolve (quri:uri url))
       (format nil "Able to download <~a>~%" url)))))

(finalize)

Use Nyxt specific site instead of Atlas.

;;;; SPDX-FileCopyrightText: Atlas Engineer LLC
;;;; SPDX-License-Identifier: BSD-3-Clause

(in-package :cl-user)
(uiop:define-package download-manager/tests
  (:use #:common-lisp #:prove)
  (:import-from #:download-manager))
(in-package :download-manager/tests)

(plan nil)

(subtest "Simple HTTP/HTTPS downloads"
  (let ((urls '("https://abcl.org"
                "http://en.wikipedia.org/wiki/Main_Page"
                "https://duckduckgo.com"
                "https://nyxt.atlas.engineer")))
    (dolist (url urls)
      (ok
       (download-manager:resolve (quri:uri url))
       (format nil "Able to download <~a>~%" url)))))

(finalize)


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

;;; The method defined here is meant to implement the behavior
;;; described in "Initialization of Method Metaobjects" in the AMOP.

;;; FIXME: Here, I specialize on METHOD, but check whether the
;;; specialization should be reserved for STANDARD-METHOD instead.

(defmethod initialize-instance :after ((method method)
				       &rest keys
				       &key
					 qualifiers
					 lambda-list
					 specializers
					 function
					 documentation)
  (declare (ignore qualifiers lambda-list specializers function documentation))
  (apply #'initialize-instance-after-method method keys))

(defmethod initialize-instance :after ((method standard-accessor-method)
				       &rest keys
				       &key
					 slot-definition
				       &allow-other-keys)
  (declare (ignore slot-definition))
  (apply #'initialize-instance-after-standard-accessor-method method keys))

Allow for :SLOT-DEFINITION initarg by adding &allow-other-keys.

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

;;; The method defined here is meant to implement the behavior
;;; described in "Initialization of Method Metaobjects" in the AMOP.

;;; FIXME: Here, I specialize on METHOD, but check whether the
;;; specialization should be reserved for STANDARD-METHOD instead.

(defmethod initialize-instance :after ((method method)
				       &rest keys
				       &key
					 qualifiers
					 lambda-list
					 specializers
					 function
					 documentation
				       &allow-other-keys)
  (declare (ignore qualifiers lambda-list specializers function documentation))
  (apply #'initialize-instance-after-method method keys))

(defmethod initialize-instance :after ((method standard-accessor-method)
				       &rest keys
				       &key
					 slot-definition
				       &allow-other-keys)
  (declare (ignore slot-definition))
  (apply #'initialize-instance-after-standard-accessor-method method keys))


(in-package #:sicl-clos)

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

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

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

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

Define STANDARD-FUNCTION and explain why it is defined that way in comment.

(in-package #:sicl-clos)

;;; We need for funcallable standard objects and standard functions to
;;; be called the same way.  There is a slight difficulty in order for
;;; that to happen, though.  When a funcallable standard object is
;;; allocated, since it is a standard object, two additional cells are
;;; allocated in the contents vector, namely for the object class
;;; unique number and for the class slots of the class.  When a
;;; standard function is allocated, however, the cell containing the
;;; class slots of the class is not present because standard functions
;;; are not standard objects, so they can not become obsolete, and
;;; therefore do not need this information in order to be updated.
;;; But we still want the slots of the FUNCTION class to have the same
;;; location in instances of STANDARD-FUNCTION.  To accomplish that,
;;; we add a dummy slot to standard functions that is in the same
;;; location as the class slots of the class in standard objects.  To
;;; add this dummy slot, we define a class DUMMY-SLOT-PROVIDER,
;;; containing such a slot.

(define-built-in-class dummy-slot-supplier (t)
  ((%dummy :initform nil)))

;;; It is important that the list of superclasses appear in the order
;;; that it does in this definition, because slots are allocated with
;;; locations that take this order into account.  In this case, the
;;; slot supplied by DUMMY-SLOT-SUPPLIER will occupy the first
;;; location in instances of STANDARD-FUNCTION.
(define-built-in-class standard-function (dummy-slot-supplier function)
  ())

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

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

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

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


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

(asdf:defsystem :sicl-type
  :components
  ((:file "packages")))

Define system in package ASDF-USER.

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

(defsystem :sicl-type
  :components
  ((:file "packages")))


;;;; package.lisp

(defpackage #:sdl2
  (:use #:cl #:alexandria #:cffi)
  (:export :sys-video
           :sys-audio
           :sys-timer
           :sys-joystick
           :sys-gamecontroller ; implies joystick
           :noparachute
           :everything
           :init
           :quit
           :create-window
           :destroy-window))

(defpackage #:sdl2-ffi)

Remove some now-spurious exports, export conditions, use uninterned symbols

;;;; package.lisp

(defpackage #:sdl2
  (:use #:cl #:alexandria #:cffi)
  (:export ;; API
           #:init
           #:quit
           #:create-window
           #:destroy-window

           ;; Conditions
           #:sdl-error))

(defpackage #:sdl2-ffi)


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

(asdf:defsystem :sicl-read
    :components
  ((:file "packages" :depends-on ())
   (:file "float" :depends-on ("packages"))
   (:file "read" :depends-on ("packages" "float"))))

Define ASDF system in package ASDF-USER.

(in-package #:asdf-user)

(defsystem :sicl-read
    :components
  ((:file "packages" :depends-on ())
   (:file "float" :depends-on ("packages"))
   (:file "read" :depends-on ("packages" "float"))))


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

(defsystem monkeylib-markup-xml
  :name "monkeylib-markup-xml"
  :components
  ((:file "packages")
   (:file "xml" :depends-on ("packages")))
  :depends-on
  (:com.gigamonkeys.macro-utilities
   :com.gigamonkeys.utilities
   :com.gigamonkeys.foo))

Add description to .asd file.

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

(defsystem monkeylib-markup-xml
  :name "monkeylib-markup-xml"
  :description "Library for generating XML from Markup-formatted text."
  :components
  ((:file "packages")
   (:file "xml" :depends-on ("packages")))
  :depends-on
  (:com.gigamonkeys.macro-utilities
   :com.gigamonkeys.utilities
   :com.gigamonkeys.foo))


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

(defun load-file (filename environment)
  (load-source-with-environments
   (asdf:system-relative-pathname :sicl-extrinsic-hir-compiler filename)
   environment
   environment))

Replace ASDF system used for relative pathnames.

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

(defun load-file (filename environment)
  (load-source-with-environments
   (asdf:system-relative-pathname :sicl-extrinsic-environment filename)
   environment
   environment))


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

(defun tre-expansions (x)
  (backquote-expand (quasiquote-expand (macroexpand (dot-expand x)))))
(defun expr2cl (x)                 (make-lambdas (tre-expansions x)))
(defun file2cl (pathname)          (expr2cl (read-file pathname)))
(defun files2cl (&rest pathnames)  (. 'progn (mapcan #'file2cl pathnames)))

(defun cl-expex-initializer (ex)
  (= (expex-argument-filter ex) #'identity
     (expex-setter-filter ex)   #'identity))

(defun cl-frontend (x)
  (alet (transpiler-macroexpand (quasiquote-expand (dot-expand x)))
    (fake-expression-expand (fake-place-expand (lambda-expand (rename-arguments (backquote-expand (compiler-macroexpand !))))))
    (make-lambdas !)))

(defun cl-sections-before-deps ()
  (unless (exclude-base?)
    (list (. 'cl-base *cl-base*))))

(defun make-cl-transpiler ()
  (create-transpiler
      :name                  :common-lisp
      :frontend-only?        t
      :import-variables?     t
      :lambda-export?        nil
      :stack-locals?         nil
      :sections-before-deps  #'cl-sections-before-deps
      :frontend-init         #'(() (= *cl-builtins* nil))
      :own-frontend          #'cl-frontend
      :expex-initializer     #'cl-expex-initializer))

(defvar *cl-transpiler* (copy-transpiler (make-cl-transpiler)))

Make lambda exoression in (POSTPROCESSOR).

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

(defun cl-expex-initializer (ex)
  (= (expex-argument-filter ex) #'identity
     (expex-setter-filter ex)   #'identity))

(defun cl-frontend (x)
  (aprog1 (transpiler-macroexpand (quasiquote-expand (dot-expand x)))
    (fake-expression-expand (fake-place-expand (lambda-expand (rename-arguments (backquote-expand (compiler-macroexpand !))))))))

(defun cl-sections-before-deps ()
  (unless (exclude-base?)
    (list (. 'cl-base *cl-base*))))

(defun make-cl-transpiler ()
  (create-transpiler
      :name                  :common-lisp
      :frontend-only?        t
      :import-variables?     t
      :lambda-export?        nil
      :stack-locals?         nil
      :sections-before-deps  #'cl-sections-before-deps
      :frontend-init         #'(() (= *cl-builtins* nil))
      :own-frontend          #'cl-frontend
      :expex-initializer     #'cl-expex-initializer
      :postprocessor         #'((&rest x)
                                  (make-lambdas (apply #'+ x)))))

(defvar *cl-transpiler* (copy-transpiler (make-cl-transpiler)))


(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/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 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/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-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"))
(load (rp "../../Data-and-control-flow/setf-fdefinition.lisp"))

Load new file with definition of ENSURE-GENERIC-FUNCTION.

(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"))
(load (rp "../../Data-and-control-flow/setf-fdefinition.lisp"))
(load (rp "ensure-generic-function.lisp"))


(in-package :local-time-locale)

(defmethod make-locale ((class (eql :pt-bz)))
  (make-instance 'locale-pt
		 :first-day-of-week 0))

Complete the renameing of brazilian portuguese

(in-package :local-time-locale)

(defmethod make-locale ((class (eql :pt-br)))
  (make-instance 'locale-pt
		 :first-day-of-week 0))


;;;; cl-singleton-mixin.lisp
;;;;
;;;; Copyright 2015 hipeta (rhipeta@gmail.com)
;;;;
;;;; This software is released under the MIT License.
;;;; http://opensource.org/licenses/mit-license.php

(in-package :cl-user)
(defpackage cl-singleton-mixin
  (:use :cl)
  (:export :singleton-class
           :singleton-mixin
           :remove-singleton-instance))
(in-package :cl-singleton-mixin)

(defclass singleton-class (standard-class)
  ((%the-singleton-instance :initform nil)))
(defclass singleton-mixin () ())

(defmethod make-instance :around ((class singleton-class) &key)
  (with-slots (%the-singleton-instance) class
    (or %the-singleton-instance (setf %the-singleton-instance (call-next-method)))))

(defgeneric remove-singleton-instance (class)
  (:method ((class symbol))
    (remove-singleton-instance (find-class class)))
  (:method ((class singleton-class))
    (with-slots (%the-singleton-instance) class
      (setf %the-singleton-instance nil))))

(defmethod reinitialize-instance :after ((class singleton-class) &key)
  (remove-singleton-instance class))

(metap:validate-superclass* (singleton-class standard-class t)
                            (singleton-class singleton-class t)
                            (standard-class singleton-class nil))

(metap:register-m1-m2-pair singleton-mixin singleton-class)

Modify some code for metap changed

;;;; cl-singleton-mixin.lisp
;;;;
;;;; Copyright 2015 hipeta (rhipeta@gmail.com)
;;;;
;;;; This software is released under the MIT License.
;;;; http://opensource.org/licenses/mit-license.php

(in-package :cl-user)
(defpackage cl-singleton-mixin
  (:use :cl)
  (:export :singleton-class
           :singleton-mixin
           :remove-singleton-instance))
(in-package :cl-singleton-mixin)

(defclass singleton-class (standard-class)
  ((%the-singleton-instance :initform nil)))
(defclass singleton-mixin () ())

(defmethod make-instance :around ((class singleton-class) &key)
  (with-slots (%the-singleton-instance) class
    (or %the-singleton-instance (setf %the-singleton-instance (call-next-method)))))

(defgeneric remove-singleton-instance (class)
  (:method ((class symbol))
    (remove-singleton-instance (find-class class)))
  (:method ((class singleton-class))
    (with-slots (%the-singleton-instance) class
      (setf %the-singleton-instance nil))))

(defmethod reinitialize-instance :after ((class singleton-class) &key)
  (remove-singleton-instance class))

(metap:validate-superclass* (singleton-class standard-class t)
                            (singleton-class singleton-class t)
                            (standard-class singleton-class nil))

(metap:register-m1-m2-pair 'singleton-mixin 'singleton-class)


;;; -*- Mode: Lisp; package: CL-USER; Syntax: Common-lisp; Base: 10 -*-

#|

|#

(in-package #:common-lisp-user)
(defpackage #:cl-markdown-test-system (:use #:cl #:asdf))
(in-package #:cl-markdown-test-system)

(defsystem cl-markdown-test
  :version "0.1"
  :author "Gary Warren King <gwking@metabang.com>"
  :maintainer "Gary Warren King <gwking@metabang.com>"
  :licence "MIT Style License"
  :components ((:module "unit-tests"
                        :components ((:file "package")
                                     (:file "framework"
                                            :depends-on ("package"))
                                     (:file "comparison"
                                            :depends-on ("framework"))
                                     (:file "test-markdown"
                                            :depends-on ("package"))
                                     (:file "test-chunkers"
                                            :depends-on ("test-markdown"))
                                     (:file "test-regexes"
                                            :depends-on ("test-spans"))
                                     (:file "test-spans"
                                            :depends-on ("test-markdown"))
                                     (:file "test-strippers"
                                            :depends-on ("test-markdown")))))

  :depends-on (cl-markdown lml2 lift cl-html-diff html-encode trivial-shell))

Split tests into tests and create comparison report

;;; -*- Mode: Lisp; package: CL-USER; Syntax: Common-lisp; Base: 10 -*-

(in-package #:common-lisp-user)
(defpackage #:cl-markdown-test-system (:use #:cl #:asdf))
(in-package #:cl-markdown-test-system)

(defsystem cl-markdown-test
  :version "0.1"
  :author "Gary Warren King <gwking@metabang.com>"
  :maintainer "Gary Warren King <gwking@metabang.com>"
  :licence "MIT Style License"
  :components ((:module "unit-tests"
                        :components ((:file "package")
				     (:file "test-markdown"
                                            :depends-on ("package"))
                                     (:file "test-chunkers"
                                            :depends-on ("test-markdown"))
                                     (:file "test-regexes"
                                            :depends-on ("test-spans"))
                                     (:file "test-spans"
                                            :depends-on ("test-markdown"))
                                     (:file "test-strippers"
                                            :depends-on ("test-markdown")))))
  :depends-on (cl-markdown lift))


(defsystem "petalisp.utilities"
  :author "Marco Heisig <marco.heisig@fau.de>"
  :license "AGPLv3"

  :depends-on ()

  :serial t
  :components
  ((:file "packages")
   (:file "identical")
   (:file "memoization")
   (:file "extended-euclid")
   (:file "define-method-pair")
   (:file "define-class-predicate")
   (:file "defalias")))

Make petalisp.utilties depend on alexandria.

(defsystem "petalisp.utilities"
  :author "Marco Heisig <marco.heisig@fau.de>"
  :license "AGPLv3"

  :depends-on ("alexandria")

  :serial t
  :components
  ((:file "packages")
   (:file "identical")
   (:file "memoization")
   (:file "extended-euclid")
   (:file "define-method-pair")
   (:file "define-class-predicate")
   (:file "defalias")))


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

(defvar *tre-revision*
    ,(with-open-file in (open "_current-version" :direction 'input)
       (let l (string-list (read-line in))
         (list-string (subseq l
                              (!? (position #\: l)
                                  (1+ !)
                                  0)
                              (1- (length l)))))))

(format t "; Revision ~A.~%" *tre-revision*)

Remove "M" from revision number.

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

(defvar *tre-revision*
    ,(with-open-file in (open "_current-version" :direction 'input)
       (let l (string-list (read-line in))
         (list-string
           (alet (subseq l
                         (!? (position #\: l)
                             (1+ !)
                             0)
                         (1- (length l)))
             (? (== #\M (car (last !)))
                (butlast !)
                !))))))

(format t "; Revision ~A.~%" *tre-revision*)


(in-package :cl-user)
(defpackage :nellie.alists
  (:use :cl)
  (:nicknames #:alists)
  (:export #:alist-get
           #:alist-get-str
           #:alist-set
           #:alist-update
           #:alist-merge))

(in-package :nellie.alists)

(defun alist-get (key alist)
  (cdr (assoc key alist)))

(defun alist-get-str (str-key alist)
  (cdr (assoc str-key alist :test #'equal)))

(defun alist-set (key value alist &key (test #'eql))
  (let ((existing (assoc key alist :test test)))
    (if existing
        (rplacd existing value)
        (rplacd (last alist) `((,key . ,value))))
    alist))

(defun alist-update (al1 al2 &key (test #'eql))
  (dolist (kv al2)
    (alist-set (car kv) (cdr kv) al1 :test test))
  al1)

(defun alist-merge (alists &key (test #'eql))
  (reduce (lambda (a b) (alist-update a b :test test))
          (cdr alists)
          :initial-value (copy-alist (car alists))))

Make `alist` the first parameter of all the alist handling functions

(in-package :cl-user)
(defpackage :nellie.alists
  (:use :cl)
  (:nicknames #:alists)
  (:export #:alist-get
           #:alist-get-str
           #:alist-set
           #:alist-update
           #:alist-merge))

(in-package :nellie.alists)

(defun alist-get (alist key &key (test #'eql))
  (cdr (assoc key alist :test test)))

(defun alist-get-str (alist key-string)
  (cdr (assoc key-string alist :test #'equal)))

(defun alist-set (alist key value &key (test #'eql))
  (if (null alist)
      (list (cons key value))
      (let ((existing (assoc key alist :test test)))
        (if existing
            (rplacd existing value)
            (rplacd (last alist) (list (cons key value))))
        alist)))

(defun alist-update (alist updates-alist &key (test #'eql))
  (dolist (kv updates-alist)
    (setf alist (alist-set alist (car kv) (cdr kv) :test test)))
  alist)

(defun alist-merge (alists &key (test #'eql))
  (reduce (lambda (a b) (alist-update a b :test test)) alists))