about summary refs log tree commit diff
path: root/third_party/lisp
diff options
context:
space:
mode:
Diffstat (limited to 'third_party/lisp')
-rw-r--r--third_party/lisp/alexandria/.boring13
-rw-r--r--third_party/lisp/alexandria/.gitignore4
-rw-r--r--third_party/lisp/alexandria/AUTHORS9
-rw-r--r--third_party/lisp/alexandria/LICENCE37
-rw-r--r--third_party/lisp/alexandria/README52
-rw-r--r--third_party/lisp/alexandria/alexandria-tests.asd11
-rw-r--r--third_party/lisp/alexandria/alexandria.asd62
-rw-r--r--third_party/lisp/alexandria/arrays.lisp18
-rw-r--r--third_party/lisp/alexandria/binding.lisp90
-rw-r--r--third_party/lisp/alexandria/conditions.lisp91
-rw-r--r--third_party/lisp/alexandria/control-flow.lisp106
-rw-r--r--third_party/lisp/alexandria/default.nix28
-rw-r--r--third_party/lisp/alexandria/definitions.lisp37
-rw-r--r--third_party/lisp/alexandria/doc/.gitignore3
-rw-r--r--third_party/lisp/alexandria/doc/Makefile28
-rw-r--r--third_party/lisp/alexandria/doc/alexandria.texinfo277
-rw-r--r--third_party/lisp/alexandria/doc/docstrings.lisp881
-rw-r--r--third_party/lisp/alexandria/features.lisp14
-rw-r--r--third_party/lisp/alexandria/functions.lisp161
-rw-r--r--third_party/lisp/alexandria/hash-tables.lisp101
-rw-r--r--third_party/lisp/alexandria/io.lisp172
-rw-r--r--third_party/lisp/alexandria/lists.lisp367
-rw-r--r--third_party/lisp/alexandria/macros.lisp370
-rw-r--r--third_party/lisp/alexandria/numbers.lisp295
-rw-r--r--third_party/lisp/alexandria/package.lisp243
-rw-r--r--third_party/lisp/alexandria/sequences.lisp555
-rw-r--r--third_party/lisp/alexandria/strings.lisp6
-rw-r--r--third_party/lisp/alexandria/symbols.lisp65
-rw-r--r--third_party/lisp/alexandria/tests.lisp2047
-rw-r--r--third_party/lisp/alexandria/types.lisp137
-rw-r--r--third_party/lisp/asdf-flv/.gitattributes2
-rw-r--r--third_party/lisp/asdf-flv/.gitignore3
-rw-r--r--third_party/lisp/asdf-flv/Makefile77
-rw-r--r--third_party/lisp/asdf-flv/README.md7
-rw-r--r--third_party/lisp/asdf-flv/asdf-flv.lisp64
-rw-r--r--third_party/lisp/asdf-flv/default.nix13
-rw-r--r--third_party/lisp/asdf-flv/net.didierverna.asdf-flv.asd43
-rw-r--r--third_party/lisp/asdf-flv/package.lisp28
-rw-r--r--third_party/lisp/babel.nix31
-rw-r--r--third_party/lisp/bordeaux-threads.nix19
-rw-r--r--third_party/lisp/cffi.nix33
-rw-r--r--third_party/lisp/chipz.nix33
-rw-r--r--third_party/lisp/chunga.nix27
-rw-r--r--third_party/lisp/cl-ansi-text.nix19
-rw-r--r--third_party/lisp/cl-base64.nix17
-rw-r--r--third_party/lisp/cl-colors2.nix21
-rw-r--r--third_party/lisp/cl-fad.nix27
-rw-r--r--third_party/lisp/cl-json.nix26
-rw-r--r--third_party/lisp/cl-plus-ssl.nix40
-rw-r--r--third_party/lisp/cl-ppcre.nix30
-rw-r--r--third_party/lisp/cl-prevalence.nix29
-rw-r--r--third_party/lisp/closer-mop.nix20
-rw-r--r--third_party/lisp/drakma.nix37
-rw-r--r--third_party/lisp/fiveam/.boring14
-rw-r--r--third_party/lisp/fiveam/.travis.yml47
-rw-r--r--third_party/lisp/fiveam/COPYING30
-rw-r--r--third_party/lisp/fiveam/README8
-rw-r--r--third_party/lisp/fiveam/default.nix28
-rw-r--r--third_party/lisp/fiveam/docs/make-qbook.lisp13
-rw-r--r--third_party/lisp/fiveam/fiveam.asd36
-rw-r--r--third_party/lisp/fiveam/src/check.lisp311
-rw-r--r--third_party/lisp/fiveam/src/classes.lisp128
-rw-r--r--third_party/lisp/fiveam/src/explain.lisp133
-rw-r--r--third_party/lisp/fiveam/src/fixture.lisp82
-rw-r--r--third_party/lisp/fiveam/src/package.lisp139
-rw-r--r--third_party/lisp/fiveam/src/random.lisp265
-rw-r--r--third_party/lisp/fiveam/src/run.lisp385
-rw-r--r--third_party/lisp/fiveam/src/style.css64
-rw-r--r--third_party/lisp/fiveam/src/suite.lisp140
-rw-r--r--third_party/lisp/fiveam/src/test.lisp167
-rw-r--r--third_party/lisp/fiveam/src/utils.lisp226
-rw-r--r--third_party/lisp/fiveam/t/example.lisp126
-rw-r--r--third_party/lisp/fiveam/t/tests.lisp280
-rw-r--r--third_party/lisp/fiveam/version.sexp2
-rw-r--r--third_party/lisp/flexi-streams.nix34
-rw-r--r--third_party/lisp/hunchentoot.nix61
-rw-r--r--third_party/lisp/iterate.nix15
-rw-r--r--third_party/lisp/lisp-binary.nix30
-rw-r--r--third_party/lisp/local-time.nix18
-rw-r--r--third_party/lisp/md5.nix16
-rw-r--r--third_party/lisp/moptilities.nix14
-rw-r--r--third_party/lisp/puri.nix15
-rw-r--r--third_party/lisp/quasiquote_2/README.md258
-rw-r--r--third_party/lisp/quasiquote_2/default.nix17
-rw-r--r--third_party/lisp/quasiquote_2/macros.lisp15
-rw-r--r--third_party/lisp/quasiquote_2/package.lisp11
-rw-r--r--third_party/lisp/quasiquote_2/quasiquote-2.0.asd30
-rw-r--r--third_party/lisp/quasiquote_2/quasiquote-2.0.lisp340
-rw-r--r--third_party/lisp/quasiquote_2/readers.lisp77
-rw-r--r--third_party/lisp/quasiquote_2/tests-macro.lisp21
-rw-r--r--third_party/lisp/quasiquote_2/tests.lisp143
-rw-r--r--third_party/lisp/rfc2388.nix17
-rw-r--r--third_party/lisp/s-sysdeps.nix17
-rw-r--r--third_party/lisp/s-xml/.gitignore28
-rw-r--r--third_party/lisp/s-xml/ChangeLog66
-rw-r--r--third_party/lisp/s-xml/Makefile35
-rw-r--r--third_party/lisp/s-xml/default.nix17
-rw-r--r--third_party/lisp/s-xml/examples/counter.lisp47
-rw-r--r--third_party/lisp/s-xml/examples/echo.lisp64
-rw-r--r--third_party/lisp/s-xml/examples/remove-markup.lisp21
-rw-r--r--third_party/lisp/s-xml/examples/tracer.lisp57
-rw-r--r--third_party/lisp/s-xml/s-xml.asd49
-rw-r--r--third_party/lisp/s-xml/src/dom.lisp75
-rw-r--r--third_party/lisp/s-xml/src/lxml-dom.lisp83
-rw-r--r--third_party/lisp/s-xml/src/package.lisp46
-rw-r--r--third_party/lisp/s-xml/src/sxml-dom.lisp76
-rw-r--r--third_party/lisp/s-xml/src/xml-struct-dom.lisp125
-rw-r--r--third_party/lisp/s-xml/src/xml.lisp702
-rw-r--r--third_party/lisp/s-xml/test/ant-build-file.xml252
-rw-r--r--third_party/lisp/s-xml/test/plist.xml38
-rw-r--r--third_party/lisp/s-xml/test/simple.xml5
-rw-r--r--third_party/lisp/s-xml/test/test-lxml-dom.lisp86
-rw-r--r--third_party/lisp/s-xml/test/test-sxml-dom.lisp76
-rw-r--r--third_party/lisp/s-xml/test/test-xml-struct-dom.lisp84
-rw-r--r--third_party/lisp/s-xml/test/test-xml.lisp86
-rw-r--r--third_party/lisp/s-xml/test/xhtml-page.xml271
-rw-r--r--third_party/lisp/split-sequence.nix18
-rw-r--r--third_party/lisp/trivial-backtrace/.gitignore15
-rw-r--r--third_party/lisp/trivial-backtrace/COPYING25
-rw-r--r--third_party/lisp/trivial-backtrace/default.nix14
-rw-r--r--third_party/lisp/trivial-backtrace/dev/backtrace.lisp127
-rw-r--r--third_party/lisp/trivial-backtrace/dev/fallback.lisp10
-rw-r--r--third_party/lisp/trivial-backtrace/dev/map-backtrace.lisp105
-rw-r--r--third_party/lisp/trivial-backtrace/dev/mucking.lisp75
-rw-r--r--third_party/lisp/trivial-backtrace/dev/packages.lisp13
-rw-r--r--third_party/lisp/trivial-backtrace/dev/utilities.lisp104
-rw-r--r--third_party/lisp/trivial-backtrace/lift-standard.config35
-rw-r--r--third_party/lisp/trivial-backtrace/test/packages.lisp5
-rw-r--r--third_party/lisp/trivial-backtrace/test/test-setup.lisp4
-rw-r--r--third_party/lisp/trivial-backtrace/test/tests.lisp17
-rw-r--r--third_party/lisp/trivial-backtrace/trivial-backtrace-test.asd22
-rw-r--r--third_party/lisp/trivial-backtrace/trivial-backtrace.asd35
-rw-r--r--third_party/lisp/trivial-backtrace/website/source/index.md88
-rw-r--r--third_party/lisp/trivial-backtrace/website/source/resources/footer.md15
-rw-r--r--third_party/lisp/trivial-backtrace/website/source/resources/header.md19
-rw-r--r--third_party/lisp/trivial-backtrace/website/source/resources/navigation.md2
-rw-r--r--third_party/lisp/trivial-backtrace/website/website.tmproj93
-rw-r--r--third_party/lisp/trivial-features.nix12
-rw-r--r--third_party/lisp/trivial-garbage.nix12
-rw-r--r--third_party/lisp/trivial-gray-streams.nix16
-rw-r--r--third_party/lisp/unix-opts.nix17
-rw-r--r--third_party/lisp/usocket.nix37
142 files changed, 14023 insertions, 0 deletions
diff --git a/third_party/lisp/alexandria/.boring b/third_party/lisp/alexandria/.boring
new file mode 100644
index 000000000000..dfa9e6dd7bb4
--- /dev/null
+++ b/third_party/lisp/alexandria/.boring
@@ -0,0 +1,13 @@
+# Boring file regexps:
+~$
+^_darcs
+^\{arch\}
+^.arch-ids
+\#
+\.dfsl$
+\.ppcf$
+\.fasl$
+\.x86f$
+\.fas$
+\.lib$
+^public_html
diff --git a/third_party/lisp/alexandria/.gitignore b/third_party/lisp/alexandria/.gitignore
new file mode 100644
index 000000000000..e832e9471833
--- /dev/null
+++ b/third_party/lisp/alexandria/.gitignore
@@ -0,0 +1,4 @@
+*.fasl
+*~
+\#*
+*.patch
diff --git a/third_party/lisp/alexandria/AUTHORS b/third_party/lisp/alexandria/AUTHORS
new file mode 100644
index 000000000000..b550ea503248
--- /dev/null
+++ b/third_party/lisp/alexandria/AUTHORS
@@ -0,0 +1,9 @@
+
+ACTA EST FABULA PLAUDITE
+
+Nikodemus Siivola 
+Attila Lendvai
+Marco Baringer
+Robert Strandh
+Luis Oliveira
+Tobias C. Rittweiler
\ No newline at end of file
diff --git a/third_party/lisp/alexandria/LICENCE b/third_party/lisp/alexandria/LICENCE
new file mode 100644
index 000000000000..b5140fbb2491
--- /dev/null
+++ b/third_party/lisp/alexandria/LICENCE
@@ -0,0 +1,37 @@
+Alexandria software and associated documentation are in the public
+domain:
+
+  Authors dedicate this work to public domain, for the benefit of the
+  public at large and to the detriment of the authors' heirs and
+  successors. Authors intends this dedication to be an overt act of
+  relinquishment in perpetuity of all present and future rights under
+  copyright law, whether vested or contingent, in the work. Authors
+  understands that such relinquishment of all rights includes the
+  relinquishment of all rights to enforce (by lawsuit or otherwise)
+  those copyrights in the work.
+
+  Authors recognize that, once placed in the public domain, the work
+  may be freely reproduced, distributed, transmitted, used, modified,
+  built upon, or otherwise exploited by anyone for any purpose,
+  commercial or non-commercial, and in any way, including by methods
+  that have not yet been invented or conceived.
+
+In those legislations where public domain dedications are not
+recognized or possible, Alexandria is distributed under the following
+terms and conditions:
+
+  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 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.
diff --git a/third_party/lisp/alexandria/README b/third_party/lisp/alexandria/README
new file mode 100644
index 000000000000..a5dae9ed1ac7
--- /dev/null
+++ b/third_party/lisp/alexandria/README
@@ -0,0 +1,52 @@
+Alexandria is a collection of portable public domain utilities that
+meet the following constraints:
+
+ * Utilities, not extensions: Alexandria will not contain conceptual
+   extensions to Common Lisp, instead limiting itself to tools and
+   utilities that fit well within the framework of standard ANSI
+   Common Lisp. Test-frameworks, system definitions, logging
+   facilities, serialization layers, etc. are all outside the scope of
+   Alexandria as a library, though well within the scope of Alexandria
+   as a project.
+
+ * Conservative: Alexandria limits itself to what project members
+   consider conservative utilities. Alexandria does not and will not
+   include anaphoric constructs, loop-like binding macros, etc.
+
+ * Portable: Alexandria limits itself to portable parts of Common
+   Lisp. Even apparently conservative and useful functions remain
+   outside the scope of Alexandria if they cannot be implemented
+   portably. Portability is here defined as portable within a
+   conforming implementation: implementation bugs are not considered
+   portability issues.
+
+Homepage:
+
+  http://common-lisp.net/project/alexandria/
+
+Mailing lists:
+
+  http://lists.common-lisp.net/mailman/listinfo/alexandria-devel
+  http://lists.common-lisp.net/mailman/listinfo/alexandria-cvs
+
+Repository:
+
+  git://gitlab.common-lisp.net/alexandria/alexandria.git
+
+Documentation:
+
+  http://common-lisp.net/project/alexandria/draft/alexandria.html
+
+  (To build docs locally: cd doc && make html pdf info)
+
+Patches:
+
+  Patches are always welcome! Please send them to the mailing list as
+  attachments, generated by "git format-patch -1".
+
+  Patches should include a commit message that explains what's being
+  done and /why/, and when fixing a bug or adding a feature you should
+  also include a test-case.
+
+  Be advised though that right now new features are unlikely to be
+  accepted until 1.0 is officially out of the door.
diff --git a/third_party/lisp/alexandria/alexandria-tests.asd b/third_party/lisp/alexandria/alexandria-tests.asd
new file mode 100644
index 000000000000..445c18cf7f77
--- /dev/null
+++ b/third_party/lisp/alexandria/alexandria-tests.asd
@@ -0,0 +1,11 @@
+(defsystem "alexandria-tests"
+  :licence "Public Domain / 0-clause MIT"
+  :description "Tests for Alexandria, which is a collection of portable public domain utilities."
+  :author "Nikodemus Siivola <nikodemus@sb-studio.net>, and others."
+  :depends-on (:alexandria #+sbcl :sb-rt #-sbcl :rt)
+  :components ((:file "tests"))
+  :perform (test-op (o c)
+             (flet ((run-tests (&rest args)
+                      (apply (intern (string '#:run-tests) '#:alexandria-tests) args)))
+               (run-tests :compiled nil)
+               (run-tests :compiled t))))
diff --git a/third_party/lisp/alexandria/alexandria.asd b/third_party/lisp/alexandria/alexandria.asd
new file mode 100644
index 000000000000..db10e4f53710
--- /dev/null
+++ b/third_party/lisp/alexandria/alexandria.asd
@@ -0,0 +1,62 @@
+(defsystem "alexandria"
+  :version "1.0.0"
+  :licence "Public Domain / 0-clause MIT"
+  :description "Alexandria is a collection of portable public domain utilities."
+  :author "Nikodemus Siivola and others."
+  :long-description
+  "Alexandria is a project and a library.
+
+As a project Alexandria's goal is to reduce duplication of effort and improve
+portability of Common Lisp code according to its own idiosyncratic and rather
+conservative aesthetic.
+
+As a library Alexandria is one of the means by which the project strives for
+its goals.
+
+Alexandria is a collection of portable public domain utilities that meet
+the following constraints:
+
+ * Utilities, not extensions: Alexandria will not contain conceptual
+   extensions to Common Lisp, instead limiting itself to tools and utilities
+   that fit well within the framework of standard ANSI Common Lisp.
+   Test-frameworks, system definitions, logging facilities, serialization
+   layers, etc. are all outside the scope of Alexandria as a library, though
+   well within the scope of Alexandria as a project.
+
+ * Conservative: Alexandria limits itself to what project members consider
+   conservative utilities. Alexandria does not and will not include anaphoric
+   constructs, loop-like binding macros, etc.
+   Also, its exported symbols are being imported by many other packages
+   already, so each new export carries the danger of causing conflicts.
+
+ * Portable: Alexandria limits itself to portable parts of Common Lisp. Even
+   apparently conservative and useful functions remain outside the scope of
+   Alexandria if they cannot be implemented portably. Portability is here
+   defined as portable within a conforming implementation: implementation bugs
+   are not considered portability issues.
+
+ * Team player: Alexandria will not (initially, at least) subsume or provide
+   functionality for which good-quality special-purpose packages exist, like
+   split-sequence. Instead, third party packages such as that may be
+   \"blessed\"."
+  :components
+  ((:static-file "LICENCE")
+   (:static-file "tests.lisp")
+   (:file "package")
+   (:file "definitions" :depends-on ("package"))
+   (:file "binding" :depends-on ("package"))
+   (:file "strings" :depends-on ("package"))
+   (:file "conditions" :depends-on ("package"))
+   (:file "io" :depends-on ("package" "macros" "lists" "types"))
+   (:file "macros" :depends-on ("package" "strings" "symbols"))
+   (:file "hash-tables" :depends-on ("package" "macros"))
+   (:file "control-flow" :depends-on ("package" "definitions" "macros"))
+   (:file "symbols" :depends-on ("package"))
+   (:file "functions" :depends-on ("package" "symbols" "macros"))
+   (:file "lists" :depends-on ("package" "functions"))
+   (:file "types" :depends-on ("package" "symbols" "lists"))
+   (:file "arrays" :depends-on ("package" "types"))
+   (:file "sequences" :depends-on ("package" "lists" "types"))
+   (:file "numbers" :depends-on ("package" "sequences"))
+   (:file "features" :depends-on ("package" "control-flow")))
+  :in-order-to ((test-op (test-op "alexandria-tests"))))
diff --git a/third_party/lisp/alexandria/arrays.lisp b/third_party/lisp/alexandria/arrays.lisp
new file mode 100644
index 000000000000..76c18791ad5f
--- /dev/null
+++ b/third_party/lisp/alexandria/arrays.lisp
@@ -0,0 +1,18 @@
+(in-package :alexandria)
+
+(defun copy-array (array &key (element-type (array-element-type array))
+                              (fill-pointer (and (array-has-fill-pointer-p array)
+                                                 (fill-pointer array)))
+                              (adjustable (adjustable-array-p array)))
+  "Returns an undisplaced copy of ARRAY, with same fill-pointer and
+adjustability (if any) as the original, unless overridden by the keyword
+arguments."
+ (let* ((dimensions (array-dimensions array))
+        (new-array (make-array dimensions
+                               :element-type element-type
+                               :adjustable adjustable
+                               :fill-pointer fill-pointer)))
+   (dotimes (i (array-total-size array))
+     (setf (row-major-aref new-array i)
+           (row-major-aref array i)))
+   new-array))
diff --git a/third_party/lisp/alexandria/binding.lisp b/third_party/lisp/alexandria/binding.lisp
new file mode 100644
index 000000000000..37a3d52fb9f0
--- /dev/null
+++ b/third_party/lisp/alexandria/binding.lisp
@@ -0,0 +1,90 @@
+(in-package :alexandria)
+
+(defmacro if-let (bindings &body (then-form &optional else-form))
+    "Creates new variable bindings, and conditionally executes either
+THEN-FORM or ELSE-FORM. ELSE-FORM defaults to NIL.
+
+BINDINGS must be either single binding of the form:
+
+ (variable initial-form)
+
+or a list of bindings of the form:
+
+ ((variable-1 initial-form-1)
+  (variable-2 initial-form-2)
+  ...
+  (variable-n initial-form-n))
+
+All initial-forms are executed sequentially in the specified order. Then all
+the variables are bound to the corresponding values.
+
+If all variables were bound to true values, the THEN-FORM is executed with the
+bindings in effect, otherwise the ELSE-FORM is executed with the bindings in
+effect."
+    (let* ((binding-list (if (and (consp bindings) (symbolp (car bindings)))
+                             (list bindings)
+                             bindings))
+         (variables (mapcar #'car binding-list)))
+    `(let ,binding-list
+       (if (and ,@variables)
+           ,then-form
+           ,else-form))))
+
+(defmacro when-let (bindings &body forms)
+    "Creates new variable bindings, and conditionally executes FORMS.
+
+BINDINGS must be either single binding of the form:
+
+ (variable initial-form)
+
+or a list of bindings of the form:
+
+ ((variable-1 initial-form-1)
+  (variable-2 initial-form-2)
+  ...
+  (variable-n initial-form-n))
+
+All initial-forms are executed sequentially in the specified order. Then all
+the variables are bound to the corresponding values.
+
+If all variables were bound to true values, then FORMS are executed as an
+implicit PROGN."
+  (let* ((binding-list (if (and (consp bindings) (symbolp (car bindings)))
+                           (list bindings)
+                           bindings))
+         (variables (mapcar #'car binding-list)))
+    `(let ,binding-list
+       (when (and ,@variables)
+         ,@forms))))
+
+(defmacro when-let* (bindings &body body)
+  "Creates new variable bindings, and conditionally executes BODY.
+
+BINDINGS must be either single binding of the form:
+
+ (variable initial-form)
+
+or a list of bindings of the form:
+
+ ((variable-1 initial-form-1)
+  (variable-2 initial-form-2)
+  ...
+  (variable-n initial-form-n))
+
+Each INITIAL-FORM is executed in turn, and the variable bound to the
+corresponding value. INITIAL-FORM expressions can refer to variables
+previously bound by the WHEN-LET*.
+
+Execution of WHEN-LET* stops immediately if any INITIAL-FORM evaluates to NIL.
+If all INITIAL-FORMs evaluate to true, then BODY is executed as an implicit
+PROGN."
+  (let ((binding-list (if (and (consp bindings) (symbolp (car bindings)))
+                          (list bindings)
+                          bindings)))
+    (labels ((bind (bindings body)
+               (if bindings
+                   `(let (,(car bindings))
+                      (when ,(caar bindings)
+                        ,(bind (cdr bindings) body)))
+                   `(progn ,@body))))
+      (bind binding-list body))))
diff --git a/third_party/lisp/alexandria/conditions.lisp b/third_party/lisp/alexandria/conditions.lisp
new file mode 100644
index 000000000000..ac471cca7e4c
--- /dev/null
+++ b/third_party/lisp/alexandria/conditions.lisp
@@ -0,0 +1,91 @@
+(in-package :alexandria)
+
+(defun required-argument (&optional name)
+  "Signals an error for a missing argument of NAME. Intended for
+use as an initialization form for structure and class-slots, and
+a default value for required keyword arguments."
+  (error "Required argument ~@[~S ~]missing." name))
+
+(define-condition simple-style-warning (simple-warning style-warning)
+  ())
+
+(defun simple-style-warning (message &rest args)
+  (warn 'simple-style-warning :format-control message :format-arguments args))
+
+;; We don't specify a :report for simple-reader-error to let the
+;; underlying implementation report the line and column position for
+;; us. Unfortunately this way the message from simple-error is not
+;; displayed, unless there's special support for that in the
+;; implementation. But even then it's still inspectable from the
+;; debugger...
+(define-condition simple-reader-error
+    #-sbcl(simple-error reader-error)
+    #+sbcl(sb-int:simple-reader-error)
+  ())
+
+(defun simple-reader-error (stream message &rest args)
+  (error 'simple-reader-error
+         :stream stream
+         :format-control message
+         :format-arguments args))
+
+(define-condition simple-parse-error (simple-error parse-error)
+  ())
+
+(defun simple-parse-error (message &rest args)
+  (error 'simple-parse-error
+         :format-control message
+         :format-arguments args))
+
+(define-condition simple-program-error (simple-error program-error)
+  ())
+
+(defun simple-program-error (message &rest args)
+  (error 'simple-program-error
+         :format-control message
+         :format-arguments args))
+
+(defmacro ignore-some-conditions ((&rest conditions) &body body)
+  "Similar to CL:IGNORE-ERRORS but the (unevaluated) CONDITIONS
+list determines which specific conditions are to be ignored."
+  `(handler-case
+       (progn ,@body)
+     ,@(loop for condition in conditions collect
+             `(,condition (c) (values nil c)))))
+
+(defmacro unwind-protect-case ((&optional abort-flag) protected-form &body clauses)
+  "Like CL:UNWIND-PROTECT, but you can specify the circumstances that
+the cleanup CLAUSES are run.
+
+  clauses ::= (:NORMAL form*)* | (:ABORT form*)* | (:ALWAYS form*)*
+
+Clauses can be given in any order, and more than one clause can be
+given for each circumstance. The clauses whose denoted circumstance
+occured, are executed in the order the clauses appear.
+
+ABORT-FLAG is the name of a variable that will be bound to T in
+CLAUSES if the PROTECTED-FORM aborted preemptively, and to NIL
+otherwise.
+
+Examples:
+
+  (unwind-protect-case ()
+       (protected-form)
+     (:normal (format t \"This is only evaluated if PROTECTED-FORM executed normally.~%\"))
+     (:abort  (format t \"This is only evaluated if PROTECTED-FORM aborted preemptively.~%\"))
+     (:always (format t \"This is evaluated in either case.~%\")))
+
+  (unwind-protect-case (aborted-p)
+       (protected-form)
+     (:always (perform-cleanup-if aborted-p)))
+"
+  (check-type abort-flag (or null symbol))
+  (let ((gflag (gensym "FLAG+")))
+    `(let ((,gflag t))
+       (unwind-protect (multiple-value-prog1 ,protected-form (setf ,gflag nil))
+	 (let ,(and abort-flag `((,abort-flag ,gflag)))
+	   ,@(loop for (cleanup-kind . forms) in clauses
+		   collect (ecase cleanup-kind
+			     (:normal `(when (not ,gflag) ,@forms))
+			     (:abort  `(when ,gflag ,@forms))
+			     (:always `(progn ,@forms)))))))))
\ No newline at end of file
diff --git a/third_party/lisp/alexandria/control-flow.lisp b/third_party/lisp/alexandria/control-flow.lisp
new file mode 100644
index 000000000000..dd00df3e1620
--- /dev/null
+++ b/third_party/lisp/alexandria/control-flow.lisp
@@ -0,0 +1,106 @@
+(in-package :alexandria)
+
+(defun extract-function-name (spec)
+  "Useful for macros that want to mimic the functional interface for functions
+like #'eq and 'eq."
+  (if (and (consp spec)
+           (member (first spec) '(quote function)))
+      (second spec)
+      spec))
+
+(defun generate-switch-body (whole object clauses test key &optional default)
+  (with-gensyms (value)
+    (setf test (extract-function-name test))
+    (setf key (extract-function-name key))
+    (when (and (consp default)
+               (member (first default) '(error cerror)))
+      (setf default `(,@default "No keys match in SWITCH. Testing against ~S with ~S."
+                      ,value ',test)))
+    `(let ((,value (,key ,object)))
+      (cond ,@(mapcar (lambda (clause)
+                        (if (member (first clause) '(t otherwise))
+                            (progn
+                              (when default
+                                (error "Multiple default clauses or illegal use of a default clause in ~S."
+                                       whole))
+                              (setf default `(progn ,@(rest clause)))
+                              '(()))
+                            (destructuring-bind (key-form &body forms) clause
+                              `((,test ,value ,key-form)
+                                ,@forms))))
+                      clauses)
+            (t ,default)))))
+
+(defmacro switch (&whole whole (object &key (test 'eql) (key 'identity))
+                         &body clauses)
+  "Evaluates first matching clause, returning its values, or evaluates and
+returns the values of T or OTHERWISE if no keys match."
+  (generate-switch-body whole object clauses test key))
+
+(defmacro eswitch (&whole whole (object &key (test 'eql) (key 'identity))
+                          &body clauses)
+  "Like SWITCH, but signals an error if no key matches."
+  (generate-switch-body whole object clauses test key '(error)))
+
+(defmacro cswitch (&whole whole (object &key (test 'eql) (key 'identity))
+                          &body clauses)
+  "Like SWITCH, but signals a continuable error if no key matches."
+  (generate-switch-body whole object clauses test key '(cerror "Return NIL from CSWITCH.")))
+
+(defmacro whichever (&rest possibilities &environment env)
+  "Evaluates exactly one of POSSIBILITIES, chosen at random."
+  (setf possibilities (mapcar (lambda (p) (macroexpand p env)) possibilities))
+  (if (every (lambda (p) (constantp p)) possibilities)
+      `(svref (load-time-value (vector ,@possibilities)) (random ,(length possibilities)))
+      (labels ((expand (possibilities position random-number)
+                 (if (null (cdr possibilities))
+                     (car possibilities)
+                     (let* ((length (length possibilities))
+                            (half (truncate length 2))
+                            (second-half (nthcdr half possibilities))
+                            (first-half (butlast possibilities (- length half))))
+                       `(if (< ,random-number ,(+ position half))
+                            ,(expand first-half position random-number)
+                            ,(expand second-half (+ position half) random-number))))))
+        (with-gensyms (random-number)
+          (let ((length (length possibilities)))
+            `(let ((,random-number (random ,length)))
+               ,(expand possibilities 0 random-number)))))))
+
+(defmacro xor (&rest datums)
+  "Evaluates its arguments one at a time, from left to right. If more than one
+argument evaluates to a true value no further DATUMS are evaluated, and NIL is
+returned as both primary and secondary value. If exactly one argument
+evaluates to true, its value is returned as the primary value after all the
+arguments have been evaluated, and T is returned as the secondary value. If no
+arguments evaluate to true NIL is retuned as primary, and T as secondary
+value."
+  (with-gensyms (xor tmp true)
+    `(let (,tmp ,true)
+       (block ,xor
+         ,@(mapcar (lambda (datum)
+                     `(if (setf ,tmp ,datum)
+                          (if ,true
+                              (return-from ,xor (values nil nil))
+                              (setf ,true ,tmp))))
+                   datums)
+         (return-from ,xor (values ,true t))))))
+
+(defmacro nth-value-or (nth-value &body forms)
+  "Evaluates FORM arguments one at a time, until the NTH-VALUE returned by one
+of the forms is true. It then returns all the values returned by evaluating
+that form. If none of the forms return a true nth value, this form returns
+NIL."
+  (once-only (nth-value)
+    (with-gensyms (values)
+      `(let ((,values (multiple-value-list ,(first forms))))
+         (if (nth ,nth-value ,values)
+             (values-list ,values)
+             ,(if (rest forms)
+                  `(nth-value-or ,nth-value ,@(rest forms))
+                  nil))))))
+
+(defmacro multiple-value-prog2 (first-form second-form &body forms)
+  "Evaluates FIRST-FORM, then SECOND-FORM, and then FORMS. Yields as its value
+all the value returned by SECOND-FORM."
+  `(progn ,first-form (multiple-value-prog1 ,second-form ,@forms)))
diff --git a/third_party/lisp/alexandria/default.nix b/third_party/lisp/alexandria/default.nix
new file mode 100644
index 000000000000..2358c898b3ab
--- /dev/null
+++ b/third_party/lisp/alexandria/default.nix
@@ -0,0 +1,28 @@
+# Alexandria is one of the foundational Common Lisp libraries that
+# pretty much everything depends on:
+#
+# Imported from https://common-lisp.net/project/alexandria/
+{ depot, ... }:
+
+depot.nix.buildLisp.library {
+  name = "alexandria";
+  srcs = [
+    ./package.lisp
+    ./definitions.lisp
+    ./binding.lisp
+    ./strings.lisp
+    ./conditions.lisp
+    ./symbols.lisp
+    ./macros.lisp
+    ./functions.lisp
+    ./io.lisp
+    ./hash-tables.lisp
+    ./control-flow.lisp
+    ./lists.lisp
+    ./types.lisp
+    ./arrays.lisp
+    ./sequences.lisp
+    ./numbers.lisp
+    ./features.lisp
+  ];
+}
diff --git a/third_party/lisp/alexandria/definitions.lisp b/third_party/lisp/alexandria/definitions.lisp
new file mode 100644
index 000000000000..863e1f696286
--- /dev/null
+++ b/third_party/lisp/alexandria/definitions.lisp
@@ -0,0 +1,37 @@
+(in-package :alexandria)
+
+(defun %reevaluate-constant (name value test)
+  (if (not (boundp name))
+      value
+      (let ((old (symbol-value name))
+            (new value))
+        (if (not (constantp name))
+            (prog1 new
+              (cerror "Try to redefine the variable as a constant."
+                      "~@<~S is an already bound non-constant variable ~
+                       whose value is ~S.~:@>" name old))
+            (if (funcall test old new)
+                old
+                (restart-case
+                    (error "~@<~S is an already defined constant whose value ~
+                              ~S is not equal to the provided initial value ~S ~
+                              under ~S.~:@>" name old new test)
+                  (ignore ()
+                    :report "Retain the current value."
+                    old)
+                  (continue ()
+                    :report "Try to redefine the constant."
+                    new)))))))
+
+(defmacro define-constant (name initial-value &key (test ''eql) documentation)
+  "Ensures that the global variable named by NAME is a constant with a value
+that is equal under TEST to the result of evaluating INITIAL-VALUE. TEST is a
+/function designator/ that defaults to EQL. If DOCUMENTATION is given, it
+becomes the documentation string of the constant.
+
+Signals an error if NAME is already a bound non-constant variable.
+
+Signals an error if NAME is already a constant variable whose value is not
+equal under TEST to result of evaluating INITIAL-VALUE."
+  `(defconstant ,name (%reevaluate-constant ',name ,initial-value ,test)
+     ,@(when documentation `(,documentation))))
diff --git a/third_party/lisp/alexandria/doc/.gitignore b/third_party/lisp/alexandria/doc/.gitignore
new file mode 100644
index 000000000000..f22577b3ac86
--- /dev/null
+++ b/third_party/lisp/alexandria/doc/.gitignore
@@ -0,0 +1,3 @@
+alexandria
+include
+
diff --git a/third_party/lisp/alexandria/doc/Makefile b/third_party/lisp/alexandria/doc/Makefile
new file mode 100644
index 000000000000..85eb818220d5
--- /dev/null
+++ b/third_party/lisp/alexandria/doc/Makefile
@@ -0,0 +1,28 @@
+.PHONY: clean html pdf include clean-include clean-crap info doc
+
+doc: pdf html info clean-crap
+
+clean-include:
+	rm -rf include
+
+clean-crap:
+	rm -f *.aux *.cp *.fn *.fns *.ky *.log *.pg *.toc *.tp *.tps *.vr
+
+clean: clean-include
+	rm -f  *.pdf *.html *.info
+
+include:
+	sbcl --no-userinit --eval '(require :asdf)' \
+	--eval '(let ((asdf:*central-registry* (list "../"))) (require :alexandria))' \
+	--load docstrings.lisp \
+	--eval '(sb-texinfo:generate-includes "include/" (list :alexandria) :base-package :alexandria)' \
+	--eval '(quit)'
+
+pdf: include
+	texi2pdf alexandria.texinfo
+
+html: include
+	makeinfo --html --no-split alexandria.texinfo
+
+info: include
+	makeinfo alexandria.texinfo
diff --git a/third_party/lisp/alexandria/doc/alexandria.texinfo b/third_party/lisp/alexandria/doc/alexandria.texinfo
new file mode 100644
index 000000000000..89b03ac34967
--- /dev/null
+++ b/third_party/lisp/alexandria/doc/alexandria.texinfo
@@ -0,0 +1,277 @@
+\input texinfo   @c -*-texinfo-*-
+@c %**start of header
+@setfilename alexandria.info
+@settitle Alexandria Manual
+@c %**end of header
+
+@settitle Alexandria Manual -- draft version
+
+@c for install-info
+@dircategory Software development
+@direntry
+* alexandria:           Common Lisp utilities.
+@end direntry
+
+@copying
+Alexandria software and associated documentation are in the public
+domain:
+
+@quotation
+  Authors dedicate this work to public domain, for the benefit of the
+  public at large and to the detriment of the authors' heirs and
+  successors. Authors intends this dedication to be an overt act of
+  relinquishment in perpetuity of all present and future rights under
+  copyright law, whether vested or contingent, in the work. Authors
+  understands that such relinquishment of all rights includes the
+  relinquishment of all rights to enforce (by lawsuit or otherwise)
+  those copyrights in the work.
+
+  Authors recognize that, once placed in the public domain, the work
+  may be freely reproduced, distributed, transmitted, used, modified,
+  built upon, or otherwise exploited by anyone for any purpose,
+  commercial or non-commercial, and in any way, including by methods
+  that have not yet been invented or conceived.
+@end quotation
+
+In those legislations where public domain dedications are not
+recognized or possible, Alexandria is distributed under the following
+terms and conditions:
+
+@quotation
+  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 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.
+@end quotation
+@end copying
+
+@titlepage
+
+@title Alexandria Manual
+@subtitle draft version
+
+@c The following two commands start the copyright page.
+@page
+@vskip 0pt plus 1filll
+@insertcopying
+
+@end titlepage
+
+@contents
+
+@ifnottex
+
+@include include/ifnottex.texinfo
+
+@node Top
+@comment  node-name,  next,  previous,  up
+@top Alexandria
+
+@insertcopying
+
+@menu
+* Hash Tables::
+* Data and Control Flow::
+* Conses::
+* Sequences::
+* IO::
+* Macro Writing::
+* Symbols::
+* Arrays::
+* Types::
+* Numbers::
+@end menu
+
+@end ifnottex
+
+@node Hash Tables
+@comment  node-name,  next,  previous,  up
+@chapter Hash Tables
+
+@include include/macro-alexandria-ensure-gethash.texinfo
+@include include/fun-alexandria-copy-hash-table.texinfo
+@include include/fun-alexandria-maphash-keys.texinfo
+@include include/fun-alexandria-maphash-values.texinfo
+@include include/fun-alexandria-hash-table-keys.texinfo
+@include include/fun-alexandria-hash-table-values.texinfo
+@include include/fun-alexandria-hash-table-alist.texinfo
+@include include/fun-alexandria-hash-table-plist.texinfo
+@include include/fun-alexandria-alist-hash-table.texinfo
+@include include/fun-alexandria-plist-hash-table.texinfo
+
+@node Data and Control Flow
+@comment  node-name,  next,  previous,  up
+@chapter Data and Control Flow
+
+@include include/macro-alexandria-define-constant.texinfo
+@include include/macro-alexandria-destructuring-case.texinfo
+@include include/macro-alexandria-ensure-functionf.texinfo
+@include include/macro-alexandria-multiple-value-prog2.texinfo
+@include include/macro-alexandria-named-lambda.texinfo
+@include include/macro-alexandria-nth-value-or.texinfo
+@include include/macro-alexandria-if-let.texinfo
+@include include/macro-alexandria-when-let.texinfo
+@include include/macro-alexandria-when-let-star.texinfo
+@include include/macro-alexandria-switch.texinfo
+@include include/macro-alexandria-cswitch.texinfo
+@include include/macro-alexandria-eswitch.texinfo
+@include include/macro-alexandria-whichever.texinfo
+@include include/macro-alexandria-xor.texinfo
+
+@include include/fun-alexandria-disjoin.texinfo
+@include include/fun-alexandria-conjoin.texinfo
+@include include/fun-alexandria-compose.texinfo
+@include include/fun-alexandria-ensure-function.texinfo
+@include include/fun-alexandria-multiple-value-compose.texinfo
+@include include/fun-alexandria-curry.texinfo
+@include include/fun-alexandria-rcurry.texinfo
+
+@node Conses
+@comment  node-name,  next,  previous,  up
+@chapter Conses
+
+@include include/type-alexandria-proper-list.texinfo
+@include include/type-alexandria-circular-list.texinfo
+
+@include include/macro-alexandria-appendf.texinfo
+@include include/macro-alexandria-nconcf.texinfo
+@include include/macro-alexandria-remove-from-plistf.texinfo
+@include include/macro-alexandria-delete-from-plistf.texinfo
+@include include/macro-alexandria-reversef.texinfo
+@include include/macro-alexandria-nreversef.texinfo
+@include include/macro-alexandria-unionf.texinfo
+@include include/macro-alexandria-nunionf.texinfo
+
+@include include/macro-alexandria-doplist.texinfo
+
+@include include/fun-alexandria-circular-list-p.texinfo
+@include include/fun-alexandria-circular-tree-p.texinfo
+@include include/fun-alexandria-proper-list-p.texinfo
+
+@include include/fun-alexandria-alist-plist.texinfo
+@include include/fun-alexandria-plist-alist.texinfo
+@include include/fun-alexandria-circular-list.texinfo
+@include include/fun-alexandria-make-circular-list.texinfo
+@include include/fun-alexandria-ensure-car.texinfo
+@include include/fun-alexandria-ensure-cons.texinfo
+@include include/fun-alexandria-ensure-list.texinfo
+@include include/fun-alexandria-flatten.texinfo
+@include include/fun-alexandria-lastcar.texinfo
+@include include/fun-alexandria-setf-lastcar.texinfo
+@include include/fun-alexandria-proper-list-length.texinfo
+@include include/fun-alexandria-mappend.texinfo
+@include include/fun-alexandria-map-product.texinfo
+@include include/fun-alexandria-remove-from-plist.texinfo
+@include include/fun-alexandria-delete-from-plist.texinfo
+@include include/fun-alexandria-set-equal.texinfo
+@include include/fun-alexandria-setp.texinfo
+
+@node Sequences
+@comment  node-name,  next,  previous,  up
+@chapter Sequences
+
+@include include/type-alexandria-proper-sequence.texinfo
+
+@include include/macro-alexandria-deletef.texinfo
+@include include/macro-alexandria-removef.texinfo
+
+@include include/fun-alexandria-rotate.texinfo
+@include include/fun-alexandria-shuffle.texinfo
+@include include/fun-alexandria-random-elt.texinfo
+@include include/fun-alexandria-emptyp.texinfo
+@include include/fun-alexandria-sequence-of-length-p.texinfo
+@include include/fun-alexandria-length-equals.texinfo
+@include include/fun-alexandria-copy-sequence.texinfo
+@include include/fun-alexandria-first-elt.texinfo
+@include include/fun-alexandria-setf-first-elt.texinfo
+@include include/fun-alexandria-last-elt.texinfo
+@include include/fun-alexandria-setf-last-elt.texinfo
+@include include/fun-alexandria-starts-with.texinfo
+@include include/fun-alexandria-starts-with-subseq.texinfo
+@include include/fun-alexandria-ends-with.texinfo
+@include include/fun-alexandria-ends-with-subseq.texinfo
+@include include/fun-alexandria-map-combinations.texinfo
+@include include/fun-alexandria-map-derangements.texinfo
+@include include/fun-alexandria-map-permutations.texinfo
+
+@node IO
+@comment  node-name,   next,  previous,  up
+@chapter IO
+
+@include include/fun-alexandria-read-stream-content-into-string.texinfo
+@include include/fun-alexandria-read-file-into-string.texinfo
+@include include/fun-alexandria-read-stream-content-into-byte-vector.texinfo
+@include include/fun-alexandria-read-file-into-byte-vector.texinfo
+
+@node Macro Writing
+@comment  node-name,  next,  previous,  up
+@chapter Macro Writing
+
+@include include/macro-alexandria-once-only.texinfo
+@include include/macro-alexandria-with-gensyms.texinfo
+@include include/macro-alexandria-with-unique-names.texinfo
+@include include/fun-alexandria-featurep.texinfo
+@include include/fun-alexandria-parse-body.texinfo
+@include include/fun-alexandria-parse-ordinary-lambda-list.texinfo
+
+@node Symbols
+@comment  node-name,  next,  previous,  up
+@chapter Symbols
+
+@include include/fun-alexandria-ensure-symbol.texinfo
+@include include/fun-alexandria-format-symbol.texinfo
+@include include/fun-alexandria-make-keyword.texinfo
+@include include/fun-alexandria-make-gensym.texinfo
+@include include/fun-alexandria-make-gensym-list.texinfo
+@include include/fun-alexandria-symbolicate.texinfo
+
+@node Arrays
+@comment  node-name,  next,  previous,  up
+@chapter Arrays
+
+@include include/type-alexandria-array-index.texinfo
+@include include/type-alexandria-array-length.texinfo
+@include include/fun-alexandria-copy-array.texinfo
+
+@node Types
+@comment  node-name,  next,  previous,  up
+@chapter Types
+
+@include include/type-alexandria-string-designator.texinfo
+@include include/macro-alexandria-coercef.texinfo
+@include include/fun-alexandria-of-type.texinfo
+@include include/fun-alexandria-type-equals.texinfo
+
+@node Numbers
+@comment  node-name,  next,  previous,  up
+@chapter Numbers
+
+@include include/macro-alexandria-maxf.texinfo
+@include include/macro-alexandria-minf.texinfo
+
+@include include/fun-alexandria-binomial-coefficient.texinfo
+@include include/fun-alexandria-count-permutations.texinfo
+@include include/fun-alexandria-clamp.texinfo
+@include include/fun-alexandria-lerp.texinfo
+@include include/fun-alexandria-factorial.texinfo
+@include include/fun-alexandria-subfactorial.texinfo
+@include include/fun-alexandria-gaussian-random.texinfo
+@include include/fun-alexandria-iota.texinfo
+@include include/fun-alexandria-map-iota.texinfo
+@include include/fun-alexandria-mean.texinfo
+@include include/fun-alexandria-median.texinfo
+@include include/fun-alexandria-variance.texinfo
+@include include/fun-alexandria-standard-deviation.texinfo
+
+@bye
diff --git a/third_party/lisp/alexandria/doc/docstrings.lisp b/third_party/lisp/alexandria/doc/docstrings.lisp
new file mode 100644
index 000000000000..51dda07d09b7
--- /dev/null
+++ b/third_party/lisp/alexandria/doc/docstrings.lisp
@@ -0,0 +1,881 @@
+;;; -*- lisp -*-
+
+;;;; A docstring extractor for the sbcl manual.  Creates
+;;;; @include-ready documentation from the docstrings of exported
+;;;; symbols of specified packages.
+
+;;;; This software is part of the SBCL software system. SBCL is in the
+;;;; public domain and is provided with absolutely no warranty. See
+;;;; the COPYING file for more information.
+;;;;
+;;;; Written by Rudi Schlatte <rudi@constantly.at>, mangled
+;;;; by Nikodemus Siivola.
+
+;;;; TODO
+;;;; * Verbatim text
+;;;; * Quotations
+;;;; * Method documentation untested
+;;;; * Method sorting, somehow
+;;;; * Index for macros & constants?
+;;;; * This is getting complicated enough that tests would be good
+;;;; * Nesting (currently only nested itemizations work)
+;;;; * doc -> internal form -> texinfo (so that non-texinfo format are also
+;;;;   easily generated)
+
+;;;; FIXME: The description below is no longer complete. This
+;;;; should possibly be turned into a contrib with proper documentation.
+
+;;;; Formatting heuristics (tweaked to format SAVE-LISP-AND-DIE sanely):
+;;;;
+;;;; Formats SYMBOL as @code{symbol}, or @var{symbol} if symbol is in
+;;;; the argument list of the defun / defmacro.
+;;;;
+;;;; Lines starting with * or - that are followed by intented lines
+;;;; are marked up with @itemize.
+;;;;
+;;;; Lines containing only a SYMBOL that are followed by indented
+;;;; lines are marked up as @table @code, with the SYMBOL as the item.
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (require 'sb-introspect))
+
+(defpackage :sb-texinfo
+  (:use :cl :sb-mop)
+  (:shadow #:documentation)
+  (:export #:generate-includes #:document-package)
+  (:documentation
+   "Tools to generate TexInfo documentation from docstrings."))
+
+(in-package :sb-texinfo)
+
+;;;; various specials and parameters
+
+(defvar *texinfo-output*)
+(defvar *texinfo-variables*)
+(defvar *documentation-package*)
+(defvar *base-package*)
+
+(defparameter *undocumented-packages* '(sb-pcl sb-int sb-kernel sb-sys sb-c))
+
+(defparameter *documentation-types*
+  '(compiler-macro
+    function
+    method-combination
+    setf
+    ;;structure  ; also handled by `type'
+    type
+    variable)
+  "A list of symbols accepted as second argument of `documentation'")
+
+(defparameter *character-replacements*
+  '((#\* . "star") (#\/ . "slash") (#\+ . "plus")
+    (#\< . "lt") (#\> . "gt")
+    (#\= . "equals"))
+  "Characters and their replacement names that `alphanumize' uses. If
+the replacements contain any of the chars they're supposed to replace,
+you deserve to lose.")
+
+(defparameter *characters-to-drop* '(#\\ #\` #\')
+  "Characters that should be removed by `alphanumize'.")
+
+(defparameter *texinfo-escaped-chars* "@{}"
+  "Characters that must be escaped with #\@ for Texinfo.")
+
+(defparameter *itemize-start-characters* '(#\* #\-)
+  "Characters that might start an itemization in docstrings when
+  at the start of a line.")
+
+(defparameter *symbol-characters* "ABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890*:-+&#'"
+  "List of characters that make up symbols in a docstring.")
+
+(defparameter *symbol-delimiters* " ,.!?;")
+
+(defparameter *ordered-documentation-kinds*
+  '(package type structure condition class macro))
+
+;;;; utilities
+
+(defun flatten (list)
+  (cond ((null list)
+         nil)
+        ((consp (car list))
+         (nconc (flatten (car list)) (flatten (cdr list))))
+        ((null (cdr list))
+         (cons (car list) nil))
+        (t
+         (cons (car list) (flatten (cdr list))))))
+
+(defun whitespacep (char)
+  (find char #(#\tab #\space #\page)))
+
+(defun setf-name-p (name)
+  (or (symbolp name)
+      (and (listp name) (= 2 (length name)) (eq (car name) 'setf))))
+
+(defgeneric specializer-name (specializer))
+
+(defmethod specializer-name ((specializer eql-specializer))
+  (list 'eql (eql-specializer-object specializer)))
+
+(defmethod specializer-name ((specializer class))
+  (class-name specializer))
+
+(defun ensure-class-precedence-list (class)
+  (unless (class-finalized-p class)
+    (finalize-inheritance class))
+  (class-precedence-list class))
+
+(defun specialized-lambda-list (method)
+  ;; courtecy of AMOP p. 61
+  (let* ((specializers (method-specializers method))
+         (lambda-list (method-lambda-list method))
+         (n-required (length specializers)))
+    (append (mapcar (lambda (arg specializer)
+                      (if  (eq specializer (find-class 't))
+                           arg
+                           `(,arg ,(specializer-name specializer))))
+                    (subseq lambda-list 0 n-required)
+                    specializers)
+           (subseq lambda-list n-required))))
+
+(defun string-lines (string)
+  "Lines in STRING as a vector."
+  (coerce (with-input-from-string (s string)
+            (loop for line = (read-line s nil nil)
+               while line collect line))
+          'vector))
+
+(defun indentation (line)
+  "Position of first non-SPACE character in LINE."
+  (position-if-not (lambda (c) (char= c #\Space)) line))
+
+(defun docstring (x doc-type)
+  (cl:documentation x doc-type))
+
+(defun flatten-to-string (list)
+  (format nil "~{~A~^-~}" (flatten list)))
+
+(defun alphanumize (original)
+  "Construct a string without characters like *`' that will f-star-ck
+up filename handling. See `*character-replacements*' and
+`*characters-to-drop*' for customization."
+  (let ((name (remove-if (lambda (x) (member x *characters-to-drop*))
+                         (if (listp original)
+                             (flatten-to-string original)
+                             (string original))))
+        (chars-to-replace (mapcar #'car *character-replacements*)))
+    (flet ((replacement-delimiter (index)
+             (cond ((or (< index 0) (>= index (length name))) "")
+                   ((alphanumericp (char name index)) "-")
+                   (t ""))))
+      (loop for index = (position-if #'(lambda (x) (member x chars-to-replace))
+                                     name)
+         while index
+         do (setf name (concatenate 'string (subseq name 0 index)
+                                    (replacement-delimiter (1- index))
+                                    (cdr (assoc (aref name index)
+                                                *character-replacements*))
+                                    (replacement-delimiter (1+ index))
+                                    (subseq name (1+ index))))))
+    name))
+
+;;;; generating various names
+
+(defgeneric name (thing)
+  (:documentation "Name for a documented thing. Names are either
+symbols or lists of symbols."))
+
+(defmethod name ((symbol symbol))
+  symbol)
+
+(defmethod name ((cons cons))
+  cons)
+
+(defmethod name ((package package))
+  (short-package-name package))
+
+(defmethod name ((method method))
+  (list
+   (generic-function-name (method-generic-function method))
+   (method-qualifiers method)
+   (specialized-lambda-list method)))
+
+;;; Node names for DOCUMENTATION instances
+
+(defgeneric name-using-kind/name (kind name doc))
+
+(defmethod name-using-kind/name (kind (name string) doc)
+  (declare (ignore kind doc))
+  name)
+
+(defmethod name-using-kind/name (kind (name symbol) doc)
+  (declare (ignore kind))
+  (format nil "~@[~A:~]~A" (short-package-name (get-package doc)) name))
+
+(defmethod name-using-kind/name (kind (name list) doc)
+  (declare (ignore kind))
+  (assert (setf-name-p name))
+  (format nil "(setf ~@[~A:~]~A)" (short-package-name (get-package doc)) (second name)))
+
+(defmethod name-using-kind/name ((kind (eql 'method)) name doc)
+  (format nil "~A~{ ~A~} ~A"
+          (name-using-kind/name nil (first name) doc)
+          (second name)
+          (third name)))
+
+(defun node-name (doc)
+  "Returns TexInfo node name as a string for a DOCUMENTATION instance."
+  (let ((kind (get-kind doc)))
+    (format nil "~:(~A~) ~(~A~)" kind (name-using-kind/name kind (get-name doc) doc))))
+
+(defun short-package-name (package)
+  (unless (eq package *base-package*)
+    (car (sort (copy-list (cons (package-name package) (package-nicknames package)))
+               #'< :key #'length))))
+
+;;; Definition titles for DOCUMENTATION instances
+
+(defgeneric title-using-kind/name (kind name doc))
+
+(defmethod title-using-kind/name (kind (name string) doc)
+  (declare (ignore kind doc))
+  name)
+
+(defmethod title-using-kind/name (kind (name symbol) doc)
+  (declare (ignore kind))
+  (format nil "~@[~A:~]~A" (short-package-name (get-package doc)) name))
+
+(defmethod title-using-kind/name (kind (name list) doc)
+  (declare (ignore kind))
+  (assert (setf-name-p name))
+  (format nil "(setf ~@[~A:~]~A)" (short-package-name (get-package doc)) (second name)))
+
+(defmethod title-using-kind/name ((kind (eql 'method)) name doc)
+  (format nil "~{~A ~}~A"
+          (second name)
+          (title-using-kind/name nil (first name) doc)))
+
+(defun title-name (doc)
+  "Returns a string to be used as name of the definition."
+  (string-downcase (title-using-kind/name (get-kind doc) (get-name doc) doc)))
+
+(defun include-pathname (doc)
+  (let* ((kind (get-kind doc))
+         (name (nstring-downcase
+                (if (eq 'package kind)
+                    (format nil "package-~A" (alphanumize (get-name doc)))
+                    (format nil "~A-~A-~A"
+                            (case (get-kind doc)
+                              ((function generic-function) "fun")
+                              (structure "struct")
+                              (variable "var")
+                              (otherwise (symbol-name (get-kind doc))))
+                            (alphanumize (let ((*base-package* nil))
+                                           (short-package-name (get-package doc))))
+                            (alphanumize (get-name doc)))))))
+    (make-pathname :name name  :type "texinfo")))
+
+;;;; documentation class and related methods
+
+(defclass documentation ()
+  ((name :initarg :name :reader get-name)
+   (kind :initarg :kind :reader get-kind)
+   (string :initarg :string :reader get-string)
+   (children :initarg :children :initform nil :reader get-children)
+   (package :initform *documentation-package* :reader get-package)))
+
+(defmethod print-object ((documentation documentation) stream)
+  (print-unreadable-object (documentation stream :type t)
+    (princ (list (get-kind documentation) (get-name documentation)) stream)))
+
+(defgeneric make-documentation (x doc-type string))
+
+(defmethod make-documentation ((x package) doc-type string)
+  (declare (ignore doc-type))
+  (make-instance 'documentation
+                 :name (name x)
+                 :kind 'package
+                 :string string))
+
+(defmethod make-documentation (x (doc-type (eql 'function)) string)
+  (declare (ignore doc-type))
+  (let* ((fdef (and (fboundp x) (fdefinition x)))
+         (name x)
+         (kind (cond ((and (symbolp x) (special-operator-p x))
+                      'special-operator)
+                     ((and (symbolp x) (macro-function x))
+                      'macro)
+                     ((typep fdef 'generic-function)
+                      (assert (or (symbolp name) (setf-name-p name)))
+                      'generic-function)
+                     (fdef
+                      (assert (or (symbolp name) (setf-name-p name)))
+                      'function)))
+         (children (when (eq kind 'generic-function)
+                     (collect-gf-documentation fdef))))
+    (make-instance 'documentation
+                   :name (name x)
+                   :string string
+                   :kind kind
+                   :children children)))
+
+(defmethod make-documentation ((x method) doc-type string)
+  (declare (ignore doc-type))
+  (make-instance 'documentation
+                 :name (name x)
+                 :kind 'method
+                 :string string))
+
+(defmethod make-documentation (x (doc-type (eql 'type)) string)
+  (make-instance 'documentation
+                 :name (name x)
+                 :string string
+                 :kind (etypecase (find-class x nil)
+                         (structure-class 'structure)
+                         (standard-class 'class)
+                         (sb-pcl::condition-class 'condition)
+                         ((or built-in-class null) 'type))))
+
+(defmethod make-documentation (x (doc-type (eql 'variable)) string)
+  (make-instance 'documentation
+                 :name (name x)
+                 :string string
+                 :kind (if (constantp x)
+                           'constant
+                           'variable)))
+
+(defmethod make-documentation (x (doc-type (eql 'setf)) string)
+  (declare (ignore doc-type))
+  (make-instance 'documentation
+                 :name (name x)
+                 :kind 'setf-expander
+                 :string string))
+
+(defmethod make-documentation (x doc-type string)
+  (make-instance 'documentation
+                 :name (name x)
+                 :kind doc-type
+                 :string string))
+
+(defun maybe-documentation (x doc-type)
+  "Returns a DOCUMENTATION instance for X and DOC-TYPE, or NIL if
+there is no corresponding docstring."
+  (let ((docstring (docstring x doc-type)))
+    (when docstring
+      (make-documentation x doc-type docstring))))
+
+(defun lambda-list (doc)
+  (case (get-kind doc)
+    ((package constant variable type structure class condition nil)
+     nil)
+    (method
+     (third (get-name doc)))
+    (t
+     ;; KLUDGE: Eugh.
+     ;;
+     ;; believe it or not, the above comment was written before CSR
+     ;; came along and obfuscated this.  (2005-07-04)
+     (when (symbolp (get-name doc))
+       (labels ((clean (x &key optional key)
+                  (typecase x
+                    (atom x)
+                    ((cons (member &optional))
+                     (cons (car x) (clean (cdr x) :optional t)))
+                    ((cons (member &key))
+                     (cons (car x) (clean (cdr x) :key t)))
+                    ((cons (member &whole &environment))
+                     ;; Skip these
+                     (clean (cdr x) :optional optional :key key))
+                    ((cons cons)
+                     (cons
+                      (cond (key (if (consp (caar x))
+                                     (caaar x)
+                                     (caar x)))
+                            (optional (caar x))
+                            (t (clean (car x))))
+                      (clean (cdr x) :key key :optional optional)))
+                    (cons
+                     (cons
+                      (cond ((or key optional) (car x))
+                            (t (clean (car x))))
+                      (clean (cdr x) :key key :optional optional))))))
+         (clean (sb-introspect:function-lambda-list (get-name doc))))))))
+
+(defun get-string-name (x)
+  (let ((name (get-name x)))
+    (cond ((symbolp name)
+           (symbol-name name))
+          ((and (consp name) (eq 'setf (car name)))
+           (symbol-name (second name)))
+          ((stringp name)
+           name)
+          (t
+           (error "Don't know which symbol to use for name ~S" name)))))
+
+(defun documentation< (x y)
+  (let ((p1 (position (get-kind x) *ordered-documentation-kinds*))
+        (p2 (position (get-kind y) *ordered-documentation-kinds*)))
+    (if (or (not (and p1 p2)) (= p1 p2))
+        (string< (get-string-name x) (get-string-name y))
+        (< p1 p2))))
+
+;;;; turning text into texinfo
+
+(defun escape-for-texinfo (string &optional downcasep)
+  "Return STRING with characters in *TEXINFO-ESCAPED-CHARS* escaped
+with #\@. Optionally downcase the result."
+  (let ((result (with-output-to-string (s)
+                  (loop for char across string
+                        when (find char *texinfo-escaped-chars*)
+                        do (write-char #\@ s)
+                        do (write-char char s)))))
+    (if downcasep (nstring-downcase result) result)))
+
+(defun empty-p (line-number lines)
+  (and (< -1 line-number (length lines))
+       (not (indentation (svref lines line-number)))))
+
+;;; line markups
+
+(defvar *not-symbols* '("ANSI" "CLHS"))
+
+(defun locate-symbols (line)
+  "Return a list of index pairs of symbol-like parts of LINE."
+  ;; This would be a good application for a regex ...
+  (let (result)
+    (flet ((grab (start end)
+             (unless (member (subseq line start end) '("ANSI" "CLHS"))
+               (push (list start end) result))))
+      (do ((begin nil)
+           (maybe-begin t)
+           (i 0 (1+ i)))
+          ((= i (length line))
+           ;; symbol at end of line
+           (when (and begin (or (> i (1+ begin))
+                                (not (member (char line begin) '(#\A #\I)))))
+             (grab begin i))
+           (nreverse result))
+        (cond
+          ((and begin (find (char line i) *symbol-delimiters*))
+           ;; symbol end; remember it if it's not "A" or "I"
+           (when (or (> i (1+ begin)) (not (member (char line begin) '(#\A #\I))))
+             (grab begin i))
+           (setf begin nil
+                 maybe-begin t))
+          ((and begin (not (find (char line i) *symbol-characters*)))
+           ;; Not a symbol: abort
+           (setf begin nil))
+          ((and maybe-begin (not begin) (find (char line i) *symbol-characters*))
+           ;; potential symbol begin at this position
+           (setf begin i
+                 maybe-begin nil))
+          ((find (char line i) *symbol-delimiters*)
+           ;; potential symbol begin after this position
+           (setf maybe-begin t))
+          (t
+           ;; Not reading a symbol, not at potential start of symbol
+           (setf maybe-begin nil)))))))
+
+(defun texinfo-line (line)
+  "Format symbols in LINE texinfo-style: either as code or as
+variables if the symbol in question is contained in symbols
+*TEXINFO-VARIABLES*."
+  (with-output-to-string (result)
+    (let ((last 0))
+      (dolist (symbol/index (locate-symbols line))
+        (write-string (subseq line last (first symbol/index)) result)
+        (let ((symbol-name (apply #'subseq line symbol/index)))
+          (format result (if (member symbol-name *texinfo-variables*
+                                     :test #'string=)
+                             "@var{~A}"
+                             "@code{~A}")
+                  (string-downcase symbol-name)))
+        (setf last (second symbol/index)))
+      (write-string (subseq line last) result))))
+
+;;; lisp sections
+
+(defun lisp-section-p (line line-number lines)
+  "Returns T if the given LINE looks like start of lisp code --
+ie. if it starts with whitespace followed by a paren or
+semicolon, and the previous line is empty"
+  (let ((offset (indentation line)))
+    (and offset
+         (plusp offset)
+         (find (find-if-not #'whitespacep line) "(;")
+         (empty-p (1- line-number) lines))))
+
+(defun collect-lisp-section (lines line-number)
+  (let ((lisp (loop for index = line-number then (1+ index)
+                    for line = (and (< index (length lines)) (svref lines index))
+                    while (indentation line)
+                    collect line)))
+    (values (length lisp) `("@lisp" ,@lisp "@end lisp"))))
+
+;;; itemized sections
+
+(defun maybe-itemize-offset (line)
+  "Return NIL or the indentation offset if LINE looks like it starts
+an item in an itemization."
+  (let* ((offset (indentation line))
+         (char (when offset (char line offset))))
+    (and offset
+         (member char *itemize-start-characters* :test #'char=)
+         (char= #\Space (find-if-not (lambda (c) (char= c char))
+                                     line :start offset))
+         offset)))
+
+(defun collect-maybe-itemized-section (lines starting-line)
+  ;; Return index of next line to be processed outside
+  (let ((this-offset (maybe-itemize-offset (svref lines starting-line)))
+        (result nil)
+        (lines-consumed 0))
+    (loop for line-number from starting-line below (length lines)
+       for line = (svref lines line-number)
+       for indentation = (indentation line)
+       for offset = (maybe-itemize-offset line)
+       do (cond
+            ((not indentation)
+             ;; empty line -- inserts paragraph.
+             (push "" result)
+             (incf lines-consumed))
+            ((and offset (> indentation this-offset))
+             ;; nested itemization -- handle recursively
+             ;; FIXME: tables in itemizations go wrong
+             (multiple-value-bind (sub-lines-consumed sub-itemization)
+                 (collect-maybe-itemized-section lines line-number)
+               (when sub-lines-consumed
+                 (incf line-number (1- sub-lines-consumed)) ; +1 on next loop
+                 (incf lines-consumed sub-lines-consumed)
+                 (setf result (nconc (nreverse sub-itemization) result)))))
+            ((and offset (= indentation this-offset))
+             ;; start of new item
+             (push (format nil "@item ~A"
+                           (texinfo-line (subseq line (1+ offset))))
+                   result)
+             (incf lines-consumed))
+            ((and (not offset) (> indentation this-offset))
+             ;; continued item from previous line
+             (push (texinfo-line line) result)
+             (incf lines-consumed))
+            (t
+             ;; end of itemization
+             (loop-finish))))
+    ;; a single-line itemization isn't.
+    (if (> (count-if (lambda (line) (> (length line) 0)) result) 1)
+        (values lines-consumed `("@itemize" ,@(reverse result) "@end itemize"))
+        nil)))
+
+;;; table sections
+
+(defun tabulation-body-p (offset line-number lines)
+  (when (< line-number (length lines))
+    (let ((offset2 (indentation (svref lines line-number))))
+      (and offset2 (< offset offset2)))))
+
+(defun tabulation-p (offset line-number lines direction)
+  (let ((step  (ecase direction
+                 (:backwards (1- line-number))
+                 (:forwards (1+ line-number)))))
+    (when (and (plusp line-number) (< line-number (length lines)))
+      (and (eql offset (indentation (svref lines line-number)))
+           (or (when (eq direction :backwards)
+                 (empty-p step lines))
+               (tabulation-p offset step lines direction)
+               (tabulation-body-p offset step lines))))))
+
+(defun maybe-table-offset (line-number lines)
+  "Return NIL or the indentation offset if LINE looks like it starts
+an item in a tabulation. Ie, if it is (1) indented, (2) preceded by an
+empty line, another tabulation label, or a tabulation body, (3) and
+followed another tabulation label or a tabulation body."
+  (let* ((line (svref lines line-number))
+         (offset (indentation line))
+         (prev (1- line-number))
+         (next (1+ line-number)))
+    (when (and offset (plusp offset))
+      (and (or (empty-p prev lines)
+               (tabulation-body-p offset prev lines)
+               (tabulation-p offset prev lines :backwards))
+           (or (tabulation-body-p offset next lines)
+               (tabulation-p offset next lines :forwards))
+           offset))))
+
+;;; FIXME: This and itemization are very similar: could they share
+;;; some code, mayhap?
+
+(defun collect-maybe-table-section (lines starting-line)
+  ;; Return index of next line to be processed outside
+  (let ((this-offset (maybe-table-offset starting-line lines))
+        (result nil)
+        (lines-consumed 0))
+    (loop for line-number from starting-line below (length lines)
+          for line = (svref lines line-number)
+          for indentation = (indentation line)
+          for offset = (maybe-table-offset line-number lines)
+          do (cond
+               ((not indentation)
+                ;; empty line -- inserts paragraph.
+                (push "" result)
+                (incf lines-consumed))
+               ((and offset (= indentation this-offset))
+                ;; start of new item, or continuation of previous item
+                (if (and result (search "@item" (car result) :test #'char=))
+                    (push (format nil "@itemx ~A" (texinfo-line line))
+                          result)
+                    (progn
+                      (push "" result)
+                      (push (format nil "@item ~A" (texinfo-line line))
+                            result)))
+                (incf lines-consumed))
+               ((> indentation this-offset)
+                ;; continued item from previous line
+                (push (texinfo-line line) result)
+                (incf lines-consumed))
+               (t
+                ;; end of itemization
+                (loop-finish))))
+     ;; a single-line table isn't.
+    (if (> (count-if (lambda (line) (> (length line) 0)) result) 1)
+        (values lines-consumed
+                `("" "@table @emph" ,@(reverse result) "@end table" ""))
+        nil)))
+
+;;; section markup
+
+(defmacro with-maybe-section (index &rest forms)
+  `(multiple-value-bind (count collected) (progn ,@forms)
+    (when count
+      (dolist (line collected)
+        (write-line line *texinfo-output*))
+      (incf ,index (1- count)))))
+
+(defun write-texinfo-string (string &optional lambda-list)
+  "Try to guess as much formatting for a raw docstring as possible."
+  (let ((*texinfo-variables* (flatten lambda-list))
+        (lines (string-lines (escape-for-texinfo string nil))))
+      (loop for line-number from 0 below (length lines)
+            for line = (svref lines line-number)
+            do (cond
+                 ((with-maybe-section line-number
+                    (and (lisp-section-p line line-number lines)
+                         (collect-lisp-section lines line-number))))
+                 ((with-maybe-section line-number
+                    (and (maybe-itemize-offset line)
+                         (collect-maybe-itemized-section lines line-number))))
+                 ((with-maybe-section line-number
+                    (and (maybe-table-offset line-number lines)
+                         (collect-maybe-table-section lines line-number))))
+                 (t
+                  (write-line (texinfo-line line) *texinfo-output*))))))
+
+;;;; texinfo formatting tools
+
+(defun hide-superclass-p (class-name super-name)
+  (let ((super-package (symbol-package super-name)))
+    (or
+     ;; KLUDGE: We assume that we don't want to advertise internal
+     ;; classes in CP-lists, unless the symbol we're documenting is
+     ;; internal as well.
+     (and (member super-package #.'(mapcar #'find-package *undocumented-packages*))
+          (not (eq super-package (symbol-package class-name))))
+     ;; KLUDGE: We don't generally want to advertise SIMPLE-ERROR or
+     ;; SIMPLE-CONDITION in the CPLs of conditions that inherit them
+     ;; simply as a matter of convenience. The assumption here is that
+     ;; the inheritance is incidental unless the name of the condition
+     ;; begins with SIMPLE-.
+     (and (member super-name '(simple-error simple-condition))
+          (let ((prefix "SIMPLE-"))
+            (mismatch prefix (string class-name) :end2 (length prefix)))
+          t ; don't return number from MISMATCH
+          ))))
+
+(defun hide-slot-p (symbol slot)
+  ;; FIXME: There is no pricipal reason to avoid the slot docs fo
+  ;; structures and conditions, but their DOCUMENTATION T doesn't
+  ;; currently work with them the way we'd like.
+  (not (and (typep (find-class symbol nil) 'standard-class)
+            (docstring slot t))))
+
+(defun texinfo-anchor (doc)
+  (format *texinfo-output* "@anchor{~A}~%" (node-name doc)))
+
+;;; KLUDGE: &AUX *PRINT-PRETTY* here means "no linebreaks please"
+(defun texinfo-begin (doc &aux *print-pretty*)
+  (let ((kind (get-kind doc)))
+    (format *texinfo-output* "@~A {~:(~A~)} ~({~A}~@[ ~{~A~^ ~}~]~)~%"
+            (case kind
+              ((package constant variable)
+               "defvr")
+              ((structure class condition type)
+               "deftp")
+              (t
+               "deffn"))
+            (map 'string (lambda (char) (if (eql char #\-) #\Space char)) (string kind))
+            (title-name doc)
+            ;; &foo would be amusingly bold in the pdf thanks to TeX/Texinfo
+            ;; interactions,so we escape the ampersand -- amusingly for TeX.
+            ;; sbcl.texinfo defines macros that expand @&key and friends to &key.
+            (mapcar (lambda (name)
+                      (if (member name lambda-list-keywords)
+                          (format nil "@~A" name)
+                          name))
+                    (lambda-list doc)))))
+
+(defun texinfo-index (doc)
+  (let ((title (title-name doc)))
+    (case (get-kind doc)
+      ((structure type class condition)
+       (format *texinfo-output* "@tindex ~A~%" title))
+      ((variable constant)
+       (format *texinfo-output* "@vindex ~A~%" title))
+      ((compiler-macro function method-combination macro generic-function)
+       (format *texinfo-output* "@findex ~A~%" title)))))
+
+(defun texinfo-inferred-body (doc)
+  (when (member (get-kind doc) '(class structure condition))
+    (let ((name (get-name doc)))
+      ;; class precedence list
+      (format *texinfo-output* "Class precedence list: @code{~(~{@lw{~A}~^, ~}~)}~%~%"
+              (remove-if (lambda (class)  (hide-superclass-p name class))
+                         (mapcar #'class-name (ensure-class-precedence-list (find-class name)))))
+      ;; slots
+      (let ((slots (remove-if (lambda (slot) (hide-slot-p name slot))
+                              (class-direct-slots (find-class name)))))
+        (when slots
+          (format *texinfo-output* "Slots:~%@itemize~%")
+          (dolist (slot slots)
+            (format *texinfo-output*
+                    "@item ~(@code{~A}~#[~:; --- ~]~
+                      ~:{~2*~@[~2:*~A~P: ~{@code{@w{~S}}~^, ~}~]~:^; ~}~)~%~%"
+                    (slot-definition-name slot)
+                    (remove
+                     nil
+                     (mapcar
+                      (lambda (name things)
+                        (if things
+                            (list name (length things) things)))
+                      '("initarg" "reader"  "writer")
+                      (list
+                       (slot-definition-initargs slot)
+                       (slot-definition-readers slot)
+                       (slot-definition-writers slot)))))
+            ;; FIXME: Would be neater to handler as children
+            (write-texinfo-string (docstring slot t)))
+          (format *texinfo-output* "@end itemize~%~%"))))))
+
+(defun texinfo-body (doc)
+  (write-texinfo-string (get-string doc)))
+
+(defun texinfo-end (doc)
+  (write-line (case (get-kind doc)
+                ((package variable constant) "@end defvr")
+                ((structure type class condition) "@end deftp")
+                (t "@end deffn"))
+              *texinfo-output*))
+
+(defun write-texinfo (doc)
+  "Writes TexInfo for a DOCUMENTATION instance to *TEXINFO-OUTPUT*."
+  (texinfo-anchor doc)
+  (texinfo-begin doc)
+  (texinfo-index doc)
+  (texinfo-inferred-body doc)
+  (texinfo-body doc)
+  (texinfo-end doc)
+  ;; FIXME: Children should be sorted one way or another
+  (mapc #'write-texinfo (get-children doc)))
+
+;;;; main logic
+
+(defun collect-gf-documentation (gf)
+  "Collects method documentation for the generic function GF"
+  (loop for method in (generic-function-methods gf)
+        for doc = (maybe-documentation method t)
+        when doc
+        collect doc))
+
+(defun collect-name-documentation (name)
+  (loop for type in *documentation-types*
+        for doc = (maybe-documentation name type)
+        when doc
+        collect doc))
+
+(defun collect-symbol-documentation (symbol)
+  "Collects all docs for a SYMBOL and (SETF SYMBOL), returns a list of
+the form DOC instances. See `*documentation-types*' for the possible
+values of doc-type."
+  (nconc (collect-name-documentation symbol)
+         (collect-name-documentation (list 'setf symbol))))
+
+(defun collect-documentation (package)
+  "Collects all documentation for all external symbols of the given
+package, as well as for the package itself."
+  (let* ((*documentation-package* (find-package package))
+         (docs nil))
+    (check-type package package)
+    (do-external-symbols (symbol package)
+      (setf docs (nconc (collect-symbol-documentation symbol) docs)))
+    (let ((doc (maybe-documentation *documentation-package* t)))
+      (when doc
+        (push doc docs)))
+    docs))
+
+(defmacro with-texinfo-file (pathname &body forms)
+  `(with-open-file (*texinfo-output* ,pathname
+                                    :direction :output
+                                    :if-does-not-exist :create
+                                    :if-exists :supersede)
+    ,@forms))
+
+(defun write-ifnottex ()
+  ;; We use @&key, etc to escape & from TeX in lambda lists -- so we need to
+  ;; define them for info as well.
+  (flet ((macro (name)
+                 (let ((string (string-downcase name)))
+                   (format *texinfo-output* "@macro ~A~%~A~%@end macro~%" string string))))
+    (macro '&allow-other-keys)
+    (macro '&optional)
+    (macro '&rest)
+    (macro '&key)
+    (macro '&body)))
+
+(defun generate-includes (directory packages &key (base-package :cl-user))
+  "Create files in `directory' containing Texinfo markup of all
+docstrings of each exported symbol in `packages'. `directory' is
+created if necessary. If you supply a namestring that doesn't end in a
+slash, you lose. The generated files are of the form
+\"<doc-type>_<packagename>_<symbol-name>.texinfo\" and can be included
+via @include statements. Texinfo syntax-significant characters are
+escaped in symbol names, but if a docstring contains invalid Texinfo
+markup, you lose."
+  (handler-bind ((warning #'muffle-warning))
+    (let ((directory (merge-pathnames (pathname directory)))
+          (*base-package* (find-package base-package)))
+      (ensure-directories-exist directory)
+      (dolist (package packages)
+        (dolist (doc (collect-documentation (find-package package)))
+          (with-texinfo-file (merge-pathnames (include-pathname doc) directory)
+            (write-texinfo doc))))
+      (with-texinfo-file (merge-pathnames "ifnottex.texinfo" directory)
+        (write-ifnottex))
+      directory)))
+
+(defun document-package (package &optional filename)
+  "Create a file containing all available documentation for the
+exported symbols of `package' in Texinfo format. If `filename' is not
+supplied, a file \"<packagename>.texinfo\" is generated.
+
+The definitions can be referenced using Texinfo statements like
+@ref{<doc-type>_<packagename>_<symbol-name>.texinfo}. Texinfo
+syntax-significant characters are escaped in symbol names, but if a
+docstring contains invalid Texinfo markup, you lose."
+  (handler-bind ((warning #'muffle-warning))
+    (let* ((package (find-package package))
+           (filename (or filename (make-pathname
+                                   :name (string-downcase (short-package-name package))
+                                   :type "texinfo")))
+           (docs (sort (collect-documentation package) #'documentation<)))
+      (with-texinfo-file filename
+        (dolist (doc docs)
+          (write-texinfo doc)))
+      filename)))
diff --git a/third_party/lisp/alexandria/features.lisp b/third_party/lisp/alexandria/features.lisp
new file mode 100644
index 000000000000..67348dbba43b
--- /dev/null
+++ b/third_party/lisp/alexandria/features.lisp
@@ -0,0 +1,14 @@
+(in-package :alexandria)
+
+(defun featurep (feature-expression)
+  "Returns T if the argument matches the state of the *FEATURES*
+list and NIL if it does not. FEATURE-EXPRESSION can be any atom
+or list acceptable to the reader macros #+ and #-."
+  (etypecase feature-expression
+    (symbol (not (null (member feature-expression *features*))))
+    (cons (check-type (first feature-expression) symbol)
+          (eswitch ((first feature-expression) :test 'string=)
+            (:and (every #'featurep (rest feature-expression)))
+            (:or  (some #'featurep (rest feature-expression)))
+            (:not (assert (= 2 (length feature-expression)))
+                  (not (featurep (second feature-expression))))))))
diff --git a/third_party/lisp/alexandria/functions.lisp b/third_party/lisp/alexandria/functions.lisp
new file mode 100644
index 000000000000..dd83e38b4ebc
--- /dev/null
+++ b/third_party/lisp/alexandria/functions.lisp
@@ -0,0 +1,161 @@
+(in-package :alexandria)
+
+;;; To propagate return type and allow the compiler to eliminate the IF when
+;;; it is known if the argument is function or not.
+(declaim (inline ensure-function))
+
+(declaim (ftype (function (t) (values function &optional))
+                ensure-function))
+(defun ensure-function (function-designator)
+  "Returns the function designated by FUNCTION-DESIGNATOR:
+if FUNCTION-DESIGNATOR is a function, it is returned, otherwise
+it must be a function name and its FDEFINITION is returned."
+  (if (functionp function-designator)
+      function-designator
+      (fdefinition function-designator)))
+
+(define-modify-macro ensure-functionf/1 () ensure-function)
+
+(defmacro ensure-functionf (&rest places)
+  "Multiple-place modify macro for ENSURE-FUNCTION: ensures that each of
+PLACES contains a function."
+  `(progn ,@(mapcar (lambda (x) `(ensure-functionf/1 ,x)) places)))
+
+(defun disjoin (predicate &rest more-predicates)
+  "Returns a function that applies each of PREDICATE and MORE-PREDICATE
+functions in turn to its arguments, returning the primary value of the first
+predicate that returns true, without calling the remaining predicates.
+If none of the predicates returns true, NIL is returned."
+  (declare (optimize (speed 3) (safety 1) (debug 1)))
+  (let ((predicate (ensure-function predicate))
+	(more-predicates (mapcar #'ensure-function more-predicates)))
+    (lambda (&rest arguments)
+      (or (apply predicate arguments)
+	  (some (lambda (p)
+		  (declare (type function p))
+		  (apply p arguments))
+		more-predicates)))))
+
+(defun conjoin (predicate &rest more-predicates)
+  "Returns a function that applies each of PREDICATE and MORE-PREDICATE
+functions in turn to its arguments, returning NIL if any of the predicates
+returns false, without calling the remaining predicates. If none of the
+predicates returns false, returns the primary value of the last predicate."
+  (if (null more-predicates)
+      predicate
+      (lambda (&rest arguments)
+	(and (apply predicate arguments)
+	     ;; Cannot simply use CL:EVERY because we want to return the
+	     ;; non-NIL value of the last predicate if all succeed.
+	     (do ((tail (cdr more-predicates) (cdr tail))
+		  (head (car more-predicates) (car tail)))
+		 ((not tail)
+		  (apply head arguments))
+	       (unless (apply head arguments)
+		 (return nil)))))))
+
+
+(defun compose (function &rest more-functions)
+  "Returns a function composed of FUNCTION and MORE-FUNCTIONS that applies its
+arguments to to each in turn, starting from the rightmost of MORE-FUNCTIONS,
+and then calling the next one with the primary value of the last."
+  (declare (optimize (speed 3) (safety 1) (debug 1)))
+  (reduce (lambda (f g)
+	    (let ((f (ensure-function f))
+		  (g (ensure-function g)))
+	      (lambda (&rest arguments)
+		(declare (dynamic-extent arguments))
+		(funcall f (apply g arguments)))))
+          more-functions
+          :initial-value function))
+
+(define-compiler-macro compose (function &rest more-functions)
+  (labels ((compose-1 (funs)
+             (if (cdr funs)
+                 `(funcall ,(car funs) ,(compose-1 (cdr funs)))
+                 `(apply ,(car funs) arguments))))
+    (let* ((args (cons function more-functions))
+           (funs (make-gensym-list (length args) "COMPOSE")))
+      `(let ,(loop for f in funs for arg in args
+		   collect `(,f (ensure-function ,arg)))
+         (declare (optimize (speed 3) (safety 1) (debug 1)))
+         (lambda (&rest arguments)
+           (declare (dynamic-extent arguments))
+           ,(compose-1 funs))))))
+
+(defun multiple-value-compose (function &rest more-functions)
+    "Returns a function composed of FUNCTION and MORE-FUNCTIONS that applies
+its arguments to each in turn, starting from the rightmost of
+MORE-FUNCTIONS, and then calling the next one with all the return values of
+the last."
+  (declare (optimize (speed 3) (safety 1) (debug 1)))
+  (reduce (lambda (f g)
+	    (let ((f (ensure-function f))
+		  (g (ensure-function g)))
+	      (lambda (&rest arguments)
+		(declare (dynamic-extent arguments))
+		(multiple-value-call f (apply g arguments)))))
+          more-functions
+          :initial-value function))
+
+(define-compiler-macro multiple-value-compose (function &rest more-functions)
+  (labels ((compose-1 (funs)
+             (if (cdr funs)
+                 `(multiple-value-call ,(car funs) ,(compose-1 (cdr funs)))
+                 `(apply ,(car funs) arguments))))
+    (let* ((args (cons function more-functions))
+           (funs (make-gensym-list (length args) "MV-COMPOSE")))
+      `(let ,(mapcar #'list funs args)
+         (declare (optimize (speed 3) (safety 1) (debug 1)))
+         (lambda (&rest arguments)
+           (declare (dynamic-extent arguments))
+           ,(compose-1 funs))))))
+
+(declaim (inline curry rcurry))
+
+(defun curry (function &rest arguments)
+  "Returns a function that applies ARGUMENTS and the arguments
+it is called with to FUNCTION."
+  (declare (optimize (speed 3) (safety 1)))
+  (let ((fn (ensure-function function)))
+    (lambda (&rest more)
+      (declare (dynamic-extent more))
+      ;; Using M-V-C we don't need to append the arguments.
+      (multiple-value-call fn (values-list arguments) (values-list more)))))
+
+(define-compiler-macro curry (function &rest arguments)
+  (let ((curries (make-gensym-list (length arguments) "CURRY"))
+        (fun (gensym "FUN")))
+    `(let ((,fun (ensure-function ,function))
+           ,@(mapcar #'list curries arguments))
+       (declare (optimize (speed 3) (safety 1)))
+       (lambda (&rest more)
+         (declare (dynamic-extent more))
+         (apply ,fun ,@curries more)))))
+
+(defun rcurry (function &rest arguments)
+  "Returns a function that applies the arguments it is called
+with and ARGUMENTS to FUNCTION."
+  (declare (optimize (speed 3) (safety 1)))
+  (let ((fn (ensure-function function)))
+    (lambda (&rest more)
+      (declare (dynamic-extent more))
+      (multiple-value-call fn (values-list more) (values-list arguments)))))
+
+(define-compiler-macro rcurry (function &rest arguments)
+  (let ((rcurries (make-gensym-list (length arguments) "RCURRY"))
+        (fun (gensym "FUN")))
+    `(let ((,fun (ensure-function ,function))
+           ,@(mapcar #'list rcurries arguments))
+       (declare (optimize (speed 3) (safety 1)))
+       (lambda (&rest more)
+         (declare (dynamic-extent more))
+         (multiple-value-call ,fun (values-list more) ,@rcurries)))))
+
+(declaim (notinline curry rcurry))
+
+(defmacro named-lambda (name lambda-list &body body)
+  "Expands into a lambda-expression within whose BODY NAME denotes the
+corresponding function."
+  `(labels ((,name ,lambda-list ,@body))
+     #',name))
diff --git a/third_party/lisp/alexandria/hash-tables.lisp b/third_party/lisp/alexandria/hash-tables.lisp
new file mode 100644
index 000000000000..a9f790220405
--- /dev/null
+++ b/third_party/lisp/alexandria/hash-tables.lisp
@@ -0,0 +1,101 @@
+(in-package :alexandria)
+
+(defmacro ensure-gethash (key hash-table &optional default)
+  "Like GETHASH, but if KEY is not found in the HASH-TABLE saves the DEFAULT
+under key before returning it. Secondary return value is true if key was
+already in the table."
+  (once-only (key hash-table)
+    (with-unique-names (value presentp)
+      `(multiple-value-bind (,value ,presentp) (gethash ,key ,hash-table)
+         (if ,presentp
+             (values ,value ,presentp)
+             (values (setf (gethash ,key ,hash-table) ,default) nil))))))
+
+(defun copy-hash-table (table &key key test size
+                                   rehash-size rehash-threshold)
+  "Returns a copy of hash table TABLE, with the same keys and values
+as the TABLE. The copy has the same properties as the original, unless
+overridden by the keyword arguments.
+
+Before each of the original values is set into the new hash-table, KEY
+is invoked on the value. As KEY defaults to CL:IDENTITY, a shallow
+copy is returned by default."
+  (setf key (or key 'identity))
+  (setf test (or test (hash-table-test table)))
+  (setf size (or size (hash-table-size table)))
+  (setf rehash-size (or rehash-size (hash-table-rehash-size table)))
+  (setf rehash-threshold (or rehash-threshold (hash-table-rehash-threshold table)))
+  (let ((copy (make-hash-table :test test :size size
+                               :rehash-size rehash-size
+                               :rehash-threshold rehash-threshold)))
+    (maphash (lambda (k v)
+               (setf (gethash k copy) (funcall key v)))
+             table)
+    copy))
+
+(declaim (inline maphash-keys))
+(defun maphash-keys (function table)
+  "Like MAPHASH, but calls FUNCTION with each key in the hash table TABLE."
+  (maphash (lambda (k v)
+             (declare (ignore v))
+             (funcall function k))
+           table))
+
+(declaim (inline maphash-values))
+(defun maphash-values (function table)
+  "Like MAPHASH, but calls FUNCTION with each value in the hash table TABLE."
+  (maphash (lambda (k v)
+             (declare (ignore k))
+             (funcall function v))
+           table))
+
+(defun hash-table-keys (table)
+  "Returns a list containing the keys of hash table TABLE."
+  (let ((keys nil))
+    (maphash-keys (lambda (k)
+                    (push k keys))
+                  table)
+    keys))
+
+(defun hash-table-values (table)
+  "Returns a list containing the values of hash table TABLE."
+  (let ((values nil))
+    (maphash-values (lambda (v)
+                      (push v values))
+                    table)
+    values))
+
+(defun hash-table-alist (table)
+  "Returns an association list containing the keys and values of hash table
+TABLE."
+  (let ((alist nil))
+    (maphash (lambda (k v)
+               (push (cons k v) alist))
+             table)
+    alist))
+
+(defun hash-table-plist (table)
+  "Returns a property list containing the keys and values of hash table
+TABLE."
+  (let ((plist nil))
+    (maphash (lambda (k v)
+               (setf plist (list* k v plist)))
+             table)
+    plist))
+
+(defun alist-hash-table (alist &rest hash-table-initargs)
+  "Returns a hash table containing the keys and values of the association list
+ALIST. Hash table is initialized using the HASH-TABLE-INITARGS."
+  (let ((table (apply #'make-hash-table hash-table-initargs)))
+    (dolist (cons alist)
+      (ensure-gethash (car cons) table (cdr cons)))
+    table))
+
+(defun plist-hash-table (plist &rest hash-table-initargs)
+  "Returns a hash table containing the keys and values of the property list
+PLIST. Hash table is initialized using the HASH-TABLE-INITARGS."
+  (let ((table (apply #'make-hash-table hash-table-initargs)))
+    (do ((tail plist (cddr tail)))
+        ((not tail))
+      (ensure-gethash (car tail) table (cadr tail)))
+    table))
diff --git a/third_party/lisp/alexandria/io.lisp b/third_party/lisp/alexandria/io.lisp
new file mode 100644
index 000000000000..28bf5e6d82c7
--- /dev/null
+++ b/third_party/lisp/alexandria/io.lisp
@@ -0,0 +1,172 @@
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved.
+
+(in-package :alexandria)
+
+(defmacro with-open-file* ((stream filespec &key direction element-type
+                                   if-exists if-does-not-exist external-format)
+                           &body body)
+  "Just like WITH-OPEN-FILE, but NIL values in the keyword arguments mean to use
+the default value specified for OPEN."
+  (once-only (direction element-type if-exists if-does-not-exist external-format)
+    `(with-open-stream
+         (,stream (apply #'open ,filespec
+                         (append
+                          (when ,direction
+                            (list :direction ,direction))
+                          (when ,element-type
+                            (list :element-type ,element-type))
+                          (when ,if-exists
+                            (list :if-exists ,if-exists))
+                          (when ,if-does-not-exist
+                            (list :if-does-not-exist ,if-does-not-exist))
+                          (when ,external-format
+                            (list :external-format ,external-format)))))
+       ,@body)))
+
+(defmacro with-input-from-file ((stream-name file-name &rest args
+                                             &key (direction nil direction-p)
+                                             &allow-other-keys)
+                                &body body)
+  "Evaluate BODY with STREAM-NAME to an input stream on the file
+FILE-NAME. ARGS is sent as is to the call to OPEN except EXTERNAL-FORMAT,
+which is only sent to WITH-OPEN-FILE when it's not NIL."
+  (declare (ignore direction))
+  (when direction-p
+    (error "Can't specify :DIRECTION for WITH-INPUT-FROM-FILE."))
+  `(with-open-file* (,stream-name ,file-name :direction :input ,@args)
+     ,@body))
+
+(defmacro with-output-to-file ((stream-name file-name &rest args
+                                            &key (direction nil direction-p)
+                                            &allow-other-keys)
+			       &body body)
+  "Evaluate BODY with STREAM-NAME to an output stream on the file
+FILE-NAME. ARGS is sent as is to the call to OPEN except EXTERNAL-FORMAT,
+which is only sent to WITH-OPEN-FILE when it's not NIL."
+  (declare (ignore direction))
+  (when direction-p
+    (error "Can't specify :DIRECTION for WITH-OUTPUT-TO-FILE."))
+  `(with-open-file* (,stream-name ,file-name :direction :output ,@args)
+     ,@body))
+
+(defun read-stream-content-into-string (stream &key (buffer-size 4096))
+  "Return the \"content\" of STREAM as a fresh string."
+  (check-type buffer-size positive-integer)
+  (let ((*print-pretty* nil))
+    (with-output-to-string (datum)
+      (let ((buffer (make-array buffer-size :element-type 'character)))
+        (loop
+          :for bytes-read = (read-sequence buffer stream)
+          :do (write-sequence buffer datum :start 0 :end bytes-read)
+          :while (= bytes-read buffer-size))))))
+
+(defun read-file-into-string (pathname &key (buffer-size 4096) external-format)
+  "Return the contents of the file denoted by PATHNAME as a fresh string.
+
+The EXTERNAL-FORMAT parameter will be passed directly to WITH-OPEN-FILE
+unless it's NIL, which means the system default."
+  (with-input-from-file
+      (file-stream pathname :external-format external-format)
+    (read-stream-content-into-string file-stream :buffer-size buffer-size)))
+
+(defun write-string-into-file (string pathname &key (if-exists :error)
+                                                    if-does-not-exist
+                                                    external-format)
+  "Write STRING to PATHNAME.
+
+The EXTERNAL-FORMAT parameter will be passed directly to WITH-OPEN-FILE
+unless it's NIL, which means the system default."
+  (with-output-to-file (file-stream pathname :if-exists if-exists
+                                    :if-does-not-exist if-does-not-exist
+                                    :external-format external-format)
+    (write-sequence string file-stream)))
+
+(defun read-stream-content-into-byte-vector (stream &key ((%length length))
+                                                         (initial-size 4096))
+  "Return \"content\" of STREAM as freshly allocated (unsigned-byte 8) vector."
+  (check-type length (or null non-negative-integer))
+  (check-type initial-size positive-integer)
+  (do ((buffer (make-array (or length initial-size)
+                           :element-type '(unsigned-byte 8)))
+       (offset 0)
+       (offset-wanted 0))
+      ((or (/= offset-wanted offset)
+           (and length (>= offset length)))
+       (if (= offset (length buffer))
+           buffer
+           (subseq buffer 0 offset)))
+    (unless (zerop offset)
+      (let ((new-buffer (make-array (* 2 (length buffer))
+                                    :element-type '(unsigned-byte 8))))
+        (replace new-buffer buffer)
+        (setf buffer new-buffer)))
+    (setf offset-wanted (length buffer)
+          offset (read-sequence buffer stream :start offset))))
+
+(defun read-file-into-byte-vector (pathname)
+  "Read PATHNAME into a freshly allocated (unsigned-byte 8) vector."
+  (with-input-from-file (stream pathname :element-type '(unsigned-byte 8))
+    (read-stream-content-into-byte-vector stream '%length (file-length stream))))
+
+(defun write-byte-vector-into-file (bytes pathname &key (if-exists :error)
+                                                       if-does-not-exist)
+  "Write BYTES to PATHNAME."
+  (check-type bytes (vector (unsigned-byte 8)))
+  (with-output-to-file (stream pathname :if-exists if-exists
+                               :if-does-not-exist if-does-not-exist
+                               :element-type '(unsigned-byte 8))
+    (write-sequence bytes stream)))
+
+(defun copy-file (from to &key (if-to-exists :supersede)
+			       (element-type '(unsigned-byte 8)) finish-output)
+  (with-input-from-file (input from :element-type element-type)
+    (with-output-to-file (output to :element-type element-type
+				    :if-exists if-to-exists)
+      (copy-stream input output
+                   :element-type element-type
+                   :finish-output finish-output))))
+
+(defun copy-stream (input output &key (element-type (stream-element-type input))
+                    (buffer-size 4096)
+                    (buffer (make-array buffer-size :element-type element-type))
+                    (start 0) end
+                    finish-output)
+  "Reads data from INPUT and writes it to OUTPUT. Both INPUT and OUTPUT must
+be streams, they will be passed to READ-SEQUENCE and WRITE-SEQUENCE and must have
+compatible element-types."
+  (check-type start non-negative-integer)
+  (check-type end (or null non-negative-integer))
+  (check-type buffer-size positive-integer)
+  (when (and end
+             (< end start))
+    (error "END is smaller than START in ~S" 'copy-stream))
+  (let ((output-position 0)
+        (input-position 0))
+    (unless (zerop start)
+      ;; FIXME add platform specific optimization to skip seekable streams
+      (loop while (< input-position start)
+            do (let ((n (read-sequence buffer input
+                                       :end (min (length buffer)
+                                                 (- start input-position)))))
+                 (when (zerop n)
+                   (error "~@<Could not read enough bytes from the input to fulfill ~
+                           the :START ~S requirement in ~S.~:@>" 'copy-stream start))
+                 (incf input-position n))))
+    (assert (= input-position start))
+    (loop while (or (null end) (< input-position end))
+          do (let ((n (read-sequence buffer input
+                                     :end (when end
+                                            (min (length buffer)
+                                                 (- end input-position))))))
+               (when (zerop n)
+                 (if end
+                     (error "~@<Could not read enough bytes from the input to fulfill ~
+                          the :END ~S requirement in ~S.~:@>" 'copy-stream end)
+                     (return)))
+               (incf input-position n)
+               (write-sequence buffer output :end n)
+               (incf output-position n)))
+    (when finish-output
+      (finish-output output))
+    output-position))
diff --git a/third_party/lisp/alexandria/lists.lisp b/third_party/lisp/alexandria/lists.lisp
new file mode 100644
index 000000000000..51286071ebf2
--- /dev/null
+++ b/third_party/lisp/alexandria/lists.lisp
@@ -0,0 +1,367 @@
+(in-package :alexandria)
+
+(declaim (inline safe-endp))
+(defun safe-endp (x)
+  (declare (optimize safety))
+  (endp x))
+
+(defun alist-plist (alist)
+  "Returns a property list containing the same keys and values as the
+association list ALIST in the same order."
+  (let (plist)
+    (dolist (pair alist)
+      (push (car pair) plist)
+      (push (cdr pair) plist))
+    (nreverse plist)))
+
+(defun plist-alist (plist)
+  "Returns an association list containing the same keys and values as the
+property list PLIST in the same order."
+  (let (alist)
+    (do ((tail plist (cddr tail)))
+        ((safe-endp tail) (nreverse alist))
+      (push (cons (car tail) (cadr tail)) alist))))
+
+(declaim (inline racons))
+(defun racons (key value ralist)
+  (acons value key ralist))
+
+(macrolet
+    ((define-alist-get (name get-entry get-value-from-entry add doc)
+       `(progn
+          (declaim (inline ,name))
+          (defun ,name (alist key &key (test 'eql))
+            ,doc
+            (let ((entry (,get-entry key alist :test test)))
+              (values (,get-value-from-entry entry) entry)))
+          (define-setf-expander ,name (place key &key (test ''eql)
+                                       &environment env)
+            (multiple-value-bind
+                  (temporary-variables initforms newvals setter getter)
+                (get-setf-expansion place env)
+              (when (cdr newvals)
+                (error "~A cannot store multiple values in one place" ',name))
+              (with-unique-names (new-value key-val test-val alist entry)
+                (values
+                 (append temporary-variables
+                         (list alist
+                               key-val
+                               test-val
+                               entry))
+                 (append initforms
+                         (list getter
+                               key
+                               test
+                               `(,',get-entry ,key-val ,alist :test ,test-val)))
+                 `(,new-value)
+                 `(cond
+                    (,entry
+                     (setf (,',get-value-from-entry ,entry) ,new-value))
+                    (t
+                     (let ,newvals
+                       (setf ,(first newvals) (,',add ,key ,new-value ,alist))
+                       ,setter
+                       ,new-value)))
+                 `(,',get-value-from-entry ,entry))))))))
+ (define-alist-get assoc-value assoc cdr acons
+"ASSOC-VALUE is an alist accessor very much like ASSOC, but it can
+be used with SETF.")
+ (define-alist-get rassoc-value rassoc car racons
+"RASSOC-VALUE is an alist accessor very much like RASSOC, but it can
+be used with SETF."))
+
+(defun malformed-plist (plist)
+  (error "Malformed plist: ~S" plist))
+
+(defmacro doplist ((key val plist &optional values) &body body)
+  "Iterates over elements of PLIST. BODY can be preceded by
+declarations, and is like a TAGBODY. RETURN may be used to terminate
+the iteration early. If RETURN is not used, returns VALUES."
+  (multiple-value-bind (forms declarations) (parse-body body)
+    (with-gensyms (tail loop results)
+      `(block nil
+         (flet ((,results ()
+                  (let (,key ,val)
+                    (declare (ignorable ,key ,val))
+                    (return ,values))))
+           (let* ((,tail ,plist)
+                  (,key (if ,tail
+                            (pop ,tail)
+                            (,results)))
+                 (,val (if ,tail
+                           (pop ,tail)
+                           (malformed-plist ',plist))))
+            (declare (ignorable ,key ,val))
+            ,@declarations
+            (tagbody
+               ,loop
+               ,@forms
+               (setf ,key (if ,tail
+                              (pop ,tail)
+                              (,results))
+                     ,val (if ,tail
+                              (pop ,tail)
+                              (malformed-plist ',plist)))
+               (go ,loop))))))))
+
+(define-modify-macro appendf (&rest lists) append
+  "Modify-macro for APPEND. Appends LISTS to the place designated by the first
+argument.")
+
+(define-modify-macro nconcf (&rest lists) nconc
+  "Modify-macro for NCONC. Concatenates LISTS to place designated by the first
+argument.")
+
+(define-modify-macro unionf (list &rest args) union
+  "Modify-macro for UNION. Saves the union of LIST and the contents of the
+place designated by the first argument to the designated place.")
+
+(define-modify-macro nunionf (list &rest args) nunion
+  "Modify-macro for NUNION. Saves the union of LIST and the contents of the
+place designated by the first argument to the designated place. May modify
+either argument.")
+
+(define-modify-macro reversef () reverse
+  "Modify-macro for REVERSE. Copies and reverses the list stored in the given
+place and saves back the result into the place.")
+
+(define-modify-macro nreversef () nreverse
+  "Modify-macro for NREVERSE. Reverses the list stored in the given place by
+destructively modifying it and saves back the result into the place.")
+
+(defun circular-list (&rest elements)
+  "Creates a circular list of ELEMENTS."
+  (let ((cycle (copy-list elements)))
+    (nconc cycle cycle)))
+
+(defun circular-list-p (object)
+  "Returns true if OBJECT is a circular list, NIL otherwise."
+  (and (listp object)
+       (do ((fast object (cddr fast))
+            (slow (cons (car object) (cdr object)) (cdr slow)))
+           (nil)
+         (unless (and (consp fast) (listp (cdr fast)))
+           (return nil))
+         (when (eq fast slow)
+           (return t)))))
+
+(defun circular-tree-p (object)
+  "Returns true if OBJECT is a circular tree, NIL otherwise."
+  (labels ((circularp (object seen)
+             (and (consp object)
+                  (do ((fast (cons (car object) (cdr object)) (cddr fast))
+                       (slow object (cdr slow)))
+                      (nil)
+                    (when (or (eq fast slow) (member slow seen))
+                      (return-from circular-tree-p t))
+                    (when (or (not (consp fast)) (not (consp (cdr slow))))
+                      (return
+                        (do ((tail object (cdr tail)))
+                            ((not (consp tail))
+                             nil)
+                          (let ((elt (car tail)))
+                            (circularp elt (cons object seen))))))))))
+    (circularp object nil)))
+
+(defun proper-list-p (object)
+  "Returns true if OBJECT is a proper list."
+  (cond ((not object)
+         t)
+        ((consp object)
+         (do ((fast object (cddr fast))
+              (slow (cons (car object) (cdr object)) (cdr slow)))
+             (nil)
+           (unless (and (listp fast) (consp (cdr fast)))
+             (return (and (listp fast) (not (cdr fast)))))
+           (when (eq fast slow)
+             (return nil))))
+        (t
+         nil)))
+
+(deftype proper-list ()
+  "Type designator for proper lists. Implemented as a SATISFIES type, hence
+not recommended for performance intensive use. Main usefullness as a type
+designator of the expected type in a TYPE-ERROR."
+  `(and list (satisfies proper-list-p)))
+
+(defun circular-list-error (list)
+  (error 'type-error
+         :datum list
+         :expected-type '(and list (not circular-list))))
+
+(macrolet ((def (name lambda-list doc step declare ret1 ret2)
+             (assert (member 'list lambda-list))
+             `(defun ,name ,lambda-list
+                ,doc
+                (do ((last list fast)
+                     (fast list (cddr fast))
+                     (slow (cons (car list) (cdr list)) (cdr slow))
+                     ,@(when step (list step)))
+                    (nil)
+                  (declare (dynamic-extent slow) ,@(when declare (list declare))
+                           (ignorable last))
+                  (when (safe-endp fast)
+                    (return ,ret1))
+                  (when (safe-endp (cdr fast))
+                    (return ,ret2))
+                  (when (eq fast slow)
+                    (circular-list-error list))))))
+  (def proper-list-length (list)
+    "Returns length of LIST, signalling an error if it is not a proper list."
+    (n 1 (+ n 2))
+    ;; KLUDGE: Most implementations don't actually support lists with bignum
+    ;; elements -- and this is WAY faster on most implementations then declaring
+    ;; N to be an UNSIGNED-BYTE.
+    (fixnum n)
+    (1- n)
+    n)
+
+  (def lastcar (list)
+      "Returns the last element of LIST. Signals a type-error if LIST is not a
+proper list."
+    nil
+    nil
+    (cadr last)
+    (car fast))
+
+  (def (setf lastcar) (object list)
+      "Sets the last element of LIST. Signals a type-error if LIST is not a proper
+list."
+    nil
+    nil
+    (setf (cadr last) object)
+    (setf (car fast) object)))
+
+(defun make-circular-list (length &key initial-element)
+  "Creates a circular list of LENGTH with the given INITIAL-ELEMENT."
+  (let ((cycle (make-list length :initial-element initial-element)))
+    (nconc cycle cycle)))
+
+(deftype circular-list ()
+  "Type designator for circular lists. Implemented as a SATISFIES type, so not
+recommended for performance intensive use. Main usefullness as the
+expected-type designator of a TYPE-ERROR."
+  `(satisfies circular-list-p))
+
+(defun ensure-car (thing)
+  "If THING is a CONS, its CAR is returned. Otherwise THING is returned."
+  (if (consp thing)
+      (car thing)
+      thing))
+
+(defun ensure-cons (cons)
+  "If CONS is a cons, it is returned. Otherwise returns a fresh cons with CONS
+  in the car, and NIL in the cdr."
+  (if (consp cons)
+      cons
+      (cons cons nil)))
+
+(defun ensure-list (list)
+  "If LIST is a list, it is returned. Otherwise returns the list designated by LIST."
+  (if (listp list)
+      list
+      (list list)))
+
+(defun remove-from-plist (plist &rest keys)
+  "Returns a propery-list with same keys and values as PLIST, except that keys
+in the list designated by KEYS and values corresponding to them are removed.
+The returned property-list may share structure with the PLIST, but PLIST is
+not destructively modified. Keys are compared using EQ."
+  (declare (optimize (speed 3)))
+  ;; FIXME: possible optimization: (remove-from-plist '(:x 0 :a 1 :b 2) :a)
+  ;; could return the tail without consing up a new list.
+  (loop for (key . rest) on plist by #'cddr
+        do (assert rest () "Expected a proper plist, got ~S" plist)
+        unless (member key keys :test #'eq)
+        collect key and collect (first rest)))
+
+(defun delete-from-plist (plist &rest keys)
+  "Just like REMOVE-FROM-PLIST, but this version may destructively modify the
+provided PLIST."
+  (declare (optimize speed))
+  (loop with head = plist
+        with tail = nil   ; a nil tail means an empty result so far
+        for (key . rest) on plist by #'cddr
+        do (assert rest () "Expected a proper plist, got ~S" plist)
+           (if (member key keys :test #'eq)
+               ;; skip over this pair
+               (let ((next (cdr rest)))
+                 (if tail
+                     (setf (cdr tail) next)
+                     (setf head next)))
+               ;; keep this pair
+               (setf tail rest))
+        finally (return head)))
+
+(define-modify-macro remove-from-plistf (&rest keys) remove-from-plist
+                     "Modify macro for REMOVE-FROM-PLIST.")
+(define-modify-macro delete-from-plistf (&rest keys) delete-from-plist
+                     "Modify macro for DELETE-FROM-PLIST.")
+
+(declaim (inline sans))
+(defun sans (plist &rest keys)
+  "Alias of REMOVE-FROM-PLIST for backward compatibility."
+  (apply #'remove-from-plist plist keys))
+
+(defun mappend (function &rest lists)
+  "Applies FUNCTION to respective element(s) of each LIST, appending all the
+all the result list to a single list. FUNCTION must return a list."
+  (loop for results in (apply #'mapcar function lists)
+        append results))
+
+(defun setp (object &key (test #'eql) (key #'identity))
+  "Returns true if OBJECT is a list that denotes a set, NIL otherwise. A list
+denotes a set if each element of the list is unique under KEY and TEST."
+  (and (listp object)
+       (let (seen)
+         (dolist (elt object t)
+           (let ((key (funcall key elt)))
+             (if (member key seen :test test)
+                 (return nil)
+                 (push key seen)))))))
+
+(defun set-equal (list1 list2 &key (test #'eql) (key nil keyp))
+  "Returns true if every element of LIST1 matches some element of LIST2 and
+every element of LIST2 matches some element of LIST1. Otherwise returns false."
+  (let ((keylist1 (if keyp (mapcar key list1) list1))
+        (keylist2 (if keyp (mapcar key list2) list2)))
+    (and (dolist (elt keylist1 t)
+           (or (member elt keylist2 :test test)
+               (return nil)))
+         (dolist (elt keylist2 t)
+           (or (member elt keylist1 :test test)
+               (return nil))))))
+
+(defun map-product (function list &rest more-lists)
+  "Returns a list containing the results of calling FUNCTION with one argument
+from LIST, and one from each of MORE-LISTS for each combination of arguments.
+In other words, returns the product of LIST and MORE-LISTS using FUNCTION.
+
+Example:
+
+ (map-product 'list '(1 2) '(3 4) '(5 6))
+  => ((1 3 5) (1 3 6) (1 4 5) (1 4 6)
+      (2 3 5) (2 3 6) (2 4 5) (2 4 6))
+"
+  (labels ((%map-product (f lists)
+             (let ((more (cdr lists))
+                   (one (car lists)))
+               (if (not more)
+                   (mapcar f one)
+                   (mappend (lambda (x)
+                              (%map-product (curry f x) more))
+                            one)))))
+    (%map-product (ensure-function function) (cons list more-lists))))
+
+(defun flatten (tree)
+  "Traverses the tree in order, collecting non-null leaves into a list."
+  (let (list)
+    (labels ((traverse (subtree)
+               (when subtree
+                 (if (consp subtree)
+                     (progn
+                       (traverse (car subtree))
+                       (traverse (cdr subtree)))
+                     (push subtree list)))))
+      (traverse tree))
+    (nreverse list)))
diff --git a/third_party/lisp/alexandria/macros.lisp b/third_party/lisp/alexandria/macros.lisp
new file mode 100644
index 000000000000..4364ad63b82a
--- /dev/null
+++ b/third_party/lisp/alexandria/macros.lisp
@@ -0,0 +1,370 @@
+(in-package :alexandria)
+
+(defmacro with-gensyms (names &body forms)
+  "Binds a set of variables to gensyms and evaluates the implicit progn FORMS.
+
+Each element within NAMES is either a symbol SYMBOL or a pair (SYMBOL
+STRING-DESIGNATOR). Bare symbols are equivalent to the pair (SYMBOL SYMBOL).
+
+Each pair (SYMBOL STRING-DESIGNATOR) specifies that the variable named by SYMBOL
+should be bound to a symbol constructed using GENSYM with the string designated
+by STRING-DESIGNATOR being its first argument."
+  `(let ,(mapcar (lambda (name)
+                   (multiple-value-bind (symbol string)
+                       (etypecase name
+                         (symbol
+                          (values name (symbol-name name)))
+                         ((cons symbol (cons string-designator null))
+                          (values (first name) (string (second name)))))
+                     `(,symbol (gensym ,string))))
+                 names)
+     ,@forms))
+
+(defmacro with-unique-names (names &body forms)
+  "Alias for WITH-GENSYMS."
+  `(with-gensyms ,names ,@forms))
+
+(defmacro once-only (specs &body forms)
+  "Constructs code whose primary goal is to help automate the handling of
+multiple evaluation within macros. Multiple evaluation is handled by introducing
+intermediate variables, in order to reuse the result of an expression.
+
+The returned value is a list of the form
+
+  (let ((<gensym-1> <expr-1>)
+        ...
+        (<gensym-n> <expr-n>))
+    <res>)
+
+where GENSYM-1, ..., GENSYM-N are the intermediate variables introduced in order
+to evaluate EXPR-1, ..., EXPR-N once, only. RES is code that is the result of
+evaluating the implicit progn FORMS within a special context determined by
+SPECS. RES should make use of (reference) the intermediate variables.
+
+Each element within SPECS is either a symbol SYMBOL or a pair (SYMBOL INITFORM).
+Bare symbols are equivalent to the pair (SYMBOL SYMBOL).
+
+Each pair (SYMBOL INITFORM) specifies a single intermediate variable:
+
+- INITFORM is an expression evaluated to produce EXPR-i
+
+- SYMBOL is the name of the variable that will be bound around FORMS to the
+  corresponding gensym GENSYM-i, in order for FORMS to generate RES that
+  references the intermediate variable
+
+The evaluation of INITFORMs and binding of SYMBOLs resembles LET. INITFORMs of
+all the pairs are evaluated before binding SYMBOLs and evaluating FORMS.
+
+Example:
+
+  The following expression
+
+  (let ((x '(incf y)))
+    (once-only (x)
+      `(cons ,x ,x)))
+
+  ;;; =>
+  ;;; (let ((#1=#:X123 (incf y)))
+  ;;;   (cons #1# #1#))
+
+  could be used within a macro to avoid multiple evaluation like so
+
+  (defmacro cons1 (x)
+    (once-only (x)
+      `(cons ,x ,x)))
+
+  (let ((y 0))
+    (cons1 (incf y)))
+
+  ;;; => (1 . 1)
+
+Example:
+
+  The following expression demonstrates the usage of the INITFORM field
+
+  (let ((expr '(incf y)))
+    (once-only ((var `(1+ ,expr)))
+      `(list ',expr ,var ,var)))
+
+  ;;; =>
+  ;;; (let ((#1=#:VAR123 (1+ (incf y))))
+  ;;;   (list '(incf y) #1# #1))
+
+  which could be used like so
+
+  (defmacro print-succ-twice (expr)
+    (once-only ((var `(1+ ,expr)))
+      `(format t \"Expr: ~s, Once: ~s, Twice: ~s~%\" ',expr ,var ,var)))
+
+  (let ((y 10))
+    (print-succ-twice (incf y)))
+
+  ;;; >>
+  ;;; Expr: (INCF Y), Once: 12, Twice: 12"
+  (let ((gensyms (make-gensym-list (length specs) "ONCE-ONLY"))
+        (names-and-forms (mapcar (lambda (spec)
+                                   (etypecase spec
+                                     (list
+                                      (destructuring-bind (name form) spec
+                                        (cons name form)))
+                                     (symbol
+                                      (cons spec spec))))
+                                 specs)))
+    ;; bind in user-macro
+    `(let ,(mapcar (lambda (g n) (list g `(gensym ,(string (car n)))))
+                   gensyms names-and-forms)
+       ;; bind in final expansion
+       `(let (,,@(mapcar (lambda (g n)
+                           ``(,,g ,,(cdr n)))
+                         gensyms names-and-forms))
+          ;; bind in user-macro
+          ,(let ,(mapcar (lambda (n g) (list (car n) g))
+                         names-and-forms gensyms)
+             ,@forms)))))
+
+(defun parse-body (body &key documentation whole)
+  "Parses BODY into (values remaining-forms declarations doc-string).
+Documentation strings are recognized only if DOCUMENTATION is true.
+Syntax errors in body are signalled and WHOLE is used in the signal
+arguments when given."
+  (let ((doc nil)
+        (decls nil)
+        (current nil))
+    (tagbody
+     :declarations
+       (setf current (car body))
+       (when (and documentation (stringp current) (cdr body))
+         (if doc
+             (error "Too many documentation strings in ~S." (or whole body))
+             (setf doc (pop body)))
+         (go :declarations))
+       (when (and (listp current) (eql (first current) 'declare))
+         (push (pop body) decls)
+         (go :declarations)))
+    (values body (nreverse decls) doc)))
+
+(defun parse-ordinary-lambda-list (lambda-list &key (normalize t)
+                                   allow-specializers
+                                   (normalize-optional normalize)
+                                   (normalize-keyword normalize)
+                                   (normalize-auxilary normalize))
+  "Parses an ordinary lambda-list, returning as multiple values:
+
+1. Required parameters.
+
+2. Optional parameter specifications, normalized into form:
+
+   (name init suppliedp)
+
+3. Name of the rest parameter, or NIL.
+
+4. Keyword parameter specifications, normalized into form:
+
+   ((keyword-name name) init suppliedp)
+
+5. Boolean indicating &ALLOW-OTHER-KEYS presence.
+
+6. &AUX parameter specifications, normalized into form
+
+   (name init).
+
+7. Existence of &KEY in the lambda-list.
+
+Signals a PROGRAM-ERROR is the lambda-list is malformed."
+  (let ((state :required)
+        (allow-other-keys nil)
+        (auxp nil)
+        (required nil)
+        (optional nil)
+        (rest nil)
+        (keys nil)
+        (keyp nil)
+        (aux nil))
+    (labels ((fail (elt)
+               (simple-program-error "Misplaced ~S in ordinary lambda-list:~%  ~S"
+                                     elt lambda-list))
+             (check-variable (elt what &optional (allow-specializers allow-specializers))
+               (unless (and (or (symbolp elt)
+                                (and allow-specializers
+                                     (consp elt) (= 2 (length elt)) (symbolp (first elt))))
+                            (not (constantp elt)))
+                 (simple-program-error "Invalid ~A ~S in ordinary lambda-list:~%  ~S"
+                                       what elt lambda-list)))
+             (check-spec (spec what)
+               (destructuring-bind (init suppliedp) spec
+                 (declare (ignore init))
+                 (check-variable suppliedp what nil))))
+      (dolist (elt lambda-list)
+        (case elt
+          (&optional
+           (if (eq state :required)
+               (setf state elt)
+               (fail elt)))
+          (&rest
+           (if (member state '(:required &optional))
+               (setf state elt)
+               (fail elt)))
+          (&key
+           (if (member state '(:required &optional :after-rest))
+               (setf state elt)
+               (fail elt))
+           (setf keyp t))
+          (&allow-other-keys
+           (if (eq state '&key)
+               (setf allow-other-keys t
+                     state elt)
+               (fail elt)))
+          (&aux
+           (cond ((eq state '&rest)
+                  (fail elt))
+                 (auxp
+                  (simple-program-error "Multiple ~S in ordinary lambda-list:~%  ~S"
+                                        elt lambda-list))
+                 (t
+                  (setf auxp t
+                        state elt))
+                 ))
+          (otherwise
+           (when (member elt '#.(set-difference lambda-list-keywords
+                                                '(&optional &rest &key &allow-other-keys &aux)))
+             (simple-program-error
+              "Bad lambda-list keyword ~S in ordinary lambda-list:~%  ~S"
+              elt lambda-list))
+           (case state
+             (:required
+              (check-variable elt "required parameter")
+              (push elt required))
+             (&optional
+              (cond ((consp elt)
+                     (destructuring-bind (name &rest tail) elt
+                       (check-variable name "optional parameter")
+                       (cond ((cdr tail)
+                              (check-spec tail "optional-supplied-p parameter"))
+                             ((and normalize-optional tail)
+                              (setf elt (append elt '(nil))))
+                             (normalize-optional
+                              (setf elt (append elt '(nil nil)))))))
+                    (t
+                     (check-variable elt "optional parameter")
+                     (when normalize-optional
+                       (setf elt (cons elt '(nil nil))))))
+              (push (ensure-list elt) optional))
+             (&rest
+              (check-variable elt "rest parameter")
+              (setf rest elt
+                    state :after-rest))
+             (&key
+              (cond ((consp elt)
+                     (destructuring-bind (var-or-kv &rest tail) elt
+                       (cond ((consp var-or-kv)
+                              (destructuring-bind (keyword var) var-or-kv
+                                (unless (symbolp keyword)
+                                  (simple-program-error "Invalid keyword name ~S in ordinary ~
+                                                         lambda-list:~%  ~S"
+                                                        keyword lambda-list))
+                                (check-variable var "keyword parameter")))
+                             (t
+                              (check-variable var-or-kv "keyword parameter")
+                              (when normalize-keyword
+                                (setf var-or-kv (list (make-keyword var-or-kv) var-or-kv)))))
+                       (cond ((cdr tail)
+                              (check-spec tail "keyword-supplied-p parameter"))
+                             ((and normalize-keyword tail)
+                              (setf tail (append tail '(nil))))
+                             (normalize-keyword
+                              (setf tail '(nil nil))))
+                       (setf elt (cons var-or-kv tail))))
+                    (t
+                     (check-variable elt "keyword parameter")
+                     (setf elt (if normalize-keyword
+                                   (list (list (make-keyword elt) elt) nil nil)
+                                   elt))))
+              (push elt keys))
+             (&aux
+              (if (consp elt)
+                  (destructuring-bind (var &optional init) elt
+                    (declare (ignore init))
+                    (check-variable var "&aux parameter"))
+                  (progn
+                    (check-variable elt "&aux parameter")
+                    (setf elt (list* elt (when normalize-auxilary
+                                           '(nil))))))
+              (push elt aux))
+             (t
+              (simple-program-error "Invalid ordinary lambda-list:~%  ~S" lambda-list)))))))
+    (values (nreverse required) (nreverse optional) rest (nreverse keys)
+            allow-other-keys (nreverse aux) keyp)))
+
+;;;; DESTRUCTURING-*CASE
+
+(defun expand-destructuring-case (key clauses case)
+  (once-only (key)
+    `(if (typep ,key 'cons)
+         (,case (car ,key)
+           ,@(mapcar (lambda (clause)
+                       (destructuring-bind ((keys . lambda-list) &body body) clause
+                         `(,keys
+                           (destructuring-bind ,lambda-list (cdr ,key)
+                             ,@body))))
+                     clauses))
+         (error "Invalid key to DESTRUCTURING-~S: ~S" ',case ,key))))
+
+(defmacro destructuring-case (keyform &body clauses)
+  "DESTRUCTURING-CASE, -CCASE, and -ECASE are a combination of CASE and DESTRUCTURING-BIND.
+KEYFORM must evaluate to a CONS.
+
+Clauses are of the form:
+
+  ((CASE-KEYS . DESTRUCTURING-LAMBDA-LIST) FORM*)
+
+The clause whose CASE-KEYS matches CAR of KEY, as if by CASE, CCASE, or ECASE,
+is selected, and FORMs are then executed with CDR of KEY is destructured and
+bound by the DESTRUCTURING-LAMBDA-LIST.
+
+Example:
+
+ (defun dcase (x)
+   (destructuring-case x
+     ((:foo a b)
+      (format nil \"foo: ~S, ~S\" a b))
+     ((:bar &key a b)
+      (format nil \"bar: ~S, ~S\" a b))
+     (((:alt1 :alt2) a)
+      (format nil \"alt: ~S\" a))
+     ((t &rest rest)
+      (format nil \"unknown: ~S\" rest))))
+
+  (dcase (list :foo 1 2))        ; => \"foo: 1, 2\"
+  (dcase (list :bar :a 1 :b 2))  ; => \"bar: 1, 2\"
+  (dcase (list :alt1 1))         ; => \"alt: 1\"
+  (dcase (list :alt2 2))         ; => \"alt: 2\"
+  (dcase (list :quux 1 2 3))     ; => \"unknown: 1, 2, 3\"
+
+ (defun decase (x)
+   (destructuring-case x
+     ((:foo a b)
+      (format nil \"foo: ~S, ~S\" a b))
+     ((:bar &key a b)
+      (format nil \"bar: ~S, ~S\" a b))
+     (((:alt1 :alt2) a)
+      (format nil \"alt: ~S\" a))))
+
+  (decase (list :foo 1 2))        ; => \"foo: 1, 2\"
+  (decase (list :bar :a 1 :b 2))  ; => \"bar: 1, 2\"
+  (decase (list :alt1 1))         ; => \"alt: 1\"
+  (decase (list :alt2 2))         ; => \"alt: 2\"
+  (decase (list :quux 1 2 3))     ; =| error
+"
+  (expand-destructuring-case keyform clauses 'case))
+
+(defmacro destructuring-ccase (keyform &body clauses)
+  (expand-destructuring-case keyform clauses 'ccase))
+
+(defmacro destructuring-ecase (keyform &body clauses)
+  (expand-destructuring-case keyform clauses 'ecase))
+
+(dolist (name '(destructuring-ccase destructuring-ecase))
+  (setf (documentation name 'function) (documentation 'destructuring-case 'function)))
+
+
+
diff --git a/third_party/lisp/alexandria/numbers.lisp b/third_party/lisp/alexandria/numbers.lisp
new file mode 100644
index 000000000000..1c06f71d508f
--- /dev/null
+++ b/third_party/lisp/alexandria/numbers.lisp
@@ -0,0 +1,295 @@
+(in-package :alexandria)
+
+(declaim (inline clamp))
+(defun clamp (number min max)
+  "Clamps the NUMBER into [min, max] range. Returns MIN if NUMBER is lesser then
+MIN and MAX if NUMBER is greater then MAX, otherwise returns NUMBER."
+  (if (< number min)
+      min
+      (if (> number max)
+          max
+          number)))
+
+(defun gaussian-random (&optional min max)
+  "Returns two gaussian random double floats as the primary and secondary value,
+optionally constrained by MIN and MAX. Gaussian random numbers form a standard
+normal distribution around 0.0d0.
+
+Sufficiently positive MIN or negative MAX will cause the algorithm used to
+take a very long time. If MIN is positive it should be close to zero, and
+similarly if MAX is negative it should be close to zero."
+  (macrolet
+      ((valid (x)
+         `(<= (or min ,x) ,x (or max ,x)) ))
+    (labels
+        ((gauss ()
+           (loop
+                 for x1 = (- (random 2.0d0) 1.0d0)
+                 for x2 = (- (random 2.0d0) 1.0d0)
+                 for w = (+ (expt x1 2) (expt x2 2))
+                 when (< w 1.0d0)
+                 do (let ((v (sqrt (/ (* -2.0d0 (log w)) w))))
+                      (return (values (* x1 v) (* x2 v))))))
+         (guard (x)
+           (unless (valid x)
+             (tagbody
+              :retry
+                (multiple-value-bind (x1 x2) (gauss)
+                  (when (valid x1)
+                    (setf x x1)
+                    (go :done))
+                  (when (valid x2)
+                    (setf x x2)
+                    (go :done))
+                  (go :retry))
+              :done))
+           x))
+      (multiple-value-bind
+            (g1 g2) (gauss)
+        (values (guard g1) (guard g2))))))
+
+(declaim (inline iota))
+(defun iota (n &key (start 0) (step 1))
+  "Return a list of n numbers, starting from START (with numeric contagion
+from STEP applied), each consequtive number being the sum of the previous one
+and STEP. START defaults to 0 and STEP to 1.
+
+Examples:
+
+  (iota 4)                      => (0 1 2 3)
+  (iota 3 :start 1 :step 1.0)   => (1.0 2.0 3.0)
+  (iota 3 :start -1 :step -1/2) => (-1 -3/2 -2)
+"
+  (declare (type (integer 0) n) (number start step))
+  (loop ;; KLUDGE: get numeric contagion right for the first element too
+        for i = (+ (- (+ start step) step)) then (+ i step)
+        repeat n
+        collect i))
+
+(declaim (inline map-iota))
+(defun map-iota (function n &key (start 0) (step 1))
+  "Calls FUNCTION with N numbers, starting from START (with numeric contagion
+from STEP applied), each consequtive number being the sum of the previous one
+and STEP. START defaults to 0 and STEP to 1. Returns N.
+
+Examples:
+
+  (map-iota #'print 3 :start 1 :step 1.0) => 3
+    ;;; 1.0
+    ;;; 2.0
+    ;;; 3.0
+"
+  (declare (type (integer 0) n) (number start step))
+  (loop ;; KLUDGE: get numeric contagion right for the first element too
+        for i = (+ start (- step step)) then (+ i step)
+        repeat n
+        do (funcall function i))
+  n)
+
+(declaim (inline lerp))
+(defun lerp (v a b)
+  "Returns the result of linear interpolation between A and B, using the
+interpolation coefficient V."
+  ;; The correct version is numerically stable, at the expense of an
+  ;; extra multiply. See (lerp 0.1 4 25) with (+ a (* v (- b a))). The
+  ;; unstable version can often be converted to a fast instruction on
+  ;; a lot of machines, though this is machine/implementation
+  ;; specific. As alexandria is more about correct code, than
+  ;; efficiency, and we're only talking about a single extra multiply,
+  ;; many would prefer the stable version
+  (+ (* (- 1.0 v) a) (* v b)))
+
+(declaim (inline mean))
+(defun mean (sample)
+  "Returns the mean of SAMPLE. SAMPLE must be a sequence of numbers."
+  (/ (reduce #'+ sample) (length sample)))
+
+(defun median (sample)
+  "Returns median of SAMPLE. SAMPLE must be a sequence of real numbers."
+  ;; Implements and uses the quick-select algorithm to find the median
+  ;; https://en.wikipedia.org/wiki/Quickselect
+
+  (labels ((randint-in-range (start-int end-int)
+             "Returns a random integer in the specified range, inclusive"
+             (+ start-int (random (1+ (- end-int start-int)))))
+           (partition (vec start-i end-i)
+             "Implements the partition function, which performs a partial
+              sort of vec around the (randomly) chosen pivot.
+              Returns the index where the pivot element would be located
+              in a correctly-sorted array"
+             (if (= start-i end-i)
+                 start-i
+                 (let ((pivot-i (randint-in-range start-i end-i)))
+                   (rotatef (aref vec start-i) (aref vec pivot-i))
+                   (let ((swap-i end-i))
+                     (loop for i from swap-i downto (1+ start-i) do
+                       (when (>= (aref vec i) (aref vec start-i))
+                         (rotatef (aref vec i) (aref vec swap-i))
+                         (decf swap-i)))
+                     (rotatef (aref vec swap-i) (aref vec start-i))
+                     swap-i)))))
+
+    (let* ((vector (copy-sequence 'vector sample))
+           (len (length vector))
+           (mid-i (ash len -1))
+           (i 0)
+           (j (1- len)))
+
+      (loop for correct-pos = (partition vector i j)
+            while (/= correct-pos mid-i) do
+              (if (< correct-pos mid-i)
+                  (setf i (1+ correct-pos))
+                  (setf j (1- correct-pos))))
+
+      (if (oddp len)
+          (aref vector mid-i)
+          (* 1/2
+             (+ (aref vector mid-i)
+                (reduce #'max (make-array
+                               mid-i
+                               :displaced-to vector))))))))
+
+(declaim (inline variance))
+(defun variance (sample &key (biased t))
+  "Variance of SAMPLE. Returns the biased variance if BIASED is true (the default),
+and the unbiased estimator of variance if BIASED is false. SAMPLE must be a
+sequence of numbers."
+  (let ((mean (mean sample)))
+    (/ (reduce (lambda (a b)
+                 (+ a (expt (- b mean) 2)))
+               sample
+               :initial-value 0)
+       (- (length sample) (if biased 0 1)))))
+
+(declaim (inline standard-deviation))
+(defun standard-deviation (sample &key (biased t))
+  "Standard deviation of SAMPLE. Returns the biased standard deviation if
+BIASED is true (the default), and the square root of the unbiased estimator
+for variance if BIASED is false (which is not the same as the unbiased
+estimator for standard deviation). SAMPLE must be a sequence of numbers."
+  (sqrt (variance sample :biased biased)))
+
+(define-modify-macro maxf (&rest numbers) max
+  "Modify-macro for MAX. Sets place designated by the first argument to the
+maximum of its original value and NUMBERS.")
+
+(define-modify-macro minf (&rest numbers) min
+  "Modify-macro for MIN. Sets place designated by the first argument to the
+minimum of its original value and NUMBERS.")
+
+;;;; Factorial
+
+;;; KLUDGE: This is really dependant on the numbers in question: for
+;;; small numbers this is larger, and vice versa. Ideally instead of a
+;;; constant we would have RANGE-FAST-TO-MULTIPLY-DIRECTLY-P.
+(defconstant +factorial-bisection-range-limit+ 8)
+
+;;; KLUDGE: This is really platform dependant: ideally we would use
+;;; (load-time-value (find-good-direct-multiplication-limit)) instead.
+(defconstant +factorial-direct-multiplication-limit+ 13)
+
+(defun %multiply-range (i j)
+  ;; We use a a bit of cleverness here:
+  ;;
+  ;; 1. For large factorials we bisect in order to avoid expensive bignum
+  ;;    multiplications: 1 x 2 x 3 x ... runs into bignums pretty soon,
+  ;;    and once it does that all further multiplications will be with bignums.
+  ;;
+  ;;    By instead doing the multiplication in a tree like
+  ;;       ((1 x 2) x (3 x 4)) x ((5 x 6) x (7 x 8))
+  ;;    we manage to get less bignums.
+  ;;
+  ;; 2. Division isn't exactly free either, however, so we don't bisect
+  ;;    all the way down, but multiply ranges of integers close to each
+  ;;    other directly.
+  ;;
+  ;; For even better results it should be possible to use prime
+  ;; factorization magic, but Nikodemus ran out of steam.
+  ;;
+  ;; KLUDGE: We support factorials of bignums, but it seems quite
+  ;; unlikely anyone would ever be able to use them on a modern lisp,
+  ;; since the resulting numbers are unlikely to fit in memory... but
+  ;; it would be extremely unelegant to define FACTORIAL only on
+  ;; fixnums, _and_ on lisps with 16 bit fixnums this can actually be
+  ;; needed.
+  (labels ((bisect (j k)
+             (declare (type (integer 1 #.most-positive-fixnum) j k))
+             (if (< (- k j) +factorial-bisection-range-limit+)
+                 (multiply-range j k)
+                 (let ((middle (+ j (truncate (- k j) 2))))
+                   (* (bisect j middle)
+                      (bisect (+ middle 1) k)))))
+           (bisect-big (j k)
+             (declare (type (integer 1) j k))
+             (if (= j k)
+                 j
+                 (let ((middle (+ j (truncate (- k j) 2))))
+                   (* (if (<= middle most-positive-fixnum)
+                          (bisect j middle)
+                          (bisect-big j middle))
+                      (bisect-big (+ middle 1) k)))))
+           (multiply-range (j k)
+             (declare (type (integer 1 #.most-positive-fixnum) j k))
+             (do ((f k (* f m))
+                  (m (1- k) (1- m)))
+                 ((< m j) f)
+               (declare (type (integer 0 (#.most-positive-fixnum)) m)
+                        (type unsigned-byte f)))))
+    (if (and (typep i 'fixnum) (typep j 'fixnum))
+        (bisect i j)
+        (bisect-big i j))))
+
+(declaim (inline factorial))
+(defun %factorial (n)
+  (if (< n 2)
+      1
+      (%multiply-range 1 n)))
+
+(defun factorial (n)
+  "Factorial of non-negative integer N."
+  (check-type n (integer 0))
+  (%factorial n))
+
+;;;; Combinatorics
+
+(defun binomial-coefficient (n k)
+  "Binomial coefficient of N and K, also expressed as N choose K. This is the
+number of K element combinations given N choises. N must be equal to or
+greater then K."
+  (check-type n (integer 0))
+  (check-type k (integer 0))
+  (assert (>= n k))
+  (if (or (zerop k) (= n k))
+      1
+      (let ((n-k (- n k)))
+        ;; Swaps K and N-K if K < N-K because the algorithm
+        ;; below is faster for bigger K and smaller N-K
+        (when (< k n-k)
+          (rotatef k n-k))
+        (if (= 1 n-k)
+            n
+            ;; General case, avoid computing the 1x...xK twice:
+            ;;
+            ;;    N!           1x...xN          (K+1)x...xN
+            ;; --------  =  ---------------- =  ------------, N>1
+            ;; K!(N-K)!     1x...xK x (N-K)!       (N-K)!
+            (/ (%multiply-range (+ k 1) n)
+               (%factorial n-k))))))
+
+(defun subfactorial (n)
+  "Subfactorial of the non-negative integer N."
+  (check-type n (integer 0))
+  (if (zerop n)
+      1
+      (do ((x 1 (1+ x))
+           (a 0 (* x (+ a b)))
+           (b 1 a))
+          ((= n x) a))))
+
+(defun count-permutations (n &optional (k n))
+  "Number of K element permutations for a sequence of N objects.
+K defaults to N"
+  (check-type n (integer 0))
+  (check-type k (integer 0))
+  (assert (>= n k))
+  (%multiply-range (1+ (- n k)) n))
diff --git a/third_party/lisp/alexandria/package.lisp b/third_party/lisp/alexandria/package.lisp
new file mode 100644
index 000000000000..f9d2014cd7b5
--- /dev/null
+++ b/third_party/lisp/alexandria/package.lisp
@@ -0,0 +1,243 @@
+(defpackage :alexandria.1.0.0
+  (:nicknames :alexandria)
+  (:use :cl)
+  #+sb-package-locks
+  (:lock t)
+  (:export
+   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+   ;; BLESSED
+   ;;
+   ;; Binding constructs
+   #:if-let
+   #:when-let
+   #:when-let*
+   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+   ;; REVIEW IN PROGRESS
+   ;;
+   ;; Control flow
+   ;;
+   ;; -- no clear consensus yet --
+   #:cswitch
+   #:eswitch
+   #:switch
+   ;; -- problem free? --
+   #:multiple-value-prog2
+   #:nth-value-or
+   #:whichever
+   #:xor
+   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+   ;; REVIEW PENDING
+   ;;
+   ;; Definitions
+   #:define-constant
+   ;; Hash tables
+   #:alist-hash-table
+   #:copy-hash-table
+   #:ensure-gethash
+   #:hash-table-alist
+   #:hash-table-keys
+   #:hash-table-plist
+   #:hash-table-values
+   #:maphash-keys
+   #:maphash-values
+   #:plist-hash-table
+   ;; Functions
+   #:compose
+   #:conjoin
+   #:curry
+   #:disjoin
+   #:ensure-function
+   #:ensure-functionf
+   #:multiple-value-compose
+   #:named-lambda
+   #:rcurry
+   ;; Lists
+   #:alist-plist
+   #:appendf
+   #:nconcf
+   #:reversef
+   #:nreversef
+   #:circular-list
+   #:circular-list-p
+   #:circular-tree-p
+   #:doplist
+   #:ensure-car
+   #:ensure-cons
+   #:ensure-list
+   #:flatten
+   #:lastcar
+   #:make-circular-list
+   #:map-product
+   #:mappend
+   #:nunionf
+   #:plist-alist
+   #:proper-list
+   #:proper-list-length
+   #:proper-list-p
+   #:remove-from-plist
+   #:remove-from-plistf
+   #:delete-from-plist
+   #:delete-from-plistf
+   #:set-equal
+   #:setp
+   #:unionf
+   ;; Numbers
+   #:binomial-coefficient
+   #:clamp
+   #:count-permutations
+   #:factorial
+   #:gaussian-random
+   #:iota
+   #:lerp
+   #:map-iota
+   #:maxf
+   #:mean
+   #:median
+   #:minf
+   #:standard-deviation
+   #:subfactorial
+   #:variance
+   ;; Arrays
+   #:array-index
+   #:array-length
+   #:copy-array
+   ;; Sequences
+   #:copy-sequence
+   #:deletef
+   #:emptyp
+   #:ends-with
+   #:ends-with-subseq
+   #:extremum
+   #:first-elt
+   #:last-elt
+   #:length=
+   #:map-combinations
+   #:map-derangements
+   #:map-permutations
+   #:proper-sequence
+   #:random-elt
+   #:removef
+   #:rotate
+   #:sequence-of-length-p
+   #:shuffle
+   #:starts-with
+   #:starts-with-subseq
+   ;; Macros
+   #:once-only
+   #:parse-body
+   #:parse-ordinary-lambda-list
+   #:with-gensyms
+   #:with-unique-names
+   ;; Symbols
+   #:ensure-symbol
+   #:format-symbol
+   #:make-gensym
+   #:make-gensym-list
+   #:make-keyword
+   ;; Strings
+   #:string-designator
+   ;; Types
+   #:negative-double-float
+   #:negative-fixnum-p
+   #:negative-float
+   #:negative-float-p
+   #:negative-long-float
+   #:negative-long-float-p
+   #:negative-rational
+   #:negative-rational-p
+   #:negative-real
+   #:negative-single-float-p
+   #:non-negative-double-float
+   #:non-negative-double-float-p
+   #:non-negative-fixnum
+   #:non-negative-fixnum-p
+   #:non-negative-float
+   #:non-negative-float-p
+   #:non-negative-integer-p
+   #:non-negative-long-float
+   #:non-negative-rational
+   #:non-negative-real-p
+   #:non-negative-short-float-p
+   #:non-negative-single-float
+   #:non-negative-single-float-p
+   #:non-positive-double-float
+   #:non-positive-double-float-p
+   #:non-positive-fixnum
+   #:non-positive-fixnum-p
+   #:non-positive-float
+   #:non-positive-float-p
+   #:non-positive-integer
+   #:non-positive-rational
+   #:non-positive-real
+   #:non-positive-real-p
+   #:non-positive-short-float
+   #:non-positive-short-float-p
+   #:non-positive-single-float-p
+   #:positive-double-float
+   #:positive-double-float-p
+   #:positive-fixnum
+   #:positive-fixnum-p
+   #:positive-float
+   #:positive-float-p
+   #:positive-integer
+   #:positive-rational
+   #:positive-real
+   #:positive-real-p
+   #:positive-short-float
+   #:positive-short-float-p
+   #:positive-single-float
+   #:positive-single-float-p
+   #:coercef
+   #:negative-double-float-p
+   #:negative-fixnum
+   #:negative-integer
+   #:negative-integer-p
+   #:negative-real-p
+   #:negative-short-float
+   #:negative-short-float-p
+   #:negative-single-float
+   #:non-negative-integer
+   #:non-negative-long-float-p
+   #:non-negative-rational-p
+   #:non-negative-real
+   #:non-negative-short-float
+   #:non-positive-integer-p
+   #:non-positive-long-float
+   #:non-positive-long-float-p
+   #:non-positive-rational-p
+   #:non-positive-single-float
+   #:of-type
+   #:positive-integer-p
+   #:positive-long-float
+   #:positive-long-float-p
+   #:positive-rational-p
+   #:type=
+   ;; Conditions
+   #:required-argument
+   #:ignore-some-conditions
+   #:simple-style-warning
+   #:simple-reader-error
+   #:simple-parse-error
+   #:simple-program-error
+   #:unwind-protect-case
+   ;; Features
+   #:featurep
+   ;; io
+   #:with-input-from-file
+   #:with-output-to-file
+   #:read-stream-content-into-string
+   #:read-file-into-string
+   #:write-string-into-file
+   #:read-stream-content-into-byte-vector
+   #:read-file-into-byte-vector
+   #:write-byte-vector-into-file
+   #:copy-stream
+   #:copy-file
+   ;; new additions collected at the end (subject to removal or further changes)
+   #:symbolicate
+   #:assoc-value
+   #:rassoc-value
+   #:destructuring-case
+   #:destructuring-ccase
+   #:destructuring-ecase
+   ))
diff --git a/third_party/lisp/alexandria/sequences.lisp b/third_party/lisp/alexandria/sequences.lisp
new file mode 100644
index 000000000000..21464f537610
--- /dev/null
+++ b/third_party/lisp/alexandria/sequences.lisp
@@ -0,0 +1,555 @@
+(in-package :alexandria)
+
+;; Make these inlinable by declaiming them INLINE here and some of them
+;; NOTINLINE at the end of the file. Exclude functions that have a compiler
+;; macro, because NOTINLINE is required to prevent compiler-macro expansion.
+(declaim (inline copy-sequence sequence-of-length-p))
+
+(defun sequence-of-length-p (sequence length)
+  "Return true if SEQUENCE is a sequence of length LENGTH. Signals an error if
+SEQUENCE is not a sequence. Returns FALSE for circular lists."
+  (declare (type array-index length)
+           #-lispworks (inline length)
+           (optimize speed))
+  (etypecase sequence
+    (null
+     (zerop length))
+    (cons
+     (let ((n (1- length)))
+       (unless (minusp n)
+         (let ((tail (nthcdr n sequence)))
+           (and tail
+                (null (cdr tail)))))))
+    (vector
+     (= length (length sequence)))
+    (sequence
+     (= length (length sequence)))))
+
+(defun rotate-tail-to-head (sequence n)
+  (declare (type (integer 1) n))
+  (if (listp sequence)
+      (let ((m (mod n (proper-list-length sequence))))
+        (if (null (cdr sequence))
+            sequence
+            (let* ((tail (last sequence (+ m 1)))
+                   (last (cdr tail)))
+              (setf (cdr tail) nil)
+              (nconc last sequence))))
+      (let* ((len (length sequence))
+             (m (mod n len))
+             (tail (subseq sequence (- len m))))
+        (replace sequence sequence :start1 m :start2 0)
+        (replace sequence tail)
+        sequence)))
+
+(defun rotate-head-to-tail (sequence n)
+  (declare (type (integer 1) n))
+  (if (listp sequence)
+      (let ((m (mod (1- n) (proper-list-length sequence))))
+        (if (null (cdr sequence))
+            sequence
+            (let* ((headtail (nthcdr m sequence))
+                   (tail (cdr headtail)))
+              (setf (cdr headtail) nil)
+              (nconc tail sequence))))
+      (let* ((len (length sequence))
+             (m (mod n len))
+             (head (subseq sequence 0 m)))
+        (replace sequence sequence :start1 0 :start2 m)
+        (replace sequence head :start1 (- len m))
+        sequence)))
+
+(defun rotate (sequence &optional (n 1))
+  "Returns a sequence of the same type as SEQUENCE, with the elements of
+SEQUENCE rotated by N: N elements are moved from the end of the sequence to
+the front if N is positive, and -N elements moved from the front to the end if
+N is negative. SEQUENCE must be a proper sequence. N must be an integer,
+defaulting to 1.
+
+If absolute value of N is greater then the length of the sequence, the results
+are identical to calling ROTATE with
+
+  (* (signum n) (mod n (length sequence))).
+
+Note: the original sequence may be destructively altered, and result sequence may
+share structure with it."
+  (if (plusp n)
+      (rotate-tail-to-head sequence n)
+      (if (minusp n)
+          (rotate-head-to-tail sequence (- n))
+          sequence)))
+
+(defun shuffle (sequence &key (start 0) end)
+  "Returns a random permutation of SEQUENCE bounded by START and END.
+Original sequence may be destructively modified, and (if it contains
+CONS or lists themselv) share storage with the original one.
+Signals an error if SEQUENCE is not a proper sequence."
+  (declare (type fixnum start)
+           (type (or fixnum null) end))
+  (etypecase sequence
+    (list
+     (let* ((end (or end (proper-list-length sequence)))
+            (n (- end start)))
+       (do ((tail (nthcdr start sequence) (cdr tail)))
+           ((zerop n))
+         (rotatef (car tail) (car (nthcdr (random n) tail)))
+         (decf n))))
+    (vector
+     (let ((end (or end (length sequence))))
+       (loop for i from start below end
+             do (rotatef (aref sequence i)
+                         (aref sequence (+ i (random (- end i))))))))
+    (sequence
+     (let ((end (or end (length sequence))))
+       (loop for i from (- end 1) downto start
+             do (rotatef (elt sequence i)
+                         (elt sequence (+ i (random (- end i)))))))))
+  sequence)
+
+(defun random-elt (sequence &key (start 0) end)
+  "Returns a random element from SEQUENCE bounded by START and END. Signals an
+error if the SEQUENCE is not a proper non-empty sequence, or if END and START
+are not proper bounding index designators for SEQUENCE."
+  (declare (sequence sequence) (fixnum start) (type (or fixnum null) end))
+  (let* ((size (if (listp sequence)
+                   (proper-list-length sequence)
+                   (length sequence)))
+         (end2 (or end size)))
+    (cond ((zerop size)
+           (error 'type-error
+                  :datum sequence
+                  :expected-type `(and sequence (not (satisfies emptyp)))))
+          ((not (and (<= 0 start) (< start end2) (<= end2 size)))
+           (error 'simple-type-error
+                  :datum (cons start end)
+                  :expected-type `(cons (integer 0 (,end2))
+                                        (or null (integer (,start) ,size)))
+                  :format-control "~@<~S and ~S are not valid bounding index designators for ~
+                                   a sequence of length ~S.~:@>"
+                  :format-arguments (list start end size)))
+          (t
+           (let ((index (+ start (random (- end2 start)))))
+             (elt sequence index))))))
+
+(declaim (inline remove/swapped-arguments))
+(defun remove/swapped-arguments (sequence item &rest keyword-arguments)
+  (apply #'remove item sequence keyword-arguments))
+
+(define-modify-macro removef (item &rest keyword-arguments)
+  remove/swapped-arguments
+  "Modify-macro for REMOVE. Sets place designated by the first argument to
+the result of calling REMOVE with ITEM, place, and the KEYWORD-ARGUMENTS.")
+
+(declaim (inline delete/swapped-arguments))
+(defun delete/swapped-arguments (sequence item &rest keyword-arguments)
+  (apply #'delete item sequence keyword-arguments))
+
+(define-modify-macro deletef (item &rest keyword-arguments)
+  delete/swapped-arguments
+  "Modify-macro for DELETE. Sets place designated by the first argument to
+the result of calling DELETE with ITEM, place, and the KEYWORD-ARGUMENTS.")
+
+(deftype proper-sequence ()
+  "Type designator for proper sequences, that is proper lists and sequences
+that are not lists."
+  `(or proper-list
+       (and (not list) sequence)))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (when (and (find-package '#:sequence)
+             (find-symbol (string '#:emptyp) '#:sequence))
+    (pushnew 'sequence-emptyp *features*)))
+
+#-alexandria::sequence-emptyp
+(defun emptyp (sequence)
+  "Returns true if SEQUENCE is an empty sequence. Signals an error if SEQUENCE
+is not a sequence."
+  (etypecase sequence
+    (list (null sequence))
+    (sequence (zerop (length sequence)))))
+
+#+alexandria::sequence-emptyp
+(declaim (ftype (function (sequence) (values boolean &optional)) emptyp))
+#+alexandria::sequence-emptyp
+(setf (symbol-function 'emptyp) (symbol-function 'sequence:emptyp))
+#+alexandria::sequence-emptyp
+(define-compiler-macro emptyp (sequence)
+  `(sequence:emptyp ,sequence))
+
+(defun length= (&rest sequences)
+  "Takes any number of sequences or integers in any order. Returns true iff
+the length of all the sequences and the integers are equal. Hint: there's a
+compiler macro that expands into more efficient code if the first argument
+is a literal integer."
+  (declare (dynamic-extent sequences)
+           (inline sequence-of-length-p)
+           (optimize speed))
+  (unless (cdr sequences)
+    (error "You must call LENGTH= with at least two arguments"))
+  ;; There's room for optimization here: multiple list arguments could be
+  ;; traversed in parallel.
+  (let* ((first (pop sequences))
+         (current (if (integerp first)
+                      first
+                      (length first))))
+    (declare (type array-index current))
+    (dolist (el sequences)
+      (if (integerp el)
+          (unless (= el current)
+            (return-from length= nil))
+          (unless (sequence-of-length-p el current)
+            (return-from length= nil)))))
+  t)
+
+(define-compiler-macro length= (&whole form length &rest sequences)
+  (cond
+    ((zerop (length sequences))
+     form)
+    (t
+     (let ((optimizedp (integerp length)))
+       (with-unique-names (tmp current)
+         (declare (ignorable current))
+         `(locally
+              (declare (inline sequence-of-length-p))
+            (let ((,tmp)
+                  ,@(unless optimizedp
+                     `((,current ,length))))
+              ,@(unless optimizedp
+                  `((unless (integerp ,current)
+                      (setf ,current (length ,current)))))
+              (and
+               ,@(loop
+                    :for sequence :in sequences
+                    :collect `(progn
+                                (setf ,tmp ,sequence)
+                                (if (integerp ,tmp)
+                                    (= ,tmp ,(if optimizedp
+                                                 length
+                                                 current))
+                                    (sequence-of-length-p ,tmp ,(if optimizedp
+                                                                    length
+                                                                    current)))))))))))))
+
+(defun copy-sequence (type sequence)
+  "Returns a fresh sequence of TYPE, which has the same elements as
+SEQUENCE."
+  (if (typep sequence type)
+      (copy-seq sequence)
+      (coerce sequence type)))
+
+(defun first-elt (sequence)
+  "Returns the first element of SEQUENCE. Signals a type-error if SEQUENCE is
+not a sequence, or is an empty sequence."
+  ;; Can't just directly use ELT, as it is not guaranteed to signal the
+  ;; type-error.
+  (cond  ((consp sequence)
+          (car sequence))
+         ((and (typep sequence 'sequence) (not (emptyp sequence)))
+          (elt sequence 0))
+         (t
+          (error 'type-error
+                 :datum sequence
+                 :expected-type '(and sequence (not (satisfies emptyp)))))))
+
+(defun (setf first-elt) (object sequence)
+  "Sets the first element of SEQUENCE. Signals a type-error if SEQUENCE is
+not a sequence, is an empty sequence, or if OBJECT cannot be stored in SEQUENCE."
+  ;; Can't just directly use ELT, as it is not guaranteed to signal the
+  ;; type-error.
+  (cond ((consp sequence)
+         (setf (car sequence) object))
+        ((and (typep sequence 'sequence) (not (emptyp sequence)))
+         (setf (elt sequence 0) object))
+        (t
+         (error 'type-error
+                :datum sequence
+                :expected-type '(and sequence (not (satisfies emptyp)))))))
+
+(defun last-elt (sequence)
+  "Returns the last element of SEQUENCE. Signals a type-error if SEQUENCE is
+not a proper sequence, or is an empty sequence."
+  ;; Can't just directly use ELT, as it is not guaranteed to signal the
+  ;; type-error.
+  (let ((len 0))
+    (cond ((consp sequence)
+           (lastcar sequence))
+          ((and (typep sequence '(and sequence (not list))) (plusp (setf len (length sequence))))
+           (elt sequence (1- len)))
+          (t
+           (error 'type-error
+                  :datum sequence
+                  :expected-type '(and proper-sequence (not (satisfies emptyp))))))))
+
+(defun (setf last-elt) (object sequence)
+  "Sets the last element of SEQUENCE. Signals a type-error if SEQUENCE is not a proper
+sequence, is an empty sequence, or if OBJECT cannot be stored in SEQUENCE."
+  (let ((len 0))
+    (cond ((consp sequence)
+           (setf (lastcar sequence) object))
+          ((and (typep sequence '(and sequence (not list))) (plusp (setf len (length sequence))))
+           (setf (elt sequence (1- len)) object))
+          (t
+           (error 'type-error
+                  :datum sequence
+                  :expected-type '(and proper-sequence (not (satisfies emptyp))))))))
+
+(defun starts-with-subseq (prefix sequence &rest args
+                           &key
+                           (return-suffix nil return-suffix-supplied-p)
+                           &allow-other-keys)
+  "Test whether the first elements of SEQUENCE are the same (as per TEST) as the elements of PREFIX.
+
+If RETURN-SUFFIX is T the function returns, as a second value, a
+sub-sequence or displaced array pointing to the sequence after PREFIX."
+  (declare (dynamic-extent args))
+  (let ((sequence-length (length sequence))
+        (prefix-length (length prefix)))
+    (when (< sequence-length prefix-length)
+      (return-from starts-with-subseq (values nil nil)))
+    (flet ((make-suffix (start)
+             (when return-suffix
+               (cond
+                 ((not (arrayp sequence))
+                  (if start
+                      (subseq sequence start)
+                      (subseq sequence 0 0)))
+                 ((not start)
+                  (make-array 0
+                              :element-type (array-element-type sequence)
+                              :adjustable nil))
+                 (t
+                  (make-array (- sequence-length start)
+                              :element-type (array-element-type sequence)
+                              :displaced-to sequence
+                              :displaced-index-offset start
+                              :adjustable nil))))))
+      (let ((mismatch (apply #'mismatch prefix sequence
+                             (if return-suffix-supplied-p
+                                 (remove-from-plist args :return-suffix)
+                                 args))))
+        (cond
+          ((not mismatch)
+           (values t (make-suffix nil)))
+          ((= mismatch prefix-length)
+           (values t (make-suffix mismatch)))
+          (t
+           (values nil nil)))))))
+
+(defun ends-with-subseq (suffix sequence &key (test #'eql))
+  "Test whether SEQUENCE ends with SUFFIX. In other words: return true if
+the last (length SUFFIX) elements of SEQUENCE are equal to SUFFIX."
+  (let ((sequence-length (length sequence))
+        (suffix-length (length suffix)))
+    (when (< sequence-length suffix-length)
+      ;; if SEQUENCE is shorter than SUFFIX, then SEQUENCE can't end with SUFFIX.
+      (return-from ends-with-subseq nil))
+    (loop for sequence-index from (- sequence-length suffix-length) below sequence-length
+          for suffix-index from 0 below suffix-length
+          when (not (funcall test (elt sequence sequence-index) (elt suffix suffix-index)))
+          do (return-from ends-with-subseq nil)
+          finally (return t))))
+
+(defun starts-with (object sequence &key (test #'eql) (key #'identity))
+  "Returns true if SEQUENCE is a sequence whose first element is EQL to OBJECT.
+Returns NIL if the SEQUENCE is not a sequence or is an empty sequence."
+  (let ((first-elt (typecase sequence
+                     (cons (car sequence))
+                     (sequence
+                      (if (emptyp sequence)
+                          (return-from starts-with nil)
+                          (elt sequence 0)))
+                     (t
+                      (return-from starts-with nil)))))
+    (funcall test (funcall key first-elt) object)))
+
+(defun ends-with (object sequence &key (test #'eql) (key #'identity))
+  "Returns true if SEQUENCE is a sequence whose last element is EQL to OBJECT.
+Returns NIL if the SEQUENCE is not a sequence or is an empty sequence. Signals
+an error if SEQUENCE is an improper list."
+  (let ((last-elt (typecase sequence
+                    (cons
+                     (lastcar sequence)) ; signals for improper lists
+                    (sequence
+                     ;; Can't use last-elt, as that signals an error
+                     ;; for empty sequences
+                     (let ((len (length sequence)))
+                       (if (plusp len)
+                           (elt sequence (1- len))
+                           (return-from ends-with nil))))
+                    (t
+                     (return-from ends-with nil)))))
+    (funcall test (funcall key last-elt) object)))
+
+(defun map-combinations (function sequence &key (start 0) end length (copy t))
+  "Calls FUNCTION with each combination of LENGTH constructable from the
+elements of the subsequence of SEQUENCE delimited by START and END. START
+defaults to 0, END to length of SEQUENCE, and LENGTH to the length of the
+delimited subsequence. (So unless LENGTH is specified there is only a single
+combination, which has the same elements as the delimited subsequence.) If
+COPY is true (the default) each combination is freshly allocated. If COPY is
+false all combinations are EQ to each other, in which case consequences are
+unspecified if a combination is modified by FUNCTION."
+  (let* ((end (or end (length sequence)))
+         (size (- end start))
+         (length (or length size))
+         (combination (subseq sequence 0 length))
+         (function (ensure-function function)))
+    (if (= length size)
+        (funcall function combination)
+        (flet ((call ()
+                 (funcall function (if copy
+                                       (copy-seq combination)
+                                       combination))))
+          (etypecase sequence
+            ;; When dealing with lists we prefer walking back and
+            ;; forth instead of using indexes.
+            (list
+             (labels ((combine-list (c-tail o-tail)
+                        (if (not c-tail)
+                            (call)
+                            (do ((tail o-tail (cdr tail)))
+                                ((not tail))
+                              (setf (car c-tail) (car tail))
+                              (combine-list (cdr c-tail) (cdr tail))))))
+               (combine-list combination (nthcdr start sequence))))
+            (vector
+             (labels ((combine (count start)
+                        (if (zerop count)
+                            (call)
+                            (loop for i from start below end
+                                  do (let ((j (- count 1)))
+                                       (setf (aref combination j) (aref sequence i))
+                                       (combine j (+ i 1)))))))
+               (combine length start)))
+            (sequence
+             (labels ((combine (count start)
+                        (if (zerop count)
+                            (call)
+                            (loop for i from start below end
+                                  do (let ((j (- count 1)))
+                                       (setf (elt combination j) (elt sequence i))
+                                       (combine j (+ i 1)))))))
+               (combine length start)))))))
+  sequence)
+
+(defun map-permutations (function sequence &key (start 0) end length (copy t))
+  "Calls function with each permutation of LENGTH constructable
+from the subsequence of SEQUENCE delimited by START and END. START
+defaults to 0, END to length of the sequence, and LENGTH to the
+length of the delimited subsequence."
+  (let* ((end (or end (length sequence)))
+         (size (- end start))
+         (length (or length size)))
+    (labels ((permute (seq n)
+               (let ((n-1 (- n 1)))
+                 (if (zerop n-1)
+                     (funcall function (if copy
+                                           (copy-seq seq)
+                                           seq))
+                     (loop for i from 0 upto n-1
+                           do (permute seq n-1)
+                           (if (evenp n-1)
+                               (rotatef (elt seq 0) (elt seq n-1))
+                               (rotatef (elt seq i) (elt seq n-1)))))))
+             (permute-sequence (seq)
+               (permute seq length)))
+      (if (= length size)
+          ;; Things are simple if we need to just permute the
+          ;; full START-END range.
+          (permute-sequence (subseq sequence start end))
+          ;; Otherwise we need to generate all the combinations
+          ;; of LENGTH in the START-END range, and then permute
+          ;; a copy of the result: can't permute the combination
+          ;; directly, as they share structure with each other.
+          (let ((permutation (subseq sequence 0 length)))
+            (flet ((permute-combination (combination)
+                     (permute-sequence (replace permutation combination))))
+              (declare (dynamic-extent #'permute-combination))
+              (map-combinations #'permute-combination sequence
+                                :start start
+                                :end end
+                                :length length
+                                :copy nil)))))))
+
+(defun map-derangements (function sequence &key (start 0) end (copy t))
+  "Calls FUNCTION with each derangement of the subsequence of SEQUENCE denoted
+by the bounding index designators START and END. Derangement is a permutation
+of the sequence where no element remains in place. SEQUENCE is not modified,
+but individual derangements are EQ to each other. Consequences are unspecified
+if calling FUNCTION modifies either the derangement or SEQUENCE."
+  (let* ((end (or end (length sequence)))
+         (size (- end start))
+         ;; We don't really care about the elements here.
+         (derangement (subseq sequence 0 size))
+         ;; Bitvector that has 1 for elements that have been deranged.
+         (mask (make-array size :element-type 'bit :initial-element 0)))
+    (declare (dynamic-extent mask))
+    ;; ad hoc algorith
+    (labels ((derange (place n)
+               ;; Perform one recursive step in deranging the
+               ;; sequence: PLACE is index of the original sequence
+               ;; to derange to another index, and N is the number of
+               ;; indexes not yet deranged.
+               (if (zerop n)
+                   (funcall function (if copy
+                                         (copy-seq derangement)
+                                         derangement))
+                   ;; Itarate over the indexes I of the subsequence to
+                   ;; derange: if I != PLACE and I has not yet been
+                   ;; deranged by an earlier call put the element from
+                   ;; PLACE to I, mark I as deranged, and recurse,
+                   ;; finally removing the mark.
+                   (loop for i from 0 below size
+                         do
+                         (unless (or (= place (+ i start)) (not (zerop (bit mask i))))
+                           (setf (elt derangement i) (elt sequence place)
+                                 (bit mask i) 1)
+                           (derange (1+ place) (1- n))
+                           (setf (bit mask i) 0))))))
+      (derange start size)
+      sequence)))
+
+(declaim (notinline sequence-of-length-p))
+
+(defun extremum (sequence predicate &key key (start 0) end)
+  "Returns the element of SEQUENCE that would appear first if the subsequence
+bounded by START and END was sorted using PREDICATE and KEY.
+
+EXTREMUM determines the relationship between two elements of SEQUENCE by using
+the PREDICATE function. PREDICATE should return true if and only if the first
+argument is strictly less than the second one (in some appropriate sense). Two
+arguments X and Y are considered to be equal if (FUNCALL PREDICATE X Y)
+and (FUNCALL PREDICATE Y X) are both false.
+
+The arguments to the PREDICATE function are computed from elements of SEQUENCE
+using the KEY function, if supplied. If KEY is not supplied or is NIL, the
+sequence element itself is used.
+
+If SEQUENCE is empty, NIL is returned."
+  (let* ((pred-fun (ensure-function predicate))
+         (key-fun (unless (or (not key) (eq key 'identity) (eq key #'identity))
+                    (ensure-function key)))
+         (real-end (or end (length sequence))))
+    (cond ((> real-end start)
+           (if key-fun
+               (flet ((reduce-keys (a b)
+                        (if (funcall pred-fun
+                                     (funcall key-fun a)
+                                     (funcall key-fun b))
+                            a
+                            b)))
+                 (declare (dynamic-extent #'reduce-keys))
+                 (reduce #'reduce-keys sequence :start start :end real-end))
+               (flet ((reduce-elts (a b)
+                        (if (funcall pred-fun a b)
+                            a
+                            b)))
+                 (declare (dynamic-extent #'reduce-elts))
+                 (reduce #'reduce-elts sequence :start start :end real-end))))
+          ((= real-end start)
+           nil)
+          (t
+           (error "Invalid bounding indexes for sequence of length ~S: ~S ~S, ~S ~S"
+                  (length sequence)
+                  :start start
+                  :end end)))))
diff --git a/third_party/lisp/alexandria/strings.lisp b/third_party/lisp/alexandria/strings.lisp
new file mode 100644
index 000000000000..e9fd91c96155
--- /dev/null
+++ b/third_party/lisp/alexandria/strings.lisp
@@ -0,0 +1,6 @@
+(in-package :alexandria)
+
+(deftype string-designator ()
+  "A string designator type. A string designator is either a string, a symbol,
+or a character."
+  `(or symbol string character))
diff --git a/third_party/lisp/alexandria/symbols.lisp b/third_party/lisp/alexandria/symbols.lisp
new file mode 100644
index 000000000000..5733d3e1cc50
--- /dev/null
+++ b/third_party/lisp/alexandria/symbols.lisp
@@ -0,0 +1,65 @@
+(in-package :alexandria)
+
+(declaim (inline ensure-symbol))
+(defun ensure-symbol (name &optional (package *package*))
+  "Returns a symbol with name designated by NAME, accessible in package
+designated by PACKAGE. If symbol is not already accessible in PACKAGE, it is
+interned there. Returns a secondary value reflecting the status of the symbol
+in the package, which matches the secondary return value of INTERN.
+
+Example:
+
+  (ensure-symbol :cons :cl) => cl:cons, :external
+"
+  (intern (string name) package))
+
+(defun maybe-intern (name package)
+  (values
+   (if package
+       (intern name (if (eq t package) *package* package))
+       (make-symbol name))))
+
+(declaim (inline format-symbol))
+(defun format-symbol (package control &rest arguments)
+  "Constructs a string by applying ARGUMENTS to string designator CONTROL as
+if by FORMAT within WITH-STANDARD-IO-SYNTAX, and then creates a symbol named
+by that string.
+
+If PACKAGE is NIL, returns an uninterned symbol, if package is T, returns a
+symbol interned in the current package, and otherwise returns a symbol
+interned in the package designated by PACKAGE."
+  (maybe-intern (with-standard-io-syntax
+                  (apply #'format nil (string control) arguments))
+                package))
+
+(defun make-keyword (name)
+  "Interns the string designated by NAME in the KEYWORD package."
+  (intern (string name) :keyword))
+
+(defun make-gensym (name)
+  "If NAME is a non-negative integer, calls GENSYM using it. Otherwise NAME
+must be a string designator, in which case calls GENSYM using the designated
+string as the argument."
+  (gensym (if (typep name '(integer 0))
+              name
+              (string name))))
+
+(defun make-gensym-list (length &optional (x "G"))
+  "Returns a list of LENGTH gensyms, each generated as if with a call to MAKE-GENSYM,
+using the second (optional, defaulting to \"G\") argument."
+  (let ((g (if (typep x '(integer 0)) x (string x))))
+    (loop repeat length
+          collect (gensym g))))
+
+(defun symbolicate (&rest things)
+  "Concatenate together the names of some strings and symbols,
+producing a symbol in the current package."
+  (let* ((length (reduce #'+ things
+                         :key (lambda (x) (length (string x)))))
+         (name (make-array length :element-type 'character)))
+    (let ((index 0))
+      (dolist (thing things (values (intern name)))
+        (let* ((x (string thing))
+               (len (length x)))
+          (replace name x :start1 index)
+          (incf index len))))))
diff --git a/third_party/lisp/alexandria/tests.lisp b/third_party/lisp/alexandria/tests.lisp
new file mode 100644
index 000000000000..b70ef0475e81
--- /dev/null
+++ b/third_party/lisp/alexandria/tests.lisp
@@ -0,0 +1,2047 @@
+(in-package :cl-user)
+
+(defpackage :alexandria-tests
+  (:use :cl :alexandria #+sbcl :sb-rt #-sbcl :rtest)
+  (:import-from #+sbcl :sb-rt #-sbcl :rtest
+                #:*compile-tests* #:*expected-failures*))
+
+(in-package :alexandria-tests)
+
+(defun run-tests (&key ((:compiled *compile-tests*)))
+  (do-tests))
+
+(defun hash-table-test-name (name)
+  ;; Workaround for Clisp calling EQL in a hash-table FASTHASH-EQL.
+  (hash-table-test (make-hash-table :test name)))
+
+;;;; Arrays
+
+(deftest copy-array.1
+    (let* ((orig (vector 1 2 3))
+           (copy (copy-array orig)))
+      (values (eq orig copy) (equalp orig copy)))
+  nil t)
+
+(deftest copy-array.2
+    (let ((orig (make-array 1024 :fill-pointer 0)))
+      (vector-push-extend 1 orig)
+      (vector-push-extend 2 orig)
+      (vector-push-extend 3 orig)
+      (let ((copy (copy-array orig)))
+        (values (eq orig copy) (equalp orig copy)
+                (array-has-fill-pointer-p copy)
+                (eql (fill-pointer orig) (fill-pointer copy)))))
+  nil t t t)
+
+(deftest copy-array.3
+    (let* ((orig (vector 1 2 3))
+           (copy (copy-array orig)))
+      (typep copy 'simple-array))
+  t)
+
+(deftest copy-array.4
+   (let ((orig (make-array 21
+                           :adjustable t
+                           :fill-pointer 0)))
+     (dotimes (n 42)
+       (vector-push-extend n orig))
+     (let ((copy (copy-array orig
+                             :adjustable nil
+                             :fill-pointer nil)))
+       (typep copy 'simple-array)))
+ t)
+
+(deftest array-index.1
+    (typep 0 'array-index)
+  t)
+
+;;;; Conditions
+
+(deftest unwind-protect-case.1
+    (let (result)
+      (unwind-protect-case ()
+          (random 10)
+        (:normal (push :normal result))
+        (:abort  (push :abort result))
+        (:always (push :always result)))
+      result)
+  (:always :normal))
+
+(deftest unwind-protect-case.2
+    (let (result)
+      (unwind-protect-case ()
+          (random 10)
+        (:always (push :always result))
+        (:normal (push :normal result))
+        (:abort  (push :abort result)))
+      result)
+  (:normal :always))
+
+(deftest unwind-protect-case.3
+    (let (result1 result2 result3)
+      (ignore-errors
+        (unwind-protect-case ()
+            (error "FOOF!")
+          (:normal (push :normal result1))
+          (:abort  (push :abort result1))
+          (:always (push :always result1))))
+      (catch 'foof
+        (unwind-protect-case ()
+            (throw 'foof 42)
+          (:normal (push :normal result2))
+          (:abort  (push :abort result2))
+          (:always (push :always result2))))
+      (block foof
+        (unwind-protect-case ()
+            (return-from foof 42)
+          (:normal (push :normal result3))
+          (:abort  (push :abort result3))
+          (:always (push :always result3))))
+      (values result1 result2 result3))
+  (:always :abort)
+  (:always :abort)
+  (:always :abort))
+
+(deftest unwind-protect-case.4
+    (let (result)
+      (unwind-protect-case (aborted-p)
+          (random 42)
+        (:always (setq result aborted-p)))
+      result)
+  nil)
+
+(deftest unwind-protect-case.5
+    (let (result)
+      (block foof
+        (unwind-protect-case (aborted-p)
+            (return-from foof)
+          (:always (setq result aborted-p))))
+      result)
+  t)
+
+;;;; Control flow
+
+(deftest switch.1
+    (switch (13 :test =)
+      (12 :oops)
+      (13.0 :yay))
+  :yay)
+
+(deftest switch.2
+    (switch (13)
+      ((+ 12 2) :oops)
+      ((- 13 1) :oops2)
+      (t :yay))
+  :yay)
+
+(deftest eswitch.1
+    (let ((x 13))
+      (eswitch (x :test =)
+        (12 :oops)
+        (13.0 :yay)))
+  :yay)
+
+(deftest eswitch.2
+    (let ((x 13))
+      (eswitch (x :key 1+)
+        (11 :oops)
+        (14 :yay)))
+  :yay)
+
+(deftest cswitch.1
+    (cswitch (13 :test =)
+      (12 :oops)
+      (13.0 :yay))
+  :yay)
+
+(deftest cswitch.2
+    (cswitch (13 :key 1-)
+      (12 :yay)
+      (13.0 :oops))
+  :yay)
+
+(deftest multiple-value-prog2.1
+    (multiple-value-prog2
+        (values 1 1 1)
+        (values 2 20 200)
+      (values 3 3 3))
+  2 20 200)
+
+(deftest nth-value-or.1
+    (multiple-value-bind (a b c)
+        (nth-value-or 1
+                      (values 1 nil 1)
+                      (values 2 2 2))
+      (= a b c 2))
+  t)
+
+(deftest whichever.1
+    (let ((x (whichever 1 2 3)))
+      (and (member x '(1 2 3)) t))
+  t)
+
+(deftest whichever.2
+    (let* ((a 1)
+           (b 2)
+           (c 3)
+           (x (whichever a b c)))
+      (and (member x '(1 2 3)) t))
+  t)
+
+(deftest xor.1
+    (xor nil nil 1 nil)
+  1
+  t)
+
+(deftest xor.2
+    (xor nil nil 1 2)
+  nil
+  nil)
+
+(deftest xor.3
+    (xor nil nil nil)
+  nil
+  t)
+
+;;;; Definitions
+
+(deftest define-constant.1
+    (let ((name (gensym)))
+      (eval `(define-constant ,name "FOO" :test 'equal))
+      (eval `(define-constant ,name "FOO" :test 'equal))
+      (values (equal "FOO" (symbol-value name))
+              (constantp name)))
+  t
+  t)
+
+(deftest define-constant.2
+    (let ((name (gensym)))
+      (eval `(define-constant ,name 13))
+      (eval `(define-constant ,name 13))
+      (values (eql 13 (symbol-value name))
+              (constantp name)))
+  t
+  t)
+
+;;;; Errors
+
+;;; TYPEP is specified to return a generalized boolean and, for
+;;; example, ECL exploits this by returning the superclasses of ERROR
+;;; in this case.
+(defun errorp (x)
+  (not (null (typep x 'error))))
+
+(deftest required-argument.1
+    (multiple-value-bind (res err)
+        (ignore-errors (required-argument))
+      (errorp err))
+  t)
+
+;;;; Hash tables
+
+(deftest ensure-gethash.1
+    (let ((table (make-hash-table))
+          (x (list 1)))
+      (multiple-value-bind (value already-there)
+          (ensure-gethash x table 42)
+        (and (= value 42)
+             (not already-there)
+             (= 42 (gethash x table))
+             (multiple-value-bind (value2 already-there2)
+                 (ensure-gethash x table 13)
+               (and (= value2 42)
+                    already-there2
+                    (= 42 (gethash x table)))))))
+  t)
+
+(deftest ensure-gethash.2
+    (let ((table (make-hash-table))
+          (count 0))
+      (multiple-value-call #'values
+        (ensure-gethash (progn (incf count) :foo)
+                        (progn (incf count) table)
+                        (progn (incf count) :bar))
+        (gethash :foo table)
+        count))
+  :bar nil :bar t 3)
+
+(deftest copy-hash-table.1
+    (let ((orig (make-hash-table :test 'eq :size 123))
+          (foo "foo"))
+      (setf (gethash orig orig) t
+            (gethash foo orig) t)
+      (let ((eq-copy (copy-hash-table orig))
+            (eql-copy (copy-hash-table orig :test 'eql))
+            (equal-copy (copy-hash-table orig :test 'equal))
+            (equalp-copy (copy-hash-table orig :test 'equalp)))
+        (list (eql (hash-table-size eq-copy) (hash-table-size orig))
+              (eql (hash-table-rehash-size eq-copy)
+                   (hash-table-rehash-size orig))
+              (hash-table-count eql-copy)
+              (gethash orig eq-copy)
+              (gethash (copy-seq foo) eql-copy)
+              (gethash foo eql-copy)
+              (gethash (copy-seq foo) equal-copy)
+              (gethash "FOO" equal-copy)
+              (gethash "FOO" equalp-copy))))
+  (t t 2 t nil t t nil t))
+
+(deftest copy-hash-table.2
+    (let ((ht (make-hash-table))
+          (list (list :list (vector :A :B :C))))
+      (setf (gethash 'list ht) list)
+      (let* ((shallow-copy (copy-hash-table ht))
+             (deep1-copy (copy-hash-table ht :key 'copy-list))
+             (list         (gethash 'list ht))
+             (shallow-list (gethash 'list shallow-copy))
+             (deep1-list   (gethash 'list deep1-copy)))
+        (list (eq ht shallow-copy)
+              (eq ht deep1-copy)
+              (eq list shallow-list)
+              (eq list deep1-list)                   ; outer list was copied.
+              (eq (second list) (second shallow-list))
+              (eq (second list) (second deep1-list)) ; inner vector wasn't copied.
+              )))
+  (nil nil t nil t t))
+
+(deftest maphash-keys.1
+    (let ((keys nil)
+          (table (make-hash-table)))
+      (declare (notinline maphash-keys))
+      (dotimes (i 10)
+        (setf (gethash i table) t))
+      (maphash-keys (lambda (k) (push k keys)) table)
+      (set-equal keys '(0 1 2 3 4 5 6 7 8 9)))
+  t)
+
+(deftest maphash-values.1
+    (let ((vals nil)
+          (table (make-hash-table)))
+      (declare (notinline maphash-values))
+      (dotimes (i 10)
+        (setf (gethash i table) (- i)))
+      (maphash-values (lambda (v) (push v vals)) table)
+      (set-equal vals '(0 -1 -2 -3 -4 -5 -6 -7 -8 -9)))
+  t)
+
+(deftest hash-table-keys.1
+    (let ((table (make-hash-table)))
+      (dotimes (i 10)
+        (setf (gethash i table) t))
+      (set-equal (hash-table-keys table) '(0 1 2 3 4 5 6 7 8 9)))
+  t)
+
+(deftest hash-table-values.1
+    (let ((table (make-hash-table)))
+      (dotimes (i 10)
+        (setf (gethash (gensym) table) i))
+      (set-equal (hash-table-values table) '(0 1 2 3 4 5 6 7 8 9)))
+  t)
+
+(deftest hash-table-alist.1
+    (let ((table (make-hash-table)))
+      (dotimes (i 10)
+        (setf (gethash i table) (- i)))
+      (let ((alist (hash-table-alist table)))
+        (list (length alist)
+              (assoc 0 alist)
+              (assoc 3 alist)
+              (assoc 9 alist)
+              (assoc nil alist))))
+  (10 (0 . 0) (3 . -3) (9 . -9) nil))
+
+(deftest hash-table-plist.1
+    (let ((table (make-hash-table)))
+      (dotimes (i 10)
+        (setf (gethash i table) (- i)))
+      (let ((plist (hash-table-plist table)))
+        (list (length plist)
+              (getf plist 0)
+              (getf plist 2)
+              (getf plist 7)
+              (getf plist nil))))
+  (20 0 -2 -7 nil))
+
+(deftest alist-hash-table.1
+    (let* ((alist '((0 a) (1 b) (2 c)))
+           (table (alist-hash-table alist)))
+      (list (hash-table-count table)
+            (gethash 0 table)
+            (gethash 1 table)
+            (gethash 2 table)
+            (eq (hash-table-test-name 'eql)
+                (hash-table-test table))))
+  (3 (a) (b) (c) t))
+
+(deftest alist-hash-table.duplicate-keys
+    (let* ((alist '((0 a) (1 b) (0 c) (1 d) (2 e)))
+           (table (alist-hash-table alist)))
+      (list (hash-table-count table)
+            (gethash 0 table)
+            (gethash 1 table)
+            (gethash 2 table)))
+  (3 (a) (b) (e)))
+
+(deftest plist-hash-table.1
+    (let* ((plist '(:a 1 :b 2 :c 3))
+           (table (plist-hash-table plist :test 'eq)))
+      (list (hash-table-count table)
+            (gethash :a table)
+            (gethash :b table)
+            (gethash :c table)
+            (gethash 2 table)
+            (gethash nil table)
+            (eq (hash-table-test-name 'eq)
+                (hash-table-test table))))
+  (3 1 2 3 nil nil t))
+
+(deftest plist-hash-table.duplicate-keys
+    (let* ((plist '(:a 1 :b 2 :a 3 :b 4 :c 5))
+           (table (plist-hash-table plist)))
+      (list (hash-table-count table)
+            (gethash :a table)
+            (gethash :b table)
+            (gethash :c table)))
+  (3 1 2 5))
+
+;;;; Functions
+
+(deftest disjoin.1
+    (let ((disjunction (disjoin (lambda (x)
+                                  (and (consp x) :cons))
+                                (lambda (x)
+                                  (and (stringp x) :string)))))
+      (list (funcall disjunction 'zot)
+            (funcall disjunction '(foo bar))
+            (funcall disjunction "test")))
+  (nil :cons :string))
+
+(deftest disjoin.2
+    (let ((disjunction (disjoin #'zerop)))
+      (list (funcall disjunction 0)
+            (funcall disjunction 1)))
+  (t nil))
+
+(deftest conjoin.1
+    (let ((conjunction (conjoin #'consp
+                                (lambda (x)
+                                  (stringp (car x)))
+                                (lambda (x)
+                                  (char (car x) 0)))))
+      (list (funcall conjunction 'zot)
+            (funcall conjunction '(foo))
+            (funcall conjunction '("foo"))))
+  (nil nil #\f))
+
+(deftest conjoin.2
+    (let ((conjunction (conjoin #'zerop)))
+      (list (funcall conjunction 0)
+            (funcall conjunction 1)))
+  (t nil))
+
+(deftest compose.1
+    (let ((composite (compose '1+
+                              (lambda (x)
+                                (* x 2))
+                              #'read-from-string)))
+      (funcall composite "1"))
+  3)
+
+(deftest compose.2
+    (let ((composite
+           (locally (declare (notinline compose))
+             (compose '1+
+                      (lambda (x)
+                        (* x 2))
+                      #'read-from-string))))
+      (funcall composite "2"))
+  5)
+
+(deftest compose.3
+    (let ((compose-form (funcall (compiler-macro-function 'compose)
+                                 '(compose '1+
+                                   (lambda (x)
+                                     (* x 2))
+                                   #'read-from-string)
+                                 nil)))
+      (let ((fun (funcall (compile nil `(lambda () ,compose-form)))))
+        (funcall fun "3")))
+  7)
+
+(deftest compose.4
+    (let ((composite (compose #'zerop)))
+      (list (funcall composite 0)
+            (funcall composite 1)))
+  (t nil))
+
+(deftest multiple-value-compose.1
+    (let ((composite (multiple-value-compose
+                      #'truncate
+                      (lambda (x y)
+                        (values y x))
+                      (lambda (x)
+                        (with-input-from-string (s x)
+                          (values (read s) (read s)))))))
+      (multiple-value-list (funcall composite "2 7")))
+  (3 1))
+
+(deftest multiple-value-compose.2
+    (let ((composite (locally (declare (notinline multiple-value-compose))
+                       (multiple-value-compose
+                        #'truncate
+                        (lambda (x y)
+                          (values y x))
+                       (lambda (x)
+                         (with-input-from-string (s x)
+                           (values (read s) (read s))))))))
+      (multiple-value-list (funcall composite "2 11")))
+  (5 1))
+
+(deftest multiple-value-compose.3
+    (let ((compose-form (funcall (compiler-macro-function 'multiple-value-compose)
+                                 '(multiple-value-compose
+                                   #'truncate
+                                   (lambda (x y)
+                                     (values y x))
+                                   (lambda (x)
+                                     (with-input-from-string (s x)
+                                       (values (read s) (read s)))))
+                                 nil)))
+      (let ((fun (funcall (compile nil `(lambda () ,compose-form)))))
+        (multiple-value-list (funcall fun "2 9"))))
+  (4 1))
+
+(deftest multiple-value-compose.4
+    (let ((composite (multiple-value-compose #'truncate)))
+      (multiple-value-list (funcall composite 9 2)))
+  (4 1))
+
+(deftest curry.1
+    (let ((curried (curry '+ 3)))
+      (funcall curried 1 5))
+  9)
+
+(deftest curry.2
+    (let ((curried (locally (declare (notinline curry))
+                     (curry '* 2 3))))
+      (funcall curried 7))
+  42)
+
+(deftest curry.3
+    (let ((curried-form (funcall (compiler-macro-function 'curry)
+                                 '(curry '/ 8)
+                                 nil)))
+      (let ((fun (funcall (compile nil `(lambda () ,curried-form)))))
+        (funcall fun 2)))
+  4)
+
+(deftest curry.4
+    (let* ((x 1)
+           (curried (curry (progn
+                             (incf x)
+                             (lambda (y z) (* x y z)))
+                           3)))
+      (list (funcall curried 7)
+            (funcall curried 7)
+            x))
+  (42 42 2))
+
+(deftest rcurry.1
+    (let ((r (rcurry '/ 2)))
+      (funcall r 8))
+  4)
+
+(deftest rcurry.2
+    (let* ((x 1)
+           (curried (rcurry (progn
+                              (incf x)
+                              (lambda (y z) (* x y z)))
+                            3)))
+      (list (funcall curried 7)
+            (funcall curried 7)
+            x))
+  (42 42 2))
+
+(deftest named-lambda.1
+    (let ((fac (named-lambda fac (x)
+                 (if (> x 1)
+                     (* x (fac (- x 1)))
+                     x))))
+      (funcall fac 5))
+  120)
+
+(deftest named-lambda.2
+    (let ((fac (named-lambda fac (&key x)
+                 (if (> x 1)
+                     (* x (fac :x (- x 1)))
+                     x))))
+      (funcall fac :x 5))
+  120)
+
+;;;; Lists
+
+(deftest alist-plist.1
+    (alist-plist '((a . 1) (b . 2) (c . 3)))
+  (a 1 b 2 c 3))
+
+(deftest plist-alist.1
+    (plist-alist '(a 1 b 2 c 3))
+  ((a . 1) (b . 2) (c . 3)))
+
+(deftest unionf.1
+    (let* ((list (list 1 2 3))
+           (orig list))
+      (unionf list (list 1 2 4))
+      (values (equal orig (list 1 2 3))
+              (eql (length list) 4)
+              (set-difference list (list 1 2 3 4))
+              (set-difference (list 1 2 3 4) list)))
+  t
+  t
+  nil
+  nil)
+
+(deftest nunionf.1
+    (let ((list (list 1 2 3)))
+      (nunionf list (list 1 2 4))
+      (values (eql (length list) 4)
+              (set-difference (list 1 2 3 4) list)
+              (set-difference list (list 1 2 3 4))))
+  t
+  nil
+  nil)
+
+(deftest appendf.1
+    (let* ((list (list 1 2 3))
+           (orig list))
+      (appendf list '(4 5 6) '(7 8))
+      (list list (eq list orig)))
+  ((1 2 3 4 5 6 7 8) nil))
+
+(deftest nconcf.1
+    (let ((list1 (list 1 2 3))
+          (list2 (list 4 5 6)))
+      (nconcf list1 list2 (list 7 8 9))
+      list1)
+  (1 2 3 4 5 6 7 8 9))
+
+(deftest circular-list.1
+    (let ((circle (circular-list 1 2 3)))
+      (list (first circle)
+            (second circle)
+            (third circle)
+            (fourth circle)
+            (eq circle (nthcdr 3 circle))))
+  (1 2 3 1 t))
+
+(deftest circular-list-p.1
+    (let* ((circle (circular-list 1 2 3 4))
+           (tree (list circle circle))
+           (dotted (cons circle t))
+           (proper (list 1 2 3 circle))
+           (tailcirc (list* 1 2 3 circle)))
+      (list (circular-list-p circle)
+            (circular-list-p tree)
+            (circular-list-p dotted)
+            (circular-list-p proper)
+            (circular-list-p tailcirc)))
+  (t nil nil nil t))
+
+(deftest circular-list-p.2
+    (circular-list-p 'foo)
+  nil)
+
+(deftest circular-tree-p.1
+    (let* ((circle (circular-list 1 2 3 4))
+           (tree1 (list circle circle))
+           (tree2 (let* ((level2 (list 1 nil 2))
+                         (level1 (list level2)))
+                    (setf (second level2) level1)
+                    level1))
+           (dotted (cons circle t))
+           (proper (list 1 2 3 circle))
+           (tailcirc (list* 1 2 3 circle))
+           (quite-proper (list 1 2 3))
+           (quite-dotted (list 1 (cons 2 3))))
+      (list (circular-tree-p circle)
+            (circular-tree-p tree1)
+            (circular-tree-p tree2)
+            (circular-tree-p dotted)
+            (circular-tree-p proper)
+            (circular-tree-p tailcirc)
+            (circular-tree-p quite-proper)
+            (circular-tree-p quite-dotted)))
+  (t t t t t t nil nil))
+
+(deftest circular-tree-p.2
+    (alexandria:circular-tree-p '#1=(#1#))
+  t)
+
+(deftest proper-list-p.1
+    (let ((l1 (list 1))
+          (l2 (list 1 2))
+          (l3 (cons 1 2))
+          (l4 (list (cons 1 2) 3))
+          (l5 (circular-list 1 2)))
+      (list (proper-list-p l1)
+            (proper-list-p l2)
+            (proper-list-p l3)
+            (proper-list-p l4)
+            (proper-list-p l5)))
+  (t t nil t nil))
+
+(deftest proper-list-p.2
+    (proper-list-p '(1 2 . 3))
+  nil)
+
+(deftest proper-list.type.1
+    (let ((l1 (list 1))
+          (l2 (list 1 2))
+          (l3 (cons 1 2))
+          (l4 (list (cons 1 2) 3))
+          (l5 (circular-list 1 2)))
+      (list (typep l1 'proper-list)
+            (typep l2 'proper-list)
+            (typep l3 'proper-list)
+            (typep l4 'proper-list)
+            (typep l5 'proper-list)))
+  (t t nil t nil))
+
+(deftest proper-list-length.1
+    (values
+     (proper-list-length nil)
+     (proper-list-length (list 1))
+     (proper-list-length (list 2 2))
+     (proper-list-length (list 3 3 3))
+     (proper-list-length (list 4 4 4 4))
+     (proper-list-length (list 5 5 5 5 5))
+     (proper-list-length (list 6 6 6 6 6 6))
+     (proper-list-length (list 7 7 7 7 7 7 7))
+     (proper-list-length (list 8 8 8 8 8 8 8 8))
+     (proper-list-length (list 9 9 9 9 9 9 9 9 9)))
+  0 1 2 3 4 5 6 7 8 9)
+
+(deftest proper-list-length.2
+    (flet ((plength (x)
+             (handler-case
+                 (proper-list-length x)
+               (type-error ()
+                 :ok))))
+      (values
+       (plength (list* 1))
+       (plength (list* 2 2))
+       (plength (list* 3 3 3))
+       (plength (list* 4 4 4 4))
+       (plength (list* 5 5 5 5 5))
+       (plength (list* 6 6 6 6 6 6))
+       (plength (list* 7 7 7 7 7 7 7))
+       (plength (list* 8 8 8 8 8 8 8 8))
+       (plength (list* 9 9 9 9 9 9 9 9 9))))
+  :ok :ok :ok
+  :ok :ok :ok
+  :ok :ok :ok)
+
+(deftest lastcar.1
+    (let ((l1 (list 1))
+          (l2 (list 1 2)))
+      (list (lastcar l1)
+            (lastcar l2)))
+  (1 2))
+
+(deftest lastcar.error.2
+    (handler-case
+        (progn
+          (lastcar (circular-list 1 2 3))
+          nil)
+      (error ()
+        t))
+  t)
+
+(deftest setf-lastcar.1
+    (let ((l (list 1 2 3 4)))
+      (values (lastcar l)
+              (progn
+                (setf (lastcar l) 42)
+                (lastcar l))))
+  4
+  42)
+
+(deftest setf-lastcar.2
+    (let ((l (circular-list 1 2 3)))
+      (multiple-value-bind (res err)
+          (ignore-errors (setf (lastcar l) 4))
+        (typep err 'type-error)))
+  t)
+
+(deftest make-circular-list.1
+    (let ((l (make-circular-list 3 :initial-element :x)))
+      (setf (car l) :y)
+      (list (eq l (nthcdr 3 l))
+            (first l)
+            (second l)
+            (third l)
+            (fourth l)))
+  (t :y :x :x :y))
+
+(deftest circular-list.type.1
+    (let* ((l1 (list 1 2 3))
+           (l2 (circular-list 1 2 3))
+           (l3 (list* 1 2 3 l2)))
+      (list (typep l1 'circular-list)
+            (typep l2 'circular-list)
+            (typep l3 'circular-list)))
+  (nil t t))
+
+(deftest ensure-list.1
+    (let ((x (list 1))
+          (y 2))
+      (list (ensure-list x)
+            (ensure-list y)))
+  ((1) (2)))
+
+(deftest ensure-cons.1
+    (let ((x (cons 1 2))
+          (y nil)
+          (z "foo"))
+      (values (ensure-cons x)
+              (ensure-cons y)
+              (ensure-cons z)))
+  (1 . 2)
+  (nil)
+  ("foo"))
+
+(deftest setp.1
+    (setp '(1))
+  t)
+
+(deftest setp.2
+    (setp nil)
+  t)
+
+(deftest setp.3
+    (setp "foo")
+  nil)
+
+(deftest setp.4
+    (setp '(1 2 3 1))
+  nil)
+
+(deftest setp.5
+    (setp '(1 2 3))
+  t)
+
+(deftest setp.6
+    (setp '(a :a))
+  t)
+
+(deftest setp.7
+    (setp '(a :a) :key 'character)
+  nil)
+
+(deftest setp.8
+    (setp '(a :a) :key 'character :test (constantly nil))
+  t)
+
+(deftest set-equal.1
+    (set-equal '(1 2 3) '(3 1 2))
+  t)
+
+(deftest set-equal.2
+    (set-equal '("Xa") '("Xb")
+               :test (lambda (a b) (eql (char a 0) (char b 0))))
+  t)
+
+(deftest set-equal.3
+    (set-equal '(1 2) '(4 2))
+  nil)
+
+(deftest set-equal.4
+    (set-equal '(a b c) '(:a :b :c) :key 'string :test 'equal)
+  t)
+
+(deftest set-equal.5
+    (set-equal '(a d c) '(:a :b :c) :key 'string :test 'equal)
+  nil)
+
+(deftest set-equal.6
+    (set-equal '(a b c) '(a b c d))
+  nil)
+
+(deftest map-product.1
+    (map-product 'cons '(2 3) '(1 4))
+  ((2 . 1) (2 . 4) (3 . 1) (3 . 4)))
+
+(deftest map-product.2
+    (map-product #'cons '(2 3) '(1 4))
+  ((2 . 1) (2 . 4) (3 . 1) (3 . 4)))
+
+(deftest flatten.1
+    (flatten '((1) 2 (((3 4))) ((((5)) 6)) 7))
+  (1 2 3 4 5 6 7))
+
+(deftest remove-from-plist.1
+    (let ((orig '(a 1 b 2 c 3 d 4)))
+      (list (remove-from-plist orig 'a 'c)
+            (remove-from-plist orig 'b 'd)
+            (remove-from-plist orig 'b)
+            (remove-from-plist orig 'a)
+            (remove-from-plist orig 'd 42 "zot")
+            (remove-from-plist orig 'a 'b 'c 'd)
+            (remove-from-plist orig 'a 'b 'c 'd 'x)
+            (equal orig '(a 1 b 2 c 3 d 4))))
+  ((b 2 d 4)
+   (a 1 c 3)
+   (a 1 c 3 d 4)
+   (b 2 c 3 d 4)
+   (a 1 b 2 c 3)
+   nil
+   nil
+   t))
+
+(deftest delete-from-plist.1
+    (let ((orig '(a 1 b 2 c 3 d 4 d 5)))
+      (list (delete-from-plist (copy-list orig) 'a 'c)
+            (delete-from-plist (copy-list orig) 'b 'd)
+            (delete-from-plist (copy-list orig) 'b)
+            (delete-from-plist (copy-list orig) 'a)
+            (delete-from-plist (copy-list orig) 'd 42 "zot")
+            (delete-from-plist (copy-list orig) 'a 'b 'c 'd)
+            (delete-from-plist (copy-list orig) 'a 'b 'c 'd 'x)
+            (equal orig (delete-from-plist orig))
+            (eq orig (delete-from-plist orig))))
+  ((b 2 d 4 d 5)
+   (a 1 c 3)
+   (a 1 c 3 d 4 d 5)
+   (b 2 c 3 d 4 d 5)
+   (a 1 b 2 c 3)
+   nil
+   nil
+   t
+   t))
+
+(deftest mappend.1
+    (mappend (compose 'list '*) '(1 2 3) '(1 2 3))
+  (1 4 9))
+
+(deftest assoc-value.1
+    (let ((key1 '(complex key))
+          (key2 'simple-key)
+          (alist '())
+          (result '()))
+      (push 1 (assoc-value alist key1 :test #'equal))
+      (push 2 (assoc-value alist key1 :test 'equal))
+      (push 42 (assoc-value alist key2))
+      (push 43 (assoc-value alist key2 :test 'eq))
+      (push (assoc-value alist key1 :test #'equal) result)
+      (push (assoc-value alist key2) result)
+
+      (push 'very (rassoc-value alist (list 2 1) :test #'equal))
+      (push (cdr (assoc '(very complex key) alist :test #'equal)) result)
+      result)
+  ((2 1) (43 42) (2 1)))
+
+;;;; Numbers
+
+(deftest clamp.1
+    (list (clamp 1.5 1 2)
+          (clamp 2.0 1 2)
+          (clamp 1.0 1 2)
+          (clamp 3 1 2)
+          (clamp 0 1 2))
+  (1.5 2.0 1.0 2 1))
+
+(deftest gaussian-random.1
+    (let ((min -0.2)
+          (max +0.2))
+      (multiple-value-bind (g1 g2)
+          (gaussian-random min max)
+        (values (<= min g1 max)
+                (<= min g2 max)
+                (/= g1 g2) ;uh
+                )))
+  t
+  t
+  t)
+
+#+sbcl
+(deftest gaussian-random.2
+    (handler-case
+        (sb-ext:with-timeout 2
+          (progn
+            (loop
+              :repeat 10000
+              :do (gaussian-random 0 nil))
+            'done))
+      (sb-ext:timeout ()
+        'timed-out))
+  done)
+
+(deftest iota.1
+    (iota 3)
+  (0 1 2))
+
+(deftest iota.2
+    (iota 3 :start 0.0d0)
+  (0.0d0 1.0d0 2.0d0))
+
+(deftest iota.3
+    (iota 3 :start 2 :step 3.0)
+  (2.0 5.0 8.0))
+
+(deftest map-iota.1
+    (let (all)
+      (declare (notinline map-iota))
+      (values (map-iota (lambda (x) (push x all))
+                        3
+                        :start 2
+                        :step 1.1d0)
+              all))
+  3
+  (4.2d0 3.1d0 2.0d0))
+
+(deftest lerp.1
+    (lerp 0.5 1 2)
+  1.5)
+
+(deftest lerp.2
+    (lerp 0.1 1 2)
+  1.1)
+
+(deftest lerp.3
+    (lerp 0.1 4 25)
+  6.1)
+
+(deftest mean.1
+    (mean '(1 2 3))
+  2)
+
+(deftest mean.2
+    (mean '(1 2 3 4))
+  5/2)
+
+(deftest mean.3
+    (mean '(1 2 10))
+  13/3)
+
+(deftest median.1
+    (median '(100 0 99 1 98 2 97))
+  97)
+
+(deftest median.2
+    (median '(100 0 99 1 98 2 97 96))
+  193/2)
+
+(deftest variance.1
+    (variance (list 1 2 3))
+  2/3)
+
+(deftest standard-deviation.1
+    (< 0 (standard-deviation (list 1 2 3)) 1)
+  t)
+
+(deftest maxf.1
+    (let ((x 1))
+      (maxf x 2)
+      x)
+  2)
+
+(deftest maxf.2
+    (let ((x 1))
+      (maxf x 0)
+      x)
+  1)
+
+(deftest maxf.3
+    (let ((x 1)
+          (c 0))
+      (maxf x (incf c))
+      (list x c))
+  (1 1))
+
+(deftest maxf.4
+    (let ((xv (vector 0 0 0))
+          (p 0))
+      (maxf (svref xv (incf p)) (incf p))
+      (list p xv))
+  (2 #(0 2 0)))
+
+(deftest minf.1
+    (let ((y 1))
+      (minf y 0)
+      y)
+  0)
+
+(deftest minf.2
+    (let ((xv (vector 10 10 10))
+          (p 0))
+      (minf (svref xv (incf p)) (incf p))
+      (list p xv))
+  (2 #(10 2 10)))
+
+(deftest subfactorial.1
+    (mapcar #'subfactorial (iota 22))
+  (1
+   0
+   1
+   2
+   9
+   44
+   265
+   1854
+   14833
+   133496
+   1334961
+   14684570
+   176214841
+   2290792932
+   32071101049
+   481066515734
+   7697064251745
+   130850092279664
+   2355301661033953
+   44750731559645106
+   895014631192902121
+   18795307255050944540))
+
+;;;; Arrays
+
+#+nil
+(deftest array-index.type)
+
+#+nil
+(deftest copy-array)
+
+;;;; Sequences
+
+(deftest rotate.1
+    (list (rotate (list 1 2 3) 0)
+          (rotate (list 1 2 3) 1)
+          (rotate (list 1 2 3) 2)
+          (rotate (list 1 2 3) 3)
+          (rotate (list 1 2 3) 4))
+  ((1 2 3)
+   (3 1 2)
+   (2 3 1)
+   (1 2 3)
+   (3 1 2)))
+
+(deftest rotate.2
+    (list (rotate (vector 1 2 3 4) 0)
+          (rotate (vector 1 2 3 4))
+          (rotate (vector 1 2 3 4) 2)
+          (rotate (vector 1 2 3 4) 3)
+          (rotate (vector 1 2 3 4) 4)
+          (rotate (vector 1 2 3 4) 5))
+  (#(1 2 3 4)
+    #(4 1 2 3)
+    #(3 4 1 2)
+    #(2 3 4 1)
+    #(1 2 3 4)
+    #(4 1 2 3)))
+
+(deftest rotate.3
+    (list (rotate (list 1 2 3) 0)
+          (rotate (list 1 2 3) -1)
+          (rotate (list 1 2 3) -2)
+          (rotate (list 1 2 3) -3)
+          (rotate (list 1 2 3) -4))
+  ((1 2 3)
+   (2 3 1)
+   (3 1 2)
+   (1 2 3)
+   (2 3 1)))
+
+(deftest rotate.4
+    (list (rotate (vector 1 2 3 4) 0)
+          (rotate (vector 1 2 3 4) -1)
+          (rotate (vector 1 2 3 4) -2)
+          (rotate (vector 1 2 3 4) -3)
+          (rotate (vector 1 2 3 4) -4)
+          (rotate (vector 1 2 3 4) -5))
+  (#(1 2 3 4)
+   #(2 3 4 1)
+   #(3 4 1 2)
+   #(4 1 2 3)
+   #(1 2 3 4)
+   #(2 3 4 1)))
+
+(deftest rotate.5
+    (values (rotate (list 1) 17)
+            (rotate (list 1) -5))
+  (1)
+  (1))
+
+(deftest shuffle.1
+    (let ((s (shuffle (iota 100))))
+      (list (equal s (iota 100))
+            (every (lambda (x)
+                     (member x s))
+                   (iota 100))
+            (every (lambda (x)
+                     (typep x '(integer 0 99)))
+                   s)))
+  (nil t t))
+
+(deftest shuffle.2
+    (let ((s (shuffle (coerce (iota 100) 'vector))))
+      (list (equal s (coerce (iota 100) 'vector))
+            (every (lambda (x)
+                     (find x s))
+                   (iota 100))
+            (every (lambda (x)
+                     (typep x '(integer 0 99)))
+                   s)))
+  (nil t t))
+
+(deftest shuffle.3
+    (let* ((orig (coerce (iota 21) 'vector))
+           (copy (copy-seq orig)))
+      (shuffle copy :start 10 :end 15)
+      (list (every #'eql (subseq copy 0 10) (subseq orig 0 10))
+            (every #'eql (subseq copy 15) (subseq orig 15))))
+  (t t))
+
+(deftest random-elt.1
+    (let ((s1 #(1 2 3 4))
+          (s2 '(1 2 3 4)))
+      (list (dotimes (i 1000 nil)
+              (unless (member (random-elt s1) s2)
+                (return nil))
+              (when (/= (random-elt s1) (random-elt s1))
+                (return t)))
+            (dotimes (i 1000 nil)
+              (unless (member (random-elt s2) s2)
+                (return nil))
+              (when (/= (random-elt s2) (random-elt s2))
+                (return t)))))
+  (t t))
+
+(deftest removef.1
+    (let* ((x '(1 2 3))
+           (x* x)
+           (y #(1 2 3))
+           (y* y))
+      (removef x 1)
+      (removef y 3)
+      (list x x* y y*))
+  ((2 3)
+   (1 2 3)
+   #(1 2)
+   #(1 2 3)))
+
+(deftest deletef.1
+    (let* ((x (list 1 2 3))
+           (x* x)
+           (y (vector 1 2 3)))
+      (deletef x 2)
+      (deletef y 1)
+      (list x x* y))
+  ((1 3)
+   (1 3)
+   #(2 3)))
+
+(deftest map-permutations.1
+    (let ((seq (list 1 2 3))
+          (seen nil)
+          (ok t))
+      (map-permutations (lambda (s)
+                          (unless (set-equal s seq)
+                            (setf ok nil))
+                          (when (member s seen :test 'equal)
+                            (setf ok nil))
+                          (push s seen))
+                        seq
+                        :copy t)
+      (values ok (length seen)))
+  t
+  6)
+
+(deftest proper-sequence.type.1
+    (mapcar (lambda (x)
+              (typep x 'proper-sequence))
+            (list (list 1 2 3)
+                  (vector 1 2 3)
+                  #2a((1 2) (3 4))
+                  (circular-list 1 2 3 4)))
+  (t t nil nil))
+
+(deftest emptyp.1
+    (mapcar #'emptyp
+            (list (list 1)
+                  (circular-list 1)
+                  nil
+                  (vector)
+                  (vector 1)))
+  (nil nil t t nil))
+
+(deftest sequence-of-length-p.1
+    (mapcar #'sequence-of-length-p
+            (list nil
+                  #()
+                  (list 1)
+                  (vector 1)
+                  (list 1 2)
+                  (vector 1 2)
+                  (list 1 2)
+                  (vector 1 2)
+                  (list 1 2)
+                  (vector 1 2))
+            (list 0
+                  0
+                  1
+                  1
+                  2
+                  2
+                  1
+                  1
+                  4
+                  4))
+  (t t t t t t nil nil nil nil))
+
+(deftest length=.1
+    (mapcar #'length=
+            (list nil
+                  #()
+                  (list 1)
+                  (vector 1)
+                  (list 1 2)
+                  (vector 1 2)
+                  (list 1 2)
+                  (vector 1 2)
+                  (list 1 2)
+                  (vector 1 2))
+            (list 0
+                  0
+                  1
+                  1
+                  2
+                  2
+                  1
+                  1
+                  4
+                  4))
+  (t t t t t t nil nil nil nil))
+
+(deftest length=.2
+    ;; test the compiler macro
+    (macrolet ((x (&rest args)
+                 (funcall
+                  (compile nil
+                           `(lambda ()
+                              (length= ,@args))))))
+      (list (x 2 '(1 2))
+            (x '(1 2) '(3 4))
+            (x '(1 2) 2)
+            (x '(1 2) 2 '(3 4))
+            (x 1 2 3)))
+  (t t t t nil))
+
+(deftest copy-sequence.1
+    (let ((l (list 1 2 3))
+          (v (vector #\a #\b #\c)))
+      (declare (notinline copy-sequence))
+      (let ((l.list (copy-sequence 'list l))
+            (l.vector (copy-sequence 'vector l))
+            (l.spec-v (copy-sequence '(vector fixnum) l))
+            (v.vector (copy-sequence 'vector v))
+            (v.list (copy-sequence 'list v))
+            (v.string (copy-sequence 'string v)))
+        (list (member l (list l.list l.vector l.spec-v))
+              (member v (list v.vector v.list v.string))
+              (equal l.list l)
+              (equalp l.vector #(1 2 3))
+              (type= (upgraded-array-element-type 'fixnum)
+                     (array-element-type l.spec-v))
+              (equalp v.vector v)
+              (equal v.list '(#\a #\b #\c))
+              (equal "abc" v.string))))
+  (nil nil t t t t t t))
+
+(deftest first-elt.1
+    (mapcar #'first-elt
+            (list (list 1 2 3)
+                  "abc"
+                  (vector :a :b :c)))
+  (1 #\a :a))
+
+(deftest first-elt.error.1
+    (mapcar (lambda (x)
+              (handler-case
+                  (first-elt x)
+                (type-error ()
+                  :type-error)))
+            (list nil
+                  #()
+                  12
+                  :zot))
+  (:type-error
+   :type-error
+   :type-error
+   :type-error))
+
+(deftest setf-first-elt.1
+    (let ((l (list 1 2 3))
+          (s (copy-seq "foobar"))
+          (v (vector :a :b :c)))
+      (setf (first-elt l) -1
+            (first-elt s) #\x
+            (first-elt v) 'zot)
+      (values l s v))
+  (-1 2 3)
+  "xoobar"
+  #(zot :b :c))
+
+(deftest setf-first-elt.error.1
+    (let ((l 'foo))
+      (multiple-value-bind (res err)
+          (ignore-errors (setf (first-elt l) 4))
+        (typep err 'type-error)))
+  t)
+
+(deftest last-elt.1
+    (mapcar #'last-elt
+            (list (list 1 2 3)
+                  (vector :a :b :c)
+                  "FOOBAR"
+                  #*001
+                  #*010))
+  (3 :c #\R 1 0))
+
+(deftest last-elt.error.1
+    (mapcar (lambda (x)
+              (handler-case
+                  (last-elt x)
+                (type-error ()
+                  :type-error)))
+            (list nil
+                  #()
+                  12
+                  :zot
+                  (circular-list 1 2 3)
+                  (list* 1 2 3 (circular-list 4 5))))
+  (:type-error
+   :type-error
+   :type-error
+   :type-error
+   :type-error
+   :type-error))
+
+(deftest setf-last-elt.1
+    (let ((l (list 1 2 3))
+          (s (copy-seq "foobar"))
+          (b (copy-seq #*010101001)))
+      (setf (last-elt l) '???
+            (last-elt s) #\?
+            (last-elt b) 0)
+      (values l s b))
+  (1 2 ???)
+  "fooba?"
+  #*010101000)
+
+(deftest setf-last-elt.error.1
+    (handler-case
+        (setf (last-elt 'foo) 13)
+      (type-error ()
+        :type-error))
+  :type-error)
+
+(deftest starts-with.1
+    (list (starts-with 1 '(1 2 3))
+          (starts-with 1 #(1 2 3))
+          (starts-with #\x "xyz")
+          (starts-with 2 '(1 2 3))
+          (starts-with 3 #(1 2 3))
+          (starts-with 1 1)
+          (starts-with nil nil))
+  (t t t nil nil nil nil))
+
+(deftest starts-with.2
+    (values (starts-with 1 '(-1 2 3) :key '-)
+            (starts-with "foo" '("foo" "bar") :test 'equal)
+            (starts-with "f" '(#\f) :key 'string :test 'equal)
+            (starts-with -1 '(0 1 2) :key #'1+)
+            (starts-with "zot" '("ZOT") :test 'equal))
+  t
+  t
+  t
+  nil
+  nil)
+
+(deftest ends-with.1
+    (list (ends-with 3 '(1 2 3))
+          (ends-with 3 #(1 2 3))
+          (ends-with #\z "xyz")
+          (ends-with 2 '(1 2 3))
+          (ends-with 1 #(1 2 3))
+          (ends-with 1 1)
+          (ends-with nil nil))
+  (t t t nil nil nil nil))
+
+(deftest ends-with.2
+    (values (ends-with 2 '(0 13 1) :key '1+)
+            (ends-with "foo" (vector "bar" "foo") :test 'equal)
+            (ends-with "X" (vector 1 2 #\X) :key 'string :test 'equal)
+            (ends-with "foo" "foo" :test 'equal))
+  t
+  t
+  t
+  nil)
+
+(deftest ends-with.error.1
+    (handler-case
+        (ends-with 3 (circular-list 3 3 3 1 3 3))
+      (type-error ()
+        :type-error))
+  :type-error)
+
+(deftest sequences.passing-improper-lists
+    (macrolet ((signals-error-p (form)
+                 `(handler-case
+                      (progn ,form nil)
+                    (type-error (e)
+                      t)))
+               (cut (fn &rest args)
+                 (with-gensyms (arg)
+                   (print`(lambda (,arg)
+                       (apply ,fn (list ,@(substitute arg '_ args))))))))
+      (let ((circular-list (make-circular-list 5 :initial-element :foo))
+            (dotted-list (list* 'a 'b 'c 'd)))
+        (loop for nth from 0
+              for fn in (list
+                         (cut #'lastcar _)
+                         (cut #'rotate _ 3)
+                         (cut #'rotate _ -3)
+                         (cut #'shuffle _)
+                         (cut #'random-elt _)
+                         (cut #'last-elt _)
+                         (cut #'ends-with :foo _))
+              nconcing
+                 (let ((on-circular-p (signals-error-p (funcall fn circular-list)))
+                       (on-dotted-p (signals-error-p (funcall fn dotted-list))))
+                   (when (or (not on-circular-p) (not on-dotted-p))
+                     (append
+                      (unless on-circular-p
+                        (let ((*print-circle* t))
+                          (list
+                           (format nil
+                                   "No appropriate error signalled when passing ~S to ~Ath entry."
+                                   circular-list nth))))
+                      (unless on-dotted-p
+                        (list
+                         (format nil
+                                 "No appropriate error signalled when passing ~S to ~Ath entry."
+                                 dotted-list nth)))))))))
+  nil)
+
+;;;; IO
+
+(deftest read-stream-content-into-string.1
+    (values (with-input-from-string (stream "foo bar")
+              (read-stream-content-into-string stream))
+            (with-input-from-string (stream "foo bar")
+              (read-stream-content-into-string stream :buffer-size 1))
+            (with-input-from-string (stream "foo bar")
+              (read-stream-content-into-string stream :buffer-size 6))
+            (with-input-from-string (stream "foo bar")
+              (read-stream-content-into-string stream :buffer-size 7)))
+  "foo bar"
+  "foo bar"
+  "foo bar"
+  "foo bar")
+
+(deftest read-stream-content-into-string.2
+    (handler-case
+        (let ((stream (make-broadcast-stream)))
+          (read-stream-content-into-string stream :buffer-size 0))
+      (type-error ()
+        :type-error))
+  :type-error)
+
+#+(or)
+(defvar *octets*
+  (map '(simple-array (unsigned-byte 8) (7)) #'char-code "foo bar"))
+
+#+(or)
+(deftest read-stream-content-into-byte-vector.1
+    (values (with-input-from-byte-vector (stream *octets*)
+              (read-stream-content-into-byte-vector stream))
+            (with-input-from-byte-vector (stream *octets*)
+              (read-stream-content-into-byte-vector stream :initial-size 1))
+            (with-input-from-byte-vector (stream *octets*)
+              (read-stream-content-into-byte-vector stream 'alexandria::%length 6))
+            (with-input-from-byte-vector (stream *octets*)
+              (read-stream-content-into-byte-vector stream 'alexandria::%length 3)))
+  *octets*
+  *octets*
+  *octets*
+  (subseq *octets* 0 3))
+
+(deftest read-stream-content-into-byte-vector.2
+    (handler-case
+        (let ((stream (make-broadcast-stream)))
+          (read-stream-content-into-byte-vector stream :initial-size 0))
+      (type-error ()
+        :type-error))
+  :type-error)
+
+;;;; Macros
+
+(deftest with-unique-names.1
+    (let ((*gensym-counter* 0))
+      (let ((syms (with-unique-names (foo bar quux)
+                    (list foo bar quux))))
+        (list (find-if #'symbol-package syms)
+              (equal '("FOO0" "BAR1" "QUUX2")
+                     (mapcar #'symbol-name syms)))))
+  (nil t))
+
+(deftest with-unique-names.2
+    (let ((*gensym-counter* 0))
+      (let ((syms (with-unique-names ((foo "_foo_") (bar -bar-) (quux #\q))
+                    (list foo bar quux))))
+        (list (find-if #'symbol-package syms)
+              (equal '("_foo_0" "-BAR-1" "q2")
+                     (mapcar #'symbol-name syms)))))
+  (nil t))
+
+(deftest with-unique-names.3
+    (let ((*gensym-counter* 0))
+      (multiple-value-bind (res err)
+          (ignore-errors
+            (eval
+             '(let ((syms
+                     (with-unique-names ((foo "_foo_") (bar -bar-) (quux 42))
+                       (list foo bar quux))))
+               (list (find-if #'symbol-package syms)
+                (equal '("_foo_0" "-BAR-1" "q2")
+                 (mapcar #'symbol-name syms))))))
+        (errorp err)))
+  t)
+
+(deftest once-only.1
+    (macrolet ((cons1.good (x)
+                 (once-only (x)
+                   `(cons ,x ,x)))
+               (cons1.bad (x)
+                 `(cons ,x ,x)))
+      (let ((y 0))
+        (list (cons1.good (incf y))
+              y
+              (cons1.bad (incf y))
+              y)))
+  ((1 . 1) 1 (2 . 3) 3))
+
+(deftest once-only.2
+    (macrolet ((cons1 (x)
+                 (once-only ((y x))
+                   `(cons ,y ,y))))
+      (let ((z 0))
+        (list (cons1 (incf z))
+              z
+              (cons1 (incf z)))))
+  ((1 . 1) 1 (2 . 2)))
+
+(deftest parse-body.1
+    (parse-body '("doc" "body") :documentation t)
+  ("body")
+  nil
+  "doc")
+
+(deftest parse-body.2
+    (parse-body '("body") :documentation t)
+  ("body")
+  nil
+  nil)
+
+(deftest parse-body.3
+    (parse-body '("doc" "body"))
+  ("doc" "body")
+  nil
+  nil)
+
+(deftest parse-body.4
+    (parse-body '((declare (foo)) "doc" (declare (bar)) body) :documentation t)
+  (body)
+  ((declare (foo)) (declare (bar)))
+  "doc")
+
+(deftest parse-body.5
+    (parse-body '((declare (foo)) "doc" (declare (bar)) body))
+  ("doc" (declare (bar)) body)
+  ((declare (foo)))
+  nil)
+
+(deftest parse-body.6
+    (multiple-value-bind (res err)
+        (ignore-errors
+          (parse-body '("foo" "bar" "quux")
+                      :documentation t))
+      (errorp err))
+  t)
+
+;;;; Symbols
+
+(deftest ensure-symbol.1
+    (ensure-symbol :cons :cl)
+  cons
+  :external)
+
+(deftest ensure-symbol.2
+    (ensure-symbol "CONS" :alexandria)
+  cons
+  :inherited)
+
+(deftest ensure-symbol.3
+    (ensure-symbol 'foo :keyword)
+  :foo
+  :external)
+
+(deftest ensure-symbol.4
+    (ensure-symbol #\* :alexandria)
+  *
+  :inherited)
+
+(deftest format-symbol.1
+    (let ((s (format-symbol nil '#:x-~d 13)))
+      (list (symbol-package s)
+            (string= (string '#:x-13) (symbol-name s))))
+  (nil t))
+
+(deftest format-symbol.2
+    (format-symbol :keyword '#:sym-~a (string :bolic))
+  :sym-bolic)
+
+(deftest format-symbol.3
+    (let ((*package* (find-package :cl)))
+      (format-symbol t '#:find-~a (string 'package)))
+  find-package)
+
+(deftest make-keyword.1
+    (list (make-keyword 'zot)
+          (make-keyword "FOO")
+          (make-keyword #\Q))
+  (:zot :foo :q))
+
+(deftest make-gensym-list.1
+    (let ((*gensym-counter* 0))
+      (let ((syms (make-gensym-list 3 "FOO")))
+        (list (find-if 'symbol-package syms)
+              (equal '("FOO0" "FOO1" "FOO2")
+                     (mapcar 'symbol-name syms)))))
+  (nil t))
+
+(deftest make-gensym-list.2
+    (let ((*gensym-counter* 0))
+      (let ((syms (make-gensym-list 3)))
+        (list (find-if 'symbol-package syms)
+              (equal '("G0" "G1" "G2")
+                     (mapcar 'symbol-name syms)))))
+  (nil t))
+
+;;;; Type-system
+
+(deftest of-type.1
+    (locally
+        (declare (notinline of-type))
+    (let ((f (of-type 'string)))
+      (list (funcall f "foo")
+            (funcall f 'bar))))
+  (t nil))
+
+(deftest type=.1
+    (type= 'string 'string)
+  t
+  t)
+
+(deftest type=.2
+    (type= 'list '(or null cons))
+  t
+  t)
+
+(deftest type=.3
+    (type= 'null '(and symbol list))
+  t
+  t)
+
+(deftest type=.4
+    (type= 'string '(satisfies emptyp))
+  nil
+  nil)
+
+(deftest type=.5
+    (type= 'string 'list)
+  nil
+  t)
+
+(macrolet
+    ((test (type numbers)
+       `(deftest ,(format-symbol t '#:cdr5.~a (string type))
+            (let ((numbers ,numbers))
+              (values (mapcar (of-type ',(format-symbol t '#:negative-~a (string type))) numbers)
+                      (mapcar (of-type ',(format-symbol t '#:non-positive-~a (string type))) numbers)
+                      (mapcar (of-type ',(format-symbol t '#:non-negative-~a (string type))) numbers)
+                      (mapcar (of-type ',(format-symbol t '#:positive-~a (string type))) numbers)))
+          (t t t nil nil nil nil)
+          (t t t t nil nil nil)
+          (nil nil nil t t t t)
+          (nil nil nil nil t t t))))
+  (test fixnum       (list most-negative-fixnum       -42      -1     0     1     42      most-positive-fixnum))
+  (test integer      (list (1- most-negative-fixnum)  -42      -1     0     1     42      (1+ most-positive-fixnum)))
+  (test rational     (list (1- most-negative-fixnum)  -42/13   -1     0     1     42/13   (1+ most-positive-fixnum)))
+  (test real         (list most-negative-long-float   -42/13   -1     0     1     42/13   most-positive-long-float))
+  (test float        (list most-negative-short-float  -42.02   -1.0   0.0   1.0   42.02   most-positive-short-float))
+  (test short-float  (list most-negative-short-float  -42.02s0 -1.0s0 0.0s0 1.0s0 42.02s0 most-positive-short-float))
+  (test single-float (list most-negative-single-float -42.02f0 -1.0f0 0.0f0 1.0f0 42.02f0 most-positive-single-float))
+  (test double-float (list most-negative-double-float -42.02d0 -1.0d0 0.0d0 1.0d0 42.02d0 most-positive-double-float))
+  (test long-float   (list most-negative-long-float   -42.02l0 -1.0l0 0.0l0 1.0l0 42.02l0 most-positive-long-float)))
+
+;;;; Bindings
+
+(declaim (notinline opaque))
+(defun opaque (x)
+  x)
+
+(deftest if-let.1
+    (if-let (x (opaque :ok))
+            x
+            :bad)
+  :ok)
+
+(deftest if-let.2
+    (if-let (x (opaque nil))
+            :bad
+            (and (not x) :ok))
+  :ok)
+
+(deftest if-let.3
+    (let ((x 1))
+      (if-let ((x 2)
+               (y x))
+              (+ x y)
+              :oops))
+  3)
+
+(deftest if-let.4
+    (if-let ((x 1)
+             (y nil))
+            :oops
+            (and (not y) x))
+  1)
+
+(deftest if-let.5
+    (if-let (x)
+            :oops
+            (not x))
+  t)
+
+(deftest if-let.error.1
+    (handler-case
+        (eval '(if-let x
+                :oops
+                :oops))
+      (type-error ()
+        :type-error))
+  :type-error)
+
+(deftest when-let.1
+    (when-let (x (opaque :ok))
+      (setf x (cons x x))
+      x)
+  (:ok . :ok))
+
+(deftest when-let.2
+    (when-let ((x 1)
+               (y nil)
+               (z 3))
+      :oops)
+  nil)
+
+(deftest when-let.3
+    (let ((x 1))
+      (when-let ((x 2)
+                 (y x))
+        (+ x y)))
+  3)
+
+(deftest when-let.error.1
+    (handler-case
+        (eval '(when-let x :oops))
+      (type-error ()
+        :type-error))
+  :type-error)
+
+(deftest when-let*.1
+    (let ((x 1))
+      (when-let* ((x 2)
+                  (y x))
+        (+ x y)))
+  4)
+
+(deftest when-let*.2
+    (let ((y 1))
+      (when-let* (x y)
+        (1+ x)))
+  2)
+
+(deftest when-let*.3
+    (when-let* ((x t)
+                (y (consp x))
+                (z (error "OOPS")))
+      t)
+  nil)
+
+(deftest when-let*.error.1
+    (handler-case
+        (eval '(when-let* x :oops))
+      (type-error ()
+        :type-error))
+  :type-error)
+
+(deftest doplist.1
+    (let (keys values)
+      (doplist (k v '(a 1 b 2 c 3) (values t (reverse keys) (reverse values) k v))
+        (push k keys)
+        (push v values)))
+  t
+  (a b c)
+  (1 2 3)
+  nil
+  nil)
+
+(deftest count-permutations.1
+    (values (count-permutations 31 7)
+            (count-permutations 1 1)
+            (count-permutations 2 1)
+            (count-permutations 2 2)
+            (count-permutations 3 2)
+            (count-permutations 3 1))
+  13253058000
+  1
+  2
+  2
+  6
+  3)
+
+(deftest binomial-coefficient.1
+    (alexandria:binomial-coefficient 1239 139)
+  28794902202288970200771694600561826718847179309929858835480006683522184441358211423695124921058123706380656375919763349913245306834194782172712255592710204598527867804110129489943080460154)
+
+;; Exercise bignum case (at least on x86).
+(deftest binomial-coefficient.2
+    (alexandria:binomial-coefficient 2000000000000 20)
+  430998041177272843950422879590338454856322722740402365741730748431530623813012487773080486408378680853987520854296499536311275320016878730999689934464711239072435565454954447356845336730100919970769793030177499999999900000000000)
+
+(deftest copy-stream.1
+    (let ((data "sdkfjhsakfh weior763495ewofhsdfk sdfadlkfjhsadf woif sdlkjfhslkdfh sdklfjh"))
+      (values (equal data
+                     (with-input-from-string (in data)
+                       (with-output-to-string (out)
+                         (alexandria:copy-stream in out))))
+              (equal (subseq data 10 20)
+                     (with-input-from-string (in data)
+                       (with-output-to-string (out)
+                         (alexandria:copy-stream in out :start 10 :end 20))))
+              (equal (subseq data 10)
+                     (with-input-from-string (in data)
+                       (with-output-to-string (out)
+                         (alexandria:copy-stream in out :start 10))))
+              (equal (subseq data 0 20)
+                     (with-input-from-string (in data)
+                       (with-output-to-string (out)
+                         (alexandria:copy-stream in out :end 20))))))
+  t
+  t
+  t
+  t)
+
+(deftest extremum.1
+    (let ((n 0))
+      (dotimes (i 10)
+       (let ((data (shuffle (coerce (iota 10000 :start i) 'vector)))
+             (ok t))
+         (unless (eql i (extremum data #'<))
+           (setf ok nil))
+         (unless (eql i (extremum (coerce data 'list) #'<))
+           (setf ok nil))
+         (unless (eql (+ 9999 i) (extremum data #'>))
+           (setf ok nil))
+         (unless (eql (+ 9999 i) (extremum (coerce  data 'list) #'>))
+           (setf ok nil))
+         (when ok
+           (incf n))))
+      (when (eql 10 (extremum #(100 1 10 1000) #'> :start 1 :end 3))
+        (incf n))
+      (when (eql -1000 (extremum #(100 1 10 -1000) #'> :key 'abs))
+        (incf n))
+      (when (eq nil (extremum "" (lambda (a b) (error "wtf? ~S, ~S" a b))))
+        (incf n))
+      n)
+  13)
+
+(deftest starts-with-subseq.string
+    (starts-with-subseq "f" "foo" :return-suffix t)
+  t
+  "oo")
+
+(deftest starts-with-subseq.vector
+    (starts-with-subseq #(1) #(1 2 3) :return-suffix t)
+  t
+  #(2 3))
+
+(deftest starts-with-subseq.list
+    (starts-with-subseq '(1) '(1 2 3) :return-suffix t)
+  t
+  (2 3))
+
+(deftest starts-with-subseq.start1
+    (starts-with-subseq "foo" "oop" :start1 1)
+  t
+  nil)
+
+(deftest starts-with-subseq.start2
+    (starts-with-subseq "foo" "xfoop" :start2 1)
+  t
+  nil)
+
+(deftest format-symbol.print-case-bound
+    (let ((upper (intern "FOO-BAR"))
+          (lower (intern "foo-bar"))
+          (*print-escape* nil))
+      (values
+       (let ((*print-case* :downcase))
+         (and (eq upper (format-symbol t "~A" upper))
+               (eq lower (format-symbol t "~A" lower))))
+       (let ((*print-case* :upcase))
+         (and (eq upper (format-symbol t "~A" upper))
+               (eq lower (format-symbol t "~A" lower))))
+       (let ((*print-case* :capitalize))
+         (and (eq upper (format-symbol t "~A" upper))
+              (eq lower (format-symbol t "~A" lower))))))
+  t
+  t
+  t)
+
+(deftest iota.fp-start-and-complex-integer-step
+    (equal '(#C(0.0 0.0) #C(0.0 2.0) #C(0.0 4.0))
+           (iota 3 :start 0.0 :step #C(0 2)))
+  t)
+
+(deftest parse-ordinary-lambda-list.1
+    (multiple-value-bind (req opt rest keys allowp aux keyp)
+        (parse-ordinary-lambda-list '(a b c
+                                      &optional o1 (o2 42) (o3 42 o3-supplied?)
+                                      &key (k1) ((:key k2)) (k3 42 k3-supplied?))
+                                    :normalize t)
+      (and (equal '(a b c) req)
+           (equal '((o1 nil nil)
+                    (o2 42 nil)
+                    (o3 42 o3-supplied?))
+                  opt)
+           (equal '(((:k1 k1) nil nil)
+                    ((:key k2) nil nil)
+                    ((:k3 k3) 42 k3-supplied?))
+                  keys)
+           (not allowp)
+           (not aux)
+           (eq t keyp)))
+  t)
diff --git a/third_party/lisp/alexandria/types.lisp b/third_party/lisp/alexandria/types.lisp
new file mode 100644
index 000000000000..1942d0ecdf2a
--- /dev/null
+++ b/third_party/lisp/alexandria/types.lisp
@@ -0,0 +1,137 @@
+(in-package :alexandria)
+
+(deftype array-index (&optional (length (1- array-dimension-limit)))
+  "Type designator for an index into array of LENGTH: an integer between
+0 (inclusive) and LENGTH (exclusive). LENGTH defaults to one less than
+ARRAY-DIMENSION-LIMIT."
+  `(integer 0 (,length)))
+
+(deftype array-length (&optional (length (1- array-dimension-limit)))
+  "Type designator for a dimension of an array of LENGTH: an integer between
+0 (inclusive) and LENGTH (inclusive). LENGTH defaults to one less than
+ARRAY-DIMENSION-LIMIT."
+  `(integer 0 ,length))
+
+;; This MACROLET will generate most of CDR5 (http://cdr.eurolisp.org/document/5/)
+;; except the RATIO related definitions and ARRAY-INDEX.
+(macrolet
+    ((frob (type &optional (base-type type))
+       (let ((subtype-names (list))
+             (predicate-names (list)))
+         (flet ((make-subtype-name (format-control)
+                  (let ((result (format-symbol :alexandria format-control
+                                               (symbol-name type))))
+                    (push result subtype-names)
+                    result))
+                (make-predicate-name (sybtype-name)
+                  (let ((result (format-symbol :alexandria '#:~A-p
+                                               (symbol-name sybtype-name))))
+                    (push result predicate-names)
+                    result))
+		(make-docstring (range-beg range-end range-type)
+		  (let ((inf (ecase range-type (:negative "-inf") (:positive "+inf"))))
+		    (format nil "Type specifier denoting the ~(~A~) range from ~A to ~A."
+			    type
+			    (if (equal range-beg ''*) inf (ensure-car range-beg))
+			    (if (equal range-end ''*) inf (ensure-car range-end))))))
+           (let* ((negative-name     (make-subtype-name '#:negative-~a))
+                  (non-positive-name (make-subtype-name '#:non-positive-~a))
+                  (non-negative-name (make-subtype-name '#:non-negative-~a))
+                  (positive-name     (make-subtype-name '#:positive-~a))
+                  (negative-p-name     (make-predicate-name negative-name))
+                  (non-positive-p-name (make-predicate-name non-positive-name))
+                  (non-negative-p-name (make-predicate-name non-negative-name))
+                  (positive-p-name     (make-predicate-name positive-name))
+                  (negative-extremum)
+                  (positive-extremum)
+                  (below-zero)
+                  (above-zero)
+                  (zero))
+             (setf (values negative-extremum below-zero
+                           above-zero positive-extremum zero)
+                   (ecase type
+                     (fixnum       (values 'most-negative-fixnum -1 1 'most-positive-fixnum 0))
+                     (integer      (values ''* -1       1        ''* 0))
+                     (rational     (values ''* '(0)     '(0)     ''* 0))
+                     (real         (values ''* '(0)     '(0)     ''* 0))
+                     (float        (values ''* '(0.0E0) '(0.0E0) ''* 0.0E0))
+                     (short-float  (values ''* '(0.0S0) '(0.0S0) ''* 0.0S0))
+                     (single-float (values ''* '(0.0F0) '(0.0F0) ''* 0.0F0))
+                     (double-float (values ''* '(0.0D0) '(0.0D0) ''* 0.0D0))
+                     (long-float   (values ''* '(0.0L0) '(0.0L0) ''* 0.0L0))))
+             `(progn
+                (deftype ,negative-name ()
+		  ,(make-docstring negative-extremum below-zero :negative)
+		  `(,',base-type ,,negative-extremum ,',below-zero))
+
+                (deftype ,non-positive-name ()
+		  ,(make-docstring negative-extremum zero :negative)
+		  `(,',base-type ,,negative-extremum ,',zero))
+
+                (deftype ,non-negative-name ()
+		  ,(make-docstring zero positive-extremum :positive)
+		  `(,',base-type ,',zero ,,positive-extremum))
+
+                (deftype ,positive-name ()
+		  ,(make-docstring above-zero positive-extremum :positive)
+		  `(,',base-type ,',above-zero ,,positive-extremum))
+
+                (declaim (inline ,@predicate-names))
+
+                (defun ,negative-p-name (n)
+                  (and (typep n ',type)
+                       (< n ,zero)))
+
+                (defun ,non-positive-p-name (n)
+                  (and (typep n ',type)
+                       (<= n ,zero)))
+
+                (defun ,non-negative-p-name (n)
+                  (and (typep n ',type)
+                       (<= ,zero n)))
+
+                (defun ,positive-p-name (n)
+                  (and (typep n ',type)
+                       (< ,zero n)))))))))
+  (frob fixnum integer)
+  (frob integer)
+  (frob rational)
+  (frob real)
+  (frob float)
+  (frob short-float)
+  (frob single-float)
+  (frob double-float)
+  (frob long-float))
+
+(defun of-type (type)
+  "Returns a function of one argument, which returns true when its argument is
+of TYPE."
+  (lambda (thing) (typep thing type)))
+
+(define-compiler-macro of-type (&whole form type &environment env)
+  ;; This can yeild a big benefit, but no point inlining the function
+  ;; all over the place if TYPE is not constant.
+  (if (constantp type env)
+      (with-gensyms (thing)
+        `(lambda (,thing)
+           (typep ,thing ,type)))
+      form))
+
+(declaim (inline type=))
+(defun type= (type1 type2)
+  "Returns a primary value of T is TYPE1 and TYPE2 are the same type,
+and a secondary value that is true is the type equality could be reliably
+determined: primary value of NIL and secondary value of T indicates that the
+types are not equivalent."
+  (multiple-value-bind (sub ok) (subtypep type1 type2)
+    (cond ((and ok sub)
+           (subtypep type2 type1))
+          (ok
+           (values nil ok))
+          (t
+           (multiple-value-bind (sub ok) (subtypep type2 type1)
+             (declare (ignore sub))
+             (values nil ok))))))
+
+(define-modify-macro coercef (type-spec) coerce
+  "Modify-macro for COERCE.")
diff --git a/third_party/lisp/asdf-flv/.gitattributes b/third_party/lisp/asdf-flv/.gitattributes
new file mode 100644
index 000000000000..2b45716e4709
--- /dev/null
+++ b/third_party/lisp/asdf-flv/.gitattributes
@@ -0,0 +1,2 @@
+.gitignore	export-ignore
+.gitattributes	export-ignore
diff --git a/third_party/lisp/asdf-flv/.gitignore b/third_party/lisp/asdf-flv/.gitignore
new file mode 100644
index 000000000000..bdf4ad2ae6dd
--- /dev/null
+++ b/third_party/lisp/asdf-flv/.gitignore
@@ -0,0 +1,3 @@
+sbcl-*/
+cmu-*/
+openmcl-*/
diff --git a/third_party/lisp/asdf-flv/Makefile b/third_party/lisp/asdf-flv/Makefile
new file mode 100644
index 000000000000..b4c74feefe82
--- /dev/null
+++ b/third_party/lisp/asdf-flv/Makefile
@@ -0,0 +1,77 @@
+### Makefile --- Toplevel directory
+
+## Copyright (C) 2011, 2015 Didier Verna
+
+## Author: Didier Verna <didier@didierverna.net>
+
+## This file is part of ASDF-FLV.
+
+## Copying and distribution of this file, with or without modification,
+## are permitted in any medium without royalty provided the copyright
+## notice and this notice are preserved.  This file is offered as-is,
+## without any warranty.
+
+
+### Commentary:
+
+## Contents management by FCM version 0.1.
+
+
+### Code:
+
+PROJECT := asdf-flv
+VERSION := 2.1
+
+W3DIR := $(HOME)/www/software/lisp/$(PROJECT)
+
+DIST_NAME := $(PROJECT)-$(VERSION)
+TARBALL   := $(DIST_NAME).tar.gz
+SIGNATURE := $(TARBALL).asc
+
+
+all:
+
+clean:
+	-rm *~
+
+distclean: clean
+	-rm *.tar.gz *.tar.gz.asc
+
+tag:
+	git tag -a -m 'Version $(VERSION)' 'version-$(VERSION)'
+
+tar: $(TARBALL)
+gpg: $(SIGNATURE)
+dist: tar gpg
+
+install-www: dist
+	-install -m 644 $(TARBALL)   "$(W3DIR)/attic/"
+	-install -m 644 $(SIGNATURE) "$(W3DIR)/attic/"
+	echo "\
+<? lref (\"$(PROJECT)/attic/$(PROJECT)-$(VERSION).tar.gz\", \
+	 contents (\"Derni่re version\", \"Latest version\")); ?> \
+| \
+<? lref (\"$(PROJECT)/attic/$(PROJECT)-$(VERSION).tar.gz.asc\", \
+	 contents (\"Signature GPG\", \"GPG Signature\")); ?>" \
+	  > "$(W3DIR)/latest.txt"
+	chmod 644 "$(W3DIR)/latest.txt"
+	cd "$(W3DIR)"					\
+	  && ln -fs attic/$(TARBALL) latest.tar.gz	\
+	  && ln -fs attic/$(SIGNATURE) latest.tar.gz.asc
+
+update-version:
+	perl -pi -e 's/:version ".*"/:version "$(VERSION)"/' \
+	  net.didierverna.$(PROJECT).asd
+
+$(TARBALL):
+	git archive --format=tar --prefix=$(DIST_NAME)/ \
+	    --worktree-attributes HEAD			\
+	  | gzip -c > $@
+
+$(SIGNATURE): $(TARBALL)
+	gpg -b -a $<
+
+
+.PHONY: all clean distclean tag tar gpg dist install-www update-version
+
+### Makefile ends here
diff --git a/third_party/lisp/asdf-flv/README.md b/third_party/lisp/asdf-flv/README.md
new file mode 100644
index 000000000000..7ccdd1888163
--- /dev/null
+++ b/third_party/lisp/asdf-flv/README.md
@@ -0,0 +1,7 @@
+ASDF-FLV provides support for file-local variables through ASDF. A file-local
+variable behaves like `*PACKAGE*` and `*READTABLE*` with respect to `LOAD` and
+`COMPILE-FILE`: a new dynamic binding is created before processing the file,
+so that any modification to the variable essentially becomes file-local.
+
+In order to make one or several variables file-local, use the macros
+`SET-FILE-LOCAL-VARIABLE(S)`.
diff --git a/third_party/lisp/asdf-flv/asdf-flv.lisp b/third_party/lisp/asdf-flv/asdf-flv.lisp
new file mode 100644
index 000000000000..76c6845b82b3
--- /dev/null
+++ b/third_party/lisp/asdf-flv/asdf-flv.lisp
@@ -0,0 +1,64 @@
+;;; asdf-flv.lisp --- Implementation
+
+;; Copyright (C) 2011, 2015 Didier Verna
+
+;; Author: Didier Verna <didier@didierverna.net>
+
+;; This file is part of ASDF-FLV.
+
+;; Copying and distribution of this file, with or without modification,
+;; are permitted in any medium without royalty provided the copyright
+;; notice and this notice are preserved.  This file is offered as-is,
+;; without any warranty.
+
+
+;;; Commentary:
+
+;; Contents management by FCM version 0.1.
+
+
+;;; Code:
+
+(in-package :net.didierverna.asdf-flv)
+
+
+(defvar *file-local-variables* ()
+  "List of file-local special variables.")
+
+
+(defun make-variable-file-local (symbol)
+  "Make special variable named by SYMBOL have a file-local value."
+  (pushnew symbol *file-local-variables*))
+
+(defmacro set-file-local-variable (symbol)
+  "Set special variable named by SYMBOL as file-local.
+SYMBOL need not be quoted."
+  `(make-variable-file-local ',symbol))
+
+(defun make-variables-file-local (&rest symbols)
+  "Make special variables named by SYMBOLS have a file-local value."
+  (dolist (symbol symbols)
+    (pushnew symbol *file-local-variables*)))
+
+(defmacro set-file-local-variables (&rest symbols)
+  "Set special variables named by SYMBOLS as file-local.
+SYMBOLS need not be quoted."
+  `(make-variables-file-local ,@(mapcar (lambda (symbol) (list 'quote symbol))
+					symbols)))
+
+
+(defmethod asdf:perform :around
+    ((operation asdf:load-op) (file asdf:cl-source-file))
+  "Establish new dynamic bindings for file-local variables."
+  (progv *file-local-variables*
+      (mapcar #'symbol-value *file-local-variables*)
+    (call-next-method)))
+
+(defmethod asdf:perform :around
+    ((operation asdf:compile-op) (file asdf:cl-source-file))
+  "Establish new dynamic bindings for file-local variables."
+  (progv *file-local-variables*
+      (mapcar #'symbol-value *file-local-variables*)
+    (call-next-method)))
+
+;;; asdf-flv.lisp ends here
diff --git a/third_party/lisp/asdf-flv/default.nix b/third_party/lisp/asdf-flv/default.nix
new file mode 100644
index 000000000000..e8ec4aa8f85c
--- /dev/null
+++ b/third_party/lisp/asdf-flv/default.nix
@@ -0,0 +1,13 @@
+# Imported from https://github.com/didierverna/asdf-flv
+{ depot, ... }:
+
+with depot.nix;
+buildLisp.library {
+  name = "asdf-flv";
+  deps = [ (buildLisp.bundled "asdf") ];
+
+  srcs = [
+    ./package.lisp
+    ./asdf-flv.lisp
+  ];
+}
diff --git a/third_party/lisp/asdf-flv/net.didierverna.asdf-flv.asd b/third_party/lisp/asdf-flv/net.didierverna.asdf-flv.asd
new file mode 100644
index 000000000000..41202746d019
--- /dev/null
+++ b/third_party/lisp/asdf-flv/net.didierverna.asdf-flv.asd
@@ -0,0 +1,43 @@
+;;; net.didierverna.asdf-flv.asd --- ASDF system definition
+
+;; Copyright (C) 2011, 2015 Didier Verna
+
+;; Author: Didier Verna <didier@didierverna.net>
+
+;; This file is part of ASDF-FLV.
+
+;; Copying and distribution of this file, with or without modification,
+;; are permitted in any medium without royalty provided the copyright
+;; notice and this notice are preserved.  This file is offered as-is,
+;; without any warranty.
+
+
+;;; Commentary:
+
+;; Contents management by FCM version 0.1.
+
+
+;;; Code:
+
+(asdf:defsystem :net.didierverna.asdf-flv
+  :long-name "ASDF File Local Variables"
+  :description "ASDF extension to provide support for file-local variables."
+  :long-description "\
+ASDF-FLV provides support for file-local variables through ASDF. A file-local
+variable behaves like *PACKAGE* and *READTABLE* with respect to LOAD and
+COMPILE-FILE: a new dynamic binding is created before processing the file, so
+that any modification to the variable becomes essentially file-local.
+
+In order to make one or several variables file-local, use the macros
+SET-FILE-LOCAL-VARIABLE(S)."
+  :author "Didier Verna"
+  :mailto "didier@didierverna.net"
+  :homepage "http://www.lrde.epita.fr/~didier/software/lisp/misc.php#asdf-flv"
+  :source-control "https://github.com/didierverna/asdf-flv"
+  :license "GNU All Permissive"
+  :version "2.1"
+  :serial t
+  :components ((:file "package")
+	       (:file "asdf-flv")))
+
+;;; net.didierverna.asdf-flv.asd ends here
diff --git a/third_party/lisp/asdf-flv/package.lisp b/third_party/lisp/asdf-flv/package.lisp
new file mode 100644
index 000000000000..1d7fb2bab43d
--- /dev/null
+++ b/third_party/lisp/asdf-flv/package.lisp
@@ -0,0 +1,28 @@
+;;; package.lisp --- Package definition
+
+;; Copyright (C) 2011, 2015 Didier Verna
+
+;; Author: Didier Verna <didier@didierverna.net>
+
+;; This file is part of ASDF-FLV.
+
+;; Copying and distribution of this file, with or without modification,
+;; are permitted in any medium without royalty provided the copyright
+;; notice and this notice are preserved.  This file is offered as-is,
+;; without any warranty.
+
+
+;;; Commentary:
+
+;; Contents management by FCM version 0.1.
+
+
+;;; Code:
+
+(in-package :cl-user)
+
+(defpackage :net.didierverna.asdf-flv
+  (:use :cl)
+  (:export :set-file-local-variable :set-file-local-variables))
+
+;;; package.lisp ends here
diff --git a/third_party/lisp/babel.nix b/third_party/lisp/babel.nix
new file mode 100644
index 000000000000..7c066904fe12
--- /dev/null
+++ b/third_party/lisp/babel.nix
@@ -0,0 +1,31 @@
+# Babel is an encoding conversion library for Common Lisp.
+{ depot, ... }:
+
+let src = builtins.fetchGit {
+  url = "https://github.com/cl-babel/babel.git";
+  rev = "ec9a17cdbdba3c1dd39609fc7961cfb3f0aa260e";
+};
+in depot.nix.buildLisp.library {
+  name = "babel";
+  deps = [ depot.third_party.lisp.alexandria ];
+
+  srcs = map (f: src + ("/src/" + f)) [
+    "packages.lisp"
+    "encodings.lisp"
+    "enc-ascii.lisp"
+    "enc-ebcdic.lisp"
+    "enc-ebcdic-int.lisp"
+    "enc-iso-8859.lisp"
+    "enc-unicode.lisp"
+    "enc-cp1251.lisp"
+    "enc-cp1252.lisp"
+    "jpn-table.lisp"
+    "enc-jpn.lisp"
+    "enc-gbk.lisp"
+    "enc-koi8.lisp"
+    "external-format.lisp"
+    "strings.lisp"
+    "gbk-map.lisp"
+    "sharp-backslash.lisp"
+  ];
+}
diff --git a/third_party/lisp/bordeaux-threads.nix b/third_party/lisp/bordeaux-threads.nix
new file mode 100644
index 000000000000..b2596672bad2
--- /dev/null
+++ b/third_party/lisp/bordeaux-threads.nix
@@ -0,0 +1,19 @@
+# This library is meant to make writing portable multi-threaded apps
+# in Common Lisp simple.
+{ depot, ... }:
+
+let src = builtins.fetchGit {
+  url = "https://github.com/sionescu/bordeaux-threads.git";
+  rev = "499b6d3f0ce635417d6096acf0a671d8bf3f6e5f";
+};
+in depot.nix.buildLisp.library {
+  name = "bordeaux-threads";
+  deps = [ depot.third_party.lisp.alexandria ];
+
+  srcs = map (f: src + ("/src/" + f)) [
+    "pkgdcl.lisp"
+    "bordeaux-threads.lisp"
+    "impl-sbcl.lisp"
+    "default-implementations.lisp"
+  ];
+}
diff --git a/third_party/lisp/cffi.nix b/third_party/lisp/cffi.nix
new file mode 100644
index 000000000000..62c1f81da720
--- /dev/null
+++ b/third_party/lisp/cffi.nix
@@ -0,0 +1,33 @@
+# CFFI purports to be the Common Foreign Function Interface.
+{ depot, ... }:
+
+with depot.nix;
+let src = builtins.fetchGit {
+  url = "https://github.com/cffi/cffi.git";
+  rev = "5e838bf46d0089c43ebd3ea014a207c403e29c61";
+};
+in buildLisp.library {
+  name = "cffi";
+  deps = with depot.third_party.lisp; [
+    alexandria
+    babel
+    trivial-features
+    (buildLisp.bundled "asdf")
+    (buildLisp.bundled "uiop")
+  ];
+
+  srcs = map (f: src + ("/src/" + f)) [
+    "cffi-sbcl.lisp"
+    "package.lisp"
+    "utils.lisp"
+    "libraries.lisp"
+    "early-types.lisp"
+    "types.lisp"
+    "enum.lisp"
+    "strings.lisp"
+    "structures.lisp"
+    "functions.lisp"
+    "foreign-vars.lisp"
+    "features.lisp"
+  ];
+}
diff --git a/third_party/lisp/chipz.nix b/third_party/lisp/chipz.nix
new file mode 100644
index 000000000000..dfbf32b09411
--- /dev/null
+++ b/third_party/lisp/chipz.nix
@@ -0,0 +1,33 @@
+# Common Lisp library for decompressing deflate, zlib, gzip, and bzip2 data
+{ depot, ... }:
+
+with depot.nix;
+
+let src = depot.third_party.fetchFromGitHub {
+  owner = "froydnj";
+  repo = "chipz";
+  rev = "75dfbc660a5a28161c57f115adf74c8a926bfc4d";
+  sha256 = "0plx4rs39zbs4gjk77h4a2q11zpy75fh9v8hnxrvsf8fnakajhwg";
+};
+in buildLisp.library {
+  name = "chipz";
+  deps = [ (buildLisp.bundled "asdf") ];
+
+  srcs = map (f: src + ("/" + f)) [
+    "chipz.asd"
+    "package.lisp"
+    "constants.lisp"
+    "conditions.lisp"
+    "dstate.lisp"
+    "types-and-tables.lisp"
+    "crc32.lisp"
+    "adler32.lisp"
+    "inflate-state.lisp"
+    "gzip.lisp"
+    "zlib.lisp"
+    "inflate.lisp"
+    "bzip2.lisp"
+    "decompress.lisp"
+    "stream.lisp"
+  ];
+}
diff --git a/third_party/lisp/chunga.nix b/third_party/lisp/chunga.nix
new file mode 100644
index 000000000000..f7879818877c
--- /dev/null
+++ b/third_party/lisp/chunga.nix
@@ -0,0 +1,27 @@
+# Portable chunked streams for Common Lisp
+{ depot, ... }:
+
+let src = depot.third_party.fetchFromGitHub {
+  owner = "edicl";
+  repo = "chunga";
+  rev = "16330852d01dfde4dd97dee7cd985a88ea571e7e";
+  sha256 = "0jzn3nyb3f22gm983rfk99smqs3mhb9ivjmasvhq9qla5cl9pyhd";
+};
+in depot.nix.buildLisp.library {
+  name = "chunga";
+  deps = with depot.third_party.lisp; [
+    trivial-gray-streams
+  ];
+
+  srcs = map (f: src + ("/" + f)) [
+    "packages.lisp"
+    "specials.lisp"
+    "util.lisp"
+    "known-words.lisp"
+    "conditions.lisp"
+    "read.lisp"
+    "streams.lisp"
+    "input.lisp"
+    "output.lisp"
+  ];
+}
diff --git a/third_party/lisp/cl-ansi-text.nix b/third_party/lisp/cl-ansi-text.nix
new file mode 100644
index 000000000000..5c01e023265a
--- /dev/null
+++ b/third_party/lisp/cl-ansi-text.nix
@@ -0,0 +1,19 @@
+# Enables ANSI colors for printing.
+{ depot, ... }:
+
+let src = builtins.fetchGit {
+  url = "https://github.com/pnathan/cl-ansi-text.git";
+  rev = "257a5f19a2dc92d22f8fd772c0a78923b99b36a8";
+};
+in depot.nix.buildLisp.library {
+  name = "cl-ansi-text";
+  deps = with depot.third_party.lisp; [
+    alexandria
+    cl-colors2
+  ];
+
+  srcs = map (f: src + ("/src/" + f)) [
+    "cl-ansi-text.lisp"
+    "define-colors.lisp"
+  ];
+}
diff --git a/third_party/lisp/cl-base64.nix b/third_party/lisp/cl-base64.nix
new file mode 100644
index 000000000000..1152601a81d3
--- /dev/null
+++ b/third_party/lisp/cl-base64.nix
@@ -0,0 +1,17 @@
+# Base64 encoding for Common Lisp
+{ depot, ... }:
+
+let src = builtins.fetchGit {
+  url = "http://git.kpe.io/cl-base64.git";
+  rev = "fc62a5342445d4ec1dd44e95f7dc513473a8c89a";
+};
+in depot.nix.buildLisp.library {
+  name = "cl-base64";
+  srcs = [
+    (src + "/package.lisp")
+    (src + "/encode.lisp")
+    (src + "/decode.lisp")
+  ];
+}
+
+
diff --git a/third_party/lisp/cl-colors2.nix b/third_party/lisp/cl-colors2.nix
new file mode 100644
index 000000000000..c90b8eae0118
--- /dev/null
+++ b/third_party/lisp/cl-colors2.nix
@@ -0,0 +1,21 @@
+
+{ depot, ... }:
+
+let src = builtins.fetchGit {
+  url = "https://notabug.org/cage/cl-colors2.git";
+  rev = "795aedee593b095fecde574bd999b520dd03ed24";
+};
+in depot.nix.buildLisp.library {
+  name = "cl-colors2";
+  deps = with depot.third_party.lisp; [
+    alexandria
+    cl-ppcre
+  ];
+
+  srcs = map (f: src + ("/" + f)) [
+    "package.lisp"
+    "colors.lisp"
+    "colornames.lisp"
+    "hexcolors.lisp"
+  ];
+}
diff --git a/third_party/lisp/cl-fad.nix b/third_party/lisp/cl-fad.nix
new file mode 100644
index 000000000000..8131bf31be2d
--- /dev/null
+++ b/third_party/lisp/cl-fad.nix
@@ -0,0 +1,27 @@
+# Portable pathname library
+{ depot, ...}:
+
+with depot.nix;
+
+let src = depot.third_party.fetchFromGitHub {
+  owner = "edicl";
+  repo = "cl-fad";
+  rev = "c13d81c4bd9ba3a172631fd05dd213ab90e7d4cb";
+  sha256 = "1gc8i82v6gks7g0lnm54r4prk2mklidv2flm5fvbr0a7rsys0vpa";
+};
+in buildLisp.library {
+  name = "cl-fad";
+
+  deps = with depot.third_party.lisp; [
+    alexandria
+    bordeaux-threads
+    (buildLisp.bundled "sb-posix")
+  ];
+
+  srcs = map (f: src + ("/" + f)) [
+    "packages.lisp"
+    "fad.lisp"
+    "path.lisp"
+    "temporary-files.lisp"
+  ];
+}
diff --git a/third_party/lisp/cl-json.nix b/third_party/lisp/cl-json.nix
new file mode 100644
index 000000000000..3652bd07932c
--- /dev/null
+++ b/third_party/lisp/cl-json.nix
@@ -0,0 +1,26 @@
+# JSON encoder & decoder
+{ depot, ... }:
+
+with depot.nix;
+let src = depot.third_party.fetchFromGitHub {
+  owner = "hankhero";
+  repo = "cl-json";
+  rev = "6dfebb9540bfc3cc33582d0c03c9ec27cb913e79";
+  sha256 = "0fx3m3x3s5ji950yzpazz4s0img3l6b3d6l3jrfjv0lr702496lh";
+};
+in buildLisp.library {
+  name = "cl-json";
+  deps = [ (buildLisp.bundled "asdf") ];
+
+  srcs = [ "${src}/cl-json.asd" ] ++
+  (map (f: src + ("/src/" + f)) [
+    "package.lisp"
+    "common.lisp"
+    "objects.lisp"
+    "camel-case.lisp"
+    "decoder.lisp"
+    "encoder.lisp"
+    "utils.lisp"
+    "json-rpc.lisp"
+  ]);
+}
diff --git a/third_party/lisp/cl-plus-ssl.nix b/third_party/lisp/cl-plus-ssl.nix
new file mode 100644
index 000000000000..63c21aa6ba45
--- /dev/null
+++ b/third_party/lisp/cl-plus-ssl.nix
@@ -0,0 +1,40 @@
+# Common Lisp bindings to OpenSSL
+{ depot, ... }:
+
+with depot.nix;
+
+let src = builtins.fetchGit {
+  url = "https://github.com/cl-plus-ssl/cl-plus-ssl.git";
+  rev = "29081992f6d7b4e3aa2c5eeece4cd92b745071f4";
+};
+in buildLisp.library {
+  name = "cl-plus-ssl";
+  deps = with depot.third_party.lisp; [
+    alexandria
+    bordeaux-threads
+    cffi
+    flexi-streams
+    trivial-features
+    trivial-garbage
+    trivial-gray-streams
+    (buildLisp.bundled "uiop")
+    (buildLisp.bundled "sb-posix")
+  ];
+
+  native = [ depot.third_party.openssl ];
+
+  srcs = map (f: src + ("/src/" + f)) [
+    "package.lisp"
+    "reload.lisp"
+    "conditions.lisp"
+    "ffi.lisp"
+    "x509.lisp"
+    "ffi-buffer-all.lisp"
+    "ffi-buffer.lisp"
+    "streams.lisp"
+    "bio.lisp"
+    "random.lisp"
+    "context.lisp"
+    "verify-hostname.lisp"
+  ];
+}
diff --git a/third_party/lisp/cl-ppcre.nix b/third_party/lisp/cl-ppcre.nix
new file mode 100644
index 000000000000..1dc9eb553118
--- /dev/null
+++ b/third_party/lisp/cl-ppcre.nix
@@ -0,0 +1,30 @@
+# cl-ppcre is a Common Lisp regular expression library.
+{ depot, ... }:
+
+let src = builtins.fetchGit {
+  url = "https://github.com/edicl/cl-ppcre";
+  rev = "1ca0cd9ca0d161acd49c463d6cb5fff897596e2f";
+};
+in depot.nix.buildLisp.library {
+  name = "cl-ppcre";
+
+  srcs = map (f: src + ("/" + f)) [
+    "packages.lisp"
+    "specials.lisp"
+    "util.lisp"
+    "errors.lisp"
+    "charset.lisp"
+    "charmap.lisp"
+    "chartest.lisp"
+    "lexer.lisp"
+    "parser.lisp"
+    "regex-class.lisp"
+    "regex-class-util.lisp"
+    "convert.lisp"
+    "optimize.lisp"
+    "closures.lisp"
+    "repetition-closures.lisp"
+    "scanner.lisp"
+    "api.lisp"
+  ];
+}
diff --git a/third_party/lisp/cl-prevalence.nix b/third_party/lisp/cl-prevalence.nix
new file mode 100644
index 000000000000..c024db0924e2
--- /dev/null
+++ b/third_party/lisp/cl-prevalence.nix
@@ -0,0 +1,29 @@
+# cl-prevalence is an implementation of object prevalence for CL (i.e.
+# an in-memory database)
+{ depot, ... }:
+
+let src = depot.third_party.fetchFromGitHub {
+  owner = "40ants";
+  repo = "cl-prevalence";
+  rev = "da3ed6c4594b1c2fca90c178c1993973c4bf16c9";
+  sha256 = "0bq905hv1626dl6b7s0zn4lbdh608g1pxaljl1fda6pwp9hmj95a";
+};
+in depot.nix.buildLisp.library {
+  name = "cl-prevalence";
+
+  deps = with depot.third_party.lisp; [
+    s-xml
+    s-sysdeps
+  ];
+
+  srcs = map (f: src + ("/src/" + f)) [
+    "package.lisp"
+    "serialization/serialization.lisp"
+    "serialization/xml.lisp"
+    "serialization/sexp.lisp"
+    "prevalence.lisp"
+    "managed-prevalence.lisp"
+    "master-slave.lisp"
+    "blob.lisp"
+  ];
+}
diff --git a/third_party/lisp/closer-mop.nix b/third_party/lisp/closer-mop.nix
new file mode 100644
index 000000000000..ab7e33e59b04
--- /dev/null
+++ b/third_party/lisp/closer-mop.nix
@@ -0,0 +1,20 @@
+# Closer to MOP is a compatibility layer that rectifies many of the
+# absent or incorrect CLOS MOP features across a broad range of Common
+# Lisp implementations
+{ depot, ... }:
+
+let src = depot.third_party.fetchFromGitHub {
+  owner = "pcostanza";
+  repo = "closer-mop";
+  rev = "e1d1430524086709a7ea8e0eede6849aa29d6276";
+  sha256 = "1zda6927379pmrsxpg29jnj6azjpa2pms9h7n1iwhy6q9d3w06rf";
+};
+in depot.nix.buildLisp.library {
+  name = "closer-mop";
+
+  srcs = [
+    "${src}/closer-mop-packages.lisp"
+    "${src}/closer-mop-shared.lisp"
+    "${src}/closer-sbcl.lisp"
+  ];
+}
diff --git a/third_party/lisp/drakma.nix b/third_party/lisp/drakma.nix
new file mode 100644
index 000000000000..8b8b9f1c903f
--- /dev/null
+++ b/third_party/lisp/drakma.nix
@@ -0,0 +1,37 @@
+# Drakma is an HTTP client for Common Lisp.
+{ depot, ... }:
+
+with depot.nix;
+
+let src = depot.third_party.fetchFromGitHub {
+  owner = "edicl";
+  repo = "drakma";
+  rev = "87feb02bef00b11a753d5fb21a5fec526b0d0bbb";
+  sha256 = "01b80am2vrw94xmdj7f21qm7p5ys08mmpzv4nc4icql81hqr1w2m";
+};
+in buildLisp.library {
+  name = "drakma";
+  deps = with depot.third_party.lisp; [
+    chipz
+    chunga
+    cl-base64
+    cl-plus-ssl
+    cl-ppcre
+    flexi-streams
+    puri
+    usocket
+    (buildLisp.bundled "asdf")
+  ];
+
+  srcs = map (f: src + ("/" + f)) [
+    "drakma.asd" # Required because the system definition is used
+    "packages.lisp"
+    "specials.lisp"
+    "conditions.lisp"
+    "util.lisp"
+    "read.lisp"
+    "cookies.lisp"
+    "encoding.lisp"
+    "request.lisp"
+  ];
+}
diff --git a/third_party/lisp/fiveam/.boring b/third_party/lisp/fiveam/.boring
new file mode 100644
index 000000000000..662944f765b3
--- /dev/null
+++ b/third_party/lisp/fiveam/.boring
@@ -0,0 +1,14 @@
+# Boring file regexps:
+\#
+~$
+(^|/)_darcs($|/)
+\.dfsl$
+\.ppcf$
+\.fasl$
+\.x86f$
+\.fas$
+\.lib$
+^docs/html($|/)
+^docs/pdf($|/)
+^\{arch\}$
+(^|/).arch-ids($|/)
diff --git a/third_party/lisp/fiveam/.travis.yml b/third_party/lisp/fiveam/.travis.yml
new file mode 100644
index 000000000000..6f6559189f27
--- /dev/null
+++ b/third_party/lisp/fiveam/.travis.yml
@@ -0,0 +1,47 @@
+dist: bionic
+language: lisp
+
+env:
+  matrix:
+    - LISP=abcl
+    - LISP=allegro
+    - LISP=ccl
+    - LISP=ccl32
+    - LISP=ecl
+    - LISP=sbcl
+    - LISP=sbcl32
+    - LISP=cmucl
+
+matrix:
+  allow_failures:
+    - env: LISP=allegro
+    - env: LISP=ccl32
+    - env: LISP=cmucl
+    - env: LISP=sbcl32
+
+notifications:
+  email:
+    on_success: change
+    on_failure: always
+  irc:
+    channels:
+      - "chat.freenode.net#iolib"
+    on_success: change
+    on_failure: always
+    use_notice: true
+    skip_join: true
+
+install:
+  - curl -L https://raw.githubusercontent.com/sionescu/cl-travis/master/install.sh | sh
+  - cl -e "(cl:in-package :cl-user)
+           (dolist (p '(:alexandria))
+             (ql:quickload p :verbose t))"
+
+script:
+  - cl -e "(cl:in-package :cl-user)
+           (ql:quickload :fiveam/test :verbose t)
+           (uiop:quit (if (some (lambda (x) (typep x '5am::test-failure))
+                                (5am:run :it.bese.fiveam))
+                          1 0))"
+
+sudo: required
diff --git a/third_party/lisp/fiveam/COPYING b/third_party/lisp/fiveam/COPYING
new file mode 100644
index 000000000000..91adf85a5a64
--- /dev/null
+++ b/third_party/lisp/fiveam/COPYING
@@ -0,0 +1,30 @@
+Copyright (c) 2003-2006, Edward Marco Baringer
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+- Redistributions of source code must retain the above copyright
+notice, this list of conditions and the following disclaimer.
+  
+- 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.
+    
+- Neither the name of Edward Marco Baringer, nor BESE, nor the names
+of its contributors may be used to endorse or promote products derived
+from this software without specific prior written permission.
+
+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.
+
diff --git a/third_party/lisp/fiveam/README b/third_party/lisp/fiveam/README
new file mode 100644
index 000000000000..32a205fa5f5a
--- /dev/null
+++ b/third_party/lisp/fiveam/README
@@ -0,0 +1,8 @@
+This is FiveAM, a common lisp testing framework.
+
+The documentation can be found in the docstrings, start with the
+package :it.bese.fiveam (nicknamed 5AM).
+
+The mailing list for FiveAM is fiveam-devel@common-lisp.net
+
+All the code is Copyright (C) 2002-2006 Edward Marco Baringer.
diff --git a/third_party/lisp/fiveam/default.nix b/third_party/lisp/fiveam/default.nix
new file mode 100644
index 000000000000..4236b93bc9c5
--- /dev/null
+++ b/third_party/lisp/fiveam/default.nix
@@ -0,0 +1,28 @@
+# FiveAM is a Common Lisp testing framework.
+#
+# Imported from https://github.com/sionescu/fiveam.git
+
+{ depot, ... }:
+
+depot.nix.buildLisp.library {
+  name = "fiveam";
+
+  deps = with depot.third_party.lisp; [
+    alexandria
+    asdf-flv
+    trivial-backtrace
+  ];
+
+  srcs = [
+    ./src/package.lisp
+    ./src/utils.lisp
+    ./src/check.lisp
+    ./src/fixture.lisp
+    ./src/classes.lisp
+    ./src/random.lisp
+    ./src/test.lisp
+    ./src/explain.lisp
+    ./src/suite.lisp
+    ./src/run.lisp
+  ];
+}
diff --git a/third_party/lisp/fiveam/docs/make-qbook.lisp b/third_party/lisp/fiveam/docs/make-qbook.lisp
new file mode 100644
index 000000000000..8144c94f020e
--- /dev/null
+++ b/third_party/lisp/fiveam/docs/make-qbook.lisp
@@ -0,0 +1,13 @@
+(asdf:oos 'asdf:load-op :FiveAM)
+(asdf:oos 'asdf:load-op :qbook)
+
+(asdf:oos 'qbook:publish-op :FiveAM
+          :generator (make-instance 'qbook:html-generator
+                                    :title "FiveAM"
+                                    :output-directory
+                                    (merge-pathnames
+                                        (make-pathname :directory '(:relative "docs" "html"))
+                                        (asdf:component-pathname (asdf:find-system :FiveAM)))))
+
+          
+
diff --git a/third_party/lisp/fiveam/fiveam.asd b/third_party/lisp/fiveam/fiveam.asd
new file mode 100644
index 000000000000..7607e33372fd
--- /dev/null
+++ b/third_party/lisp/fiveam/fiveam.asd
@@ -0,0 +1,36 @@
+;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
+
+#.(unless (or #+asdf3.1 (version<= "3.1" (asdf-version)))
+    (error "You need ASDF >= 3.1 to load this system correctly."))
+
+(defsystem :fiveam
+  :author "Edward Marco Baringer <mb@bese.it>"
+  :version (:read-file-form "version.sexp")
+  :description "A simple regression testing framework"
+  :license "BSD"
+  :depends-on (:alexandria :net.didierverna.asdf-flv  :trivial-backtrace)
+  :pathname "src/"
+  :components ((:file "package")
+               (:file "utils" :depends-on ("package"))
+               (:file "check" :depends-on ("package" "utils"))
+               (:file "fixture" :depends-on ("package"))
+               (:file "classes" :depends-on ("package"))
+               (:file "random" :depends-on ("package" "check"))
+               (:file "test" :depends-on ("package" "fixture" "classes"))
+               (:file "explain" :depends-on ("package" "utils" "check" "classes" "random"))
+               (:file "suite" :depends-on ("package" "test" "classes"))
+               (:file "run" :depends-on ("package" "check" "classes" "test" "explain" "suite")))
+  :in-order-to ((test-op (test-op :fiveam/test))))
+
+(defsystem :fiveam/test
+  :author "Edward Marco Baringer <mb@bese.it>"
+  :description "FiveAM's own test suite"
+  :license "BSD"
+  :depends-on (:fiveam)
+  :pathname "t/"
+  :components ((:file "tests"))
+  :perform (test-op (o c) (symbol-call :5am :run! :it.bese.fiveam)))
+
+;;;;@include "src/package.lisp"
+
+;;;;@include "t/example.lisp"
diff --git a/third_party/lisp/fiveam/src/check.lisp b/third_party/lisp/fiveam/src/check.lisp
new file mode 100644
index 000000000000..b3808c5cf04c
--- /dev/null
+++ b/third_party/lisp/fiveam/src/check.lisp
@@ -0,0 +1,311 @@
+;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
+
+(in-package :it.bese.fiveam)
+
+;;;; * Checks
+
+;;;; At the lowest level testing the system requires that certain
+;;;; forms be evaluated and that certain post conditions are met: the
+;;;; value returned must satisfy a certain predicate, the form must
+;;;; (or must not) signal a certain condition, etc. In FiveAM these
+;;;; low level operations are called 'checks' and are defined using
+;;;; the various checking macros.
+
+;;;; Checks are the basic operators for collecting results. Tests and
+;;;; test suites on the other hand allow grouping multiple checks into
+;;;; logic collections.
+
+(defvar *test-dribble* t)
+
+(defmacro with-*test-dribble* (stream &body body)
+  `(let ((*test-dribble* ,stream))
+     (declare (special *test-dribble*))
+     ,@body))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (def-special-environment run-state ()
+    result-list
+    current-test))
+
+;;;; ** Types of test results
+
+;;;; Every check produces a result object.
+
+(defclass test-result ()
+  ((reason :accessor reason :initarg :reason :initform "no reason given")
+   (test-case :accessor test-case :initarg :test-case)
+   (test-expr :accessor test-expr :initarg :test-expr))
+  (:documentation "All checking macros will generate an object of
+ type TEST-RESULT."))
+
+(defclass test-passed (test-result)
+  ()
+  (:documentation "Class for successful checks."))
+
+(defgeneric test-passed-p (object)
+  (:method ((o t)) nil)
+  (:method ((o test-passed)) t))
+
+(define-condition check-failure (error)
+  ((reason :accessor reason :initarg :reason :initform "no reason given")
+   (test-case :accessor test-case :initarg :test-case)
+   (test-expr :accessor test-expr :initarg :test-expr))
+  (:documentation "Signaled when a check fails.")
+  (:report  (lambda (c stream)
+              (format stream "The following check failed: ~S~%~A."
+                      (test-expr c)
+                      (reason c)))))
+
+(defun process-failure (test-expr &optional reason-format &rest format-args)
+  (let ((reason (and reason-format
+                     (apply #'format nil reason-format format-args))))
+    (with-simple-restart (ignore-failure "Continue the test run.")
+      (error 'check-failure :test-expr test-expr
+                            :reason reason))
+    (add-result 'test-failure :test-expr test-expr
+                              :reason reason)))
+
+(defclass test-failure (test-result)
+  ()
+  (:documentation "Class for unsuccessful checks."))
+
+(defgeneric test-failure-p (object)
+  (:method ((o t)) nil)
+  (:method ((o test-failure)) t))
+
+(defclass unexpected-test-failure (test-failure)
+  ((actual-condition :accessor actual-condition :initarg :condition))
+  (:documentation "Represents the result of a test which neither
+passed nor failed, but signaled an error we couldn't deal
+with.
+
+Note: This is very different than a SIGNALS check which instead
+creates a TEST-PASSED or TEST-FAILURE object."))
+
+(defclass test-skipped (test-result)
+  ()
+  (:documentation "A test which was not run. Usually this is due to
+unsatisfied dependencies, but users can decide to skip the test when
+appropriate."))
+
+(defgeneric test-skipped-p (object)
+  (:method ((o t)) nil)
+  (:method ((o test-skipped)) t))
+
+(defun add-result (result-type &rest make-instance-args)
+  "Create a TEST-RESULT object of type RESULT-TYPE passing it the
+  initialize args MAKE-INSTANCE-ARGS and add the resulting
+  object to the list of test results."
+  (with-run-state (result-list current-test)
+    (let ((result (apply #'make-instance result-type
+                         (append make-instance-args (list :test-case current-test)))))
+      (etypecase result
+        (test-passed  (format *test-dribble* "."))
+        (unexpected-test-failure (format *test-dribble* "X"))
+        (test-failure (format *test-dribble* "f"))
+        (test-skipped (format *test-dribble* "s")))
+      (push result result-list))))
+
+;;;; ** The check operators
+
+;;;; *** The IS check
+
+(defmacro is (test &rest reason-args)
+  "The DWIM checking operator.
+
+If TEST returns a true value a test-passed result is generated,
+otherwise a test-failure result is generated. The reason, unless
+REASON-ARGS is provided, is generated based on the form of TEST:
+
+ (predicate expected actual) - Means that we want to check
+ whether, according to PREDICATE, the ACTUAL value is
+ in fact what we EXPECTED.
+
+ (predicate value) - Means that we want to ensure that VALUE
+ satisfies PREDICATE.
+
+ Wrapping the TEST form in a NOT simply produces a negated reason
+ string."
+  (assert (listp test)
+          (test)
+          "Argument to IS must be a list, not ~S" test)
+  (let (bindings effective-test default-reason-args)
+    (with-gensyms (e a v)
+      (flet ((process-entry (predicate expected actual &optional negatedp)
+               ;; make sure EXPECTED is holding the entry that starts with 'values
+               (when (and (consp actual)
+                          (eq (car actual) 'values))
+                 (assert (not (and (consp expected)
+                                   (eq (car expected) 'values))) ()
+                                   "Both the expected and actual part is a values expression.")
+                 (rotatef expected actual))
+               (let ((setf-forms))
+                 (if (and (consp expected)
+                          (eq (car expected) 'values))
+                     (progn
+                       (setf expected (copy-list expected))
+                       (setf setf-forms (loop for cell = (rest expected) then (cdr cell)
+                                              for i from 0
+                                              while cell
+                                              when (eq (car cell) '*)
+                                              collect `(setf (elt ,a ,i) nil)
+                                              and do (setf (car cell) nil)))
+                       (setf bindings (list (list e `(list ,@(rest expected)))
+                                            (list a `(multiple-value-list ,actual)))))
+                     (setf bindings (list (list e expected)
+                                          (list a actual))))
+                 (setf effective-test `(progn
+                                         ,@setf-forms
+                                         ,(if negatedp
+                                              `(not (,predicate ,e ,a))
+                                              `(,predicate ,e ,a)))))))
+        (list-match-case test
+          ((not (?predicate ?expected ?actual))
+           (process-entry ?predicate ?expected ?actual t)
+           (setf default-reason-args
+                 (list "~2&~S~2% evaluated to ~2&~S~2% which is ~2&~S~2%to ~2&~S~2% (it should not be)"
+                       `',?actual a `',?predicate e)))
+          ((not (?satisfies ?value))
+           (setf bindings (list (list v ?value))
+                 effective-test `(not (,?satisfies ,v))
+                 default-reason-args
+                 (list "~2&~S~2% evaluated to ~2&~S~2% which satisfies ~2&~S~2% (it should not)"
+                       `',?value v `',?satisfies)))
+          ((?predicate ?expected ?actual)
+           (process-entry ?predicate ?expected ?actual)
+           (setf default-reason-args
+                 (list "~2&~S~2% evaluated to ~2&~S~2% which is not ~2&~S~2% to ~2&~S~2%."
+                       `',?actual a `',?predicate e)))
+          ((?satisfies ?value)
+           (setf bindings (list (list v ?value))
+                 effective-test `(,?satisfies ,v)
+                 default-reason-args
+                 (list "~2&~S~2% evaluated to ~2&~S~2% which does not satisfy ~2&~S~2%"
+                       `',?value v `',?satisfies)))
+          (?_
+           (setf bindings '()
+                 effective-test test
+                 default-reason-args (list "~2&~S~2% was NIL." `',test)))))
+      `(let ,bindings
+         (if ,effective-test
+             (add-result 'test-passed :test-expr ',test)
+             (process-failure ',test
+                              ,@(or reason-args default-reason-args)))))))
+
+;;;; *** Other checks
+
+(defmacro skip (&rest reason)
+  "Generates a TEST-SKIPPED result."
+  `(progn
+     (format *test-dribble* "s")
+     (add-result 'test-skipped :reason (format nil ,@reason))))
+
+(defmacro is-every (predicate &body clauses)
+  "The input is either a list of lists, or a list of pairs. Generates (is (,predicate ,expr ,value))
+   for each pair of elements or (is (,predicate ,expr ,value) ,@reason) for each list."
+  `(progn
+     ,@(if (every #'consp clauses)
+           (loop for (expected actual . reason) in clauses
+                 collect `(is (,predicate ,expected ,actual) ,@reason))
+           (progn
+             (assert (evenp (list-length clauses)))
+             (loop for (expr value) on clauses by #'cddr
+                   collect `(is (,predicate ,expr ,value)))))))
+
+(defmacro is-true (condition &rest reason-args)
+  "Like IS this check generates a pass if CONDITION returns true
+  and a failure if CONDITION returns false. Unlike IS this check
+  does not inspect CONDITION to determine how to report the
+  failure."
+  `(if ,condition
+       (add-result 'test-passed :test-expr ',condition)
+       (process-failure ',condition
+                        ,@(or reason-args
+                              `("~S did not return a true value" ',condition)))))
+
+(defmacro is-false (condition &rest reason-args)
+  "Generates a pass if CONDITION returns false, generates a
+  failure otherwise. Like IS-TRUE, and unlike IS, IS-FALSE does
+  not inspect CONDITION to determine what reason to give it case
+  of test failure"
+  (with-gensyms (value)
+    `(let ((,value ,condition))
+       (if ,value
+           (process-failure ',condition
+                            ,@(or reason-args
+                                  `("~S returned the value ~S, which is true" ',condition ,value)))
+           (add-result 'test-passed :test-expr ',condition)))))
+
+(defmacro signals (condition-spec
+                   &body body)
+  "Generates a pass if BODY signals a condition of type
+CONDITION. BODY is evaluated in a block named NIL, CONDITION is
+not evaluated."
+  (let ((block-name (gensym)))
+    (destructuring-bind (condition &optional reason-control reason-args)
+        (ensure-list condition-spec)
+      `(block ,block-name
+         (handler-bind ((,condition (lambda (c)
+                                      (declare (ignore c))
+                                      ;; ok, body threw condition
+                                      (add-result 'test-passed
+                                                  :test-expr ',condition)
+                                      (return-from ,block-name t))))
+           (block nil
+             ,@body))
+         (process-failure
+           ',condition
+           ,@(if reason-control
+                 `(,reason-control ,@reason-args)
+                 `("Failed to signal a ~S" ',condition)))
+         (return-from ,block-name nil)))))
+
+(defmacro finishes (&body body)
+  "Generates a pass if BODY executes to normal completion. In
+other words if body does signal, return-from or throw this test
+fails."
+  `(unwind-protect-case () (progn ,@body)
+     (:normal (add-result 'test-passed :test-expr ',body))
+     (:abort (process-failure ',body "Test didn't finish"))))
+
+(defmacro pass (&rest message-args)
+  "Simply generate a PASS."
+  `(add-result 'test-passed
+               :test-expr ',message-args
+               ,@(when message-args
+                   `(:reason (format nil ,@message-args)))))
+
+(defmacro fail (&rest message-args)
+  "Simply generate a FAIL."
+  `(process-failure ',message-args
+                    ,@message-args))
+
+;; Copyright (c) 2002-2003, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;;
+;;  - 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.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;;
+;; 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
diff --git a/third_party/lisp/fiveam/src/classes.lisp b/third_party/lisp/fiveam/src/classes.lisp
new file mode 100644
index 000000000000..fc4dc782e8cb
--- /dev/null
+++ b/third_party/lisp/fiveam/src/classes.lisp
@@ -0,0 +1,128 @@
+;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
+
+(in-package :it.bese.fiveam)
+
+(defclass testable-object ()
+  ((name :initarg :name :accessor name
+         :documentation "A symbol naming this test object.")
+   (description :initarg :description :accessor description :initform nil
+                :documentation "The textual description of this test object.")
+   (depends-on :initarg :depends-on :accessor depends-on :initform nil
+               :documentation "The list of AND, OR, NOT forms specifying when to run this test.")
+   (status :initarg :status :accessor status :initform :unknown
+           :documentation "A symbol specifying the current status
+	   of this test. Either: T - this test (and all its
+	   dependencies, have passed. NIL - this test
+	   failed (either it failed or its dependecies weren't
+	   met. :circular this test has a circular dependency
+	   and was skipped. Or :depends-not-satisfied or :resolving")
+   (profiling-info :accessor profiling-info
+                   :initform nil
+                   :documentation "An object representing how
+                   much time and memory where used by the
+                   test.")
+   (collect-profiling-info :accessor collect-profiling-info
+                           :initarg :collect-profiling-info
+                           :initform nil
+                           :documentation "When T profiling
+                           information will be collected when the
+                           test is run.")))
+
+(defmethod print-object ((test testable-object) stream)
+  (print-unreadable-object (test stream :type t :identity t)
+    (format stream "~S" (name test))))
+
+(defclass test-suite (testable-object)
+  ((tests :accessor tests :initform (make-hash-table :test 'eql)
+          :documentation "The hash table mapping names to test
+	  objects in this suite. The values in this hash table
+	  can be either test-cases or other test-suites."))
+  (:documentation "A test suite is a collection of tests or test suites.
+
+Test suites serve to organize tests into groups so that the
+developer can chose to run some tests and not just one or
+all. Like tests test suites have a name and a description.
+
+Test suites, like tests, can be part of other test suites, this
+allows the developer to create a hierarchy of tests where sub
+trees can be singularly run.
+
+Running a test suite has the effect of running every test (or
+suite) in the suite."))
+
+(defclass test-case (testable-object)
+  ((test-lambda :initarg :test-lambda :accessor test-lambda
+                :documentation "The function to run.")
+   (runtime-package :initarg :runtime-package :accessor runtime-package
+                    :documentation "By default it stores *package* from the time this test was defined (macroexpanded)."))
+  (:documentation "A test case is a single, named, collection of
+checks.
+
+A test case is the smallest organizational element which can be
+run individually. Every test case has a name, which is a symbol,
+a description and a test lambda. The test lambda is a regular
+funcall'able function which should use the various checking
+macros to collect results.
+
+Every test case is part of a suite, when a suite is not
+explicitly specified (either via the :SUITE parameter to the TEST
+macro or the global variable *SUITE*) the test is inserted into
+the global suite named NIL.
+
+Sometimes we want to run a certain test only if another test has
+passed. FiveAM allows us to specify the ways in which one test is
+dependent on another.
+
+- AND Run this test only if all the named tests passed.
+
+- OR Run this test if at least one of the named tests passed.
+
+- NOT Run this test only if another test has failed.
+
+FiveAM considers a test to have passed if all the checks executed
+were successful, otherwise we consider the test a failure.
+
+When a test is not run due to it's dependencies having failed a
+test-skipped result is added to the results."))
+
+(defclass explainer ()
+  ())
+
+(defclass text-explainer (explainer)
+  ())
+
+(defclass simple-text-explainer (text-explainer)
+  ())
+
+(defclass detailed-text-explainer (text-explainer)
+  ())
+
+;; Copyright (c) 2002-2003, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;;
+;;  - 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.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;;
+;; 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
diff --git a/third_party/lisp/fiveam/src/explain.lisp b/third_party/lisp/fiveam/src/explain.lisp
new file mode 100644
index 000000000000..015cdf45521a
--- /dev/null
+++ b/third_party/lisp/fiveam/src/explain.lisp
@@ -0,0 +1,133 @@
+;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
+
+(in-package :it.bese.fiveam)
+
+;;;; * Analyzing the results
+
+(defparameter *verbose-failures* nil
+  "T if we should print the expression failing, NIL otherwise.")
+
+;;;; Just as important as defining and runnig the tests is
+;;;; understanding the results. FiveAM provides the function EXPLAIN
+;;;; which prints a human readable summary (number passed, number
+;;;; failed, what failed and why, etc.) of a list of test results.
+
+(defgeneric explain (explainer results &optional stream recursive-depth)
+  (:documentation "Given a list of test results report write to stream detailed
+ human readable statistics regarding the results."))
+
+(defmethod explain ((exp detailed-text-explainer) results
+                    &optional (stream *test-dribble*) (recursive-depth 0))
+  (multiple-value-bind (num-checks passed num-passed passed%
+                                   skipped num-skipped skipped%
+                                   failed num-failed failed%
+                                   unknown num-unknown unknown%)
+      (partition-results results)
+    (declare (ignore passed))
+    (flet ((output (&rest format-args)
+             (format stream "~&~vT" recursive-depth)
+             (apply #'format stream format-args)))
+
+      (when (zerop num-checks)
+        (output "Didn't run anything...huh?")
+        (return-from explain nil))
+      (output "Did ~D check~P.~%" num-checks num-checks)
+      (output "   Pass: ~D (~2D%)~%" num-passed passed%)
+      (output "   Skip: ~D (~2D%)~%" num-skipped skipped%)
+      (output "   Fail: ~D (~2D%)~%" num-failed failed%)
+      (when unknown
+        (output "   UNKNOWN RESULTS: ~D (~2D)~%" num-unknown unknown%))
+      (terpri stream)
+      (when failed
+        (output "Failure Details:~%")
+        (dolist (f (reverse failed))
+          (output "--------------------------------~%")
+          (output "~A ~@{[~A]~}: ~%"
+                  (name (test-case f))
+                  (description (test-case f)))
+          (output "     ~A.~%" (reason f))
+          (when (for-all-test-failed-p f)
+            (output "Results collected with failure data:~%")
+            (explain exp (slot-value f 'result-list)
+                     stream (+ 4 recursive-depth)))
+          (when (and *verbose-failures* (test-expr f))
+            (output "    ~S~%" (test-expr f)))
+          (output "--------------------------------~%"))
+        (terpri stream))
+      (when skipped
+        (output "Skip Details:~%")
+        (dolist (f skipped)
+          (output "~A ~@{[~A]~}: ~%"
+                  (name (test-case f))
+                  (description (test-case f)))
+          (output "    ~A.~%" (reason f)))
+        (terpri stream)))))
+
+(defmethod explain ((exp simple-text-explainer) results
+                    &optional (stream *test-dribble*) (recursive-depth 0))
+  (multiple-value-bind (num-checks passed num-passed passed%
+                                   skipped num-skipped skipped%
+                                   failed num-failed failed%
+                                   unknown num-unknown unknown%)
+      (partition-results results)
+    (declare (ignore passed passed% skipped skipped% failed failed% unknown unknown%))
+    (format stream "~&~vTRan ~D checks, ~D passed" recursive-depth num-checks num-passed)
+    (when (plusp num-skipped)
+      (format stream ", ~D skipped " num-skipped))
+    (format stream " and ~D failed.~%" num-failed)
+    (when (plusp num-unknown)
+      (format stream "~vT~D UNKNOWN RESULTS.~%" recursive-depth num-unknown))))
+
+(defun partition-results (results-list)
+  (let ((num-checks (length results-list)))
+    (destructuring-bind (passed skipped failed unknown)
+        (partitionx results-list
+                    (lambda (res)
+                      (typep res 'test-passed))
+                    (lambda (res)
+                      (typep res 'test-skipped))
+                    (lambda (res)
+                      (typep res 'test-failure))
+                    t)
+      (if (zerop num-checks)
+          (values 0
+                  nil 0 0
+                  nil 0 0
+                  nil 0 0
+                  nil 0 0)
+          (values
+           num-checks
+           passed (length passed) (floor (* 100 (/ (length passed) num-checks)))
+           skipped (length skipped) (floor (* 100 (/ (length skipped) num-checks)))
+           failed (length failed) (floor (* 100 (/ (length failed) num-checks)))
+           unknown (length unknown) (floor (* 100 (/ (length failed) num-checks))))))))
+
+;; Copyright (c) 2002-2003, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;;
+;;  - 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.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;;
+;; 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
diff --git a/third_party/lisp/fiveam/src/fixture.lisp b/third_party/lisp/fiveam/src/fixture.lisp
new file mode 100644
index 000000000000..26e993304fd9
--- /dev/null
+++ b/third_party/lisp/fiveam/src/fixture.lisp
@@ -0,0 +1,82 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.fiveam)
+
+;;;; ** Fixtures
+
+;;;; When running tests we often need to setup some kind of context
+;;;; (create dummy db connections, simulate an http request,
+;;;; etc.). Fixtures provide a way to conviently hide this context
+;;;; into a macro and allow the test to focus on testing.
+
+;;;; NB: A FiveAM fixture is nothing more than a macro. Since the term
+;;;; 'fixture' is so common in testing frameworks we've provided a
+;;;; wrapper around defmacro for this purpose.
+
+(defvar *fixture*
+  (make-hash-table :test 'eql)
+  "Lookup table mapping fixture names to fixture
+  objects.")
+
+(defun get-fixture (key &optional default)
+  (gethash key *fixture* default))
+
+(defun (setf get-fixture) (value key)
+  (setf (gethash key *fixture*) value))
+
+(defun rem-fixture (key)
+  (remhash key *fixture*))
+
+(defmacro def-fixture (name (&rest args) &body body)
+  "Defines a fixture named NAME. A fixture is very much like a
+macro but is used only for simple templating. A fixture created
+with DEF-FIXTURE is a macro which can use the special macrolet
+&BODY to specify where the body should go.
+
+See Also: WITH-FIXTURE
+"
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+     (setf (get-fixture ',name) (cons ',args ',body))
+     ',name))
+
+(defmacro with-fixture (fixture-name (&rest args) &body body)
+  "Insert BODY into the fixture named FIXTURE-NAME.
+
+See Also: DEF-FIXTURE"
+  (assert (get-fixture fixture-name)
+          (fixture-name)
+          "Unknown fixture ~S." fixture-name)
+  (destructuring-bind ((&rest largs) &rest lbody)
+      (get-fixture fixture-name)
+    `(macrolet ((&body () '(progn ,@body)))
+       (funcall (lambda (,@largs) ,@lbody) ,@args))))
+
+;; Copyright (c) 2002-2003, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;;
+;;  - 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.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;;
+;; 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.
diff --git a/third_party/lisp/fiveam/src/package.lisp b/third_party/lisp/fiveam/src/package.lisp
new file mode 100644
index 000000000000..3279a9a4f7fc
--- /dev/null
+++ b/third_party/lisp/fiveam/src/package.lisp
@@ -0,0 +1,139 @@
+;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
+
+;;;; * Introduction
+
+;;;; FiveAM is a testing framework. It takes care of all the boring
+;;;; bookkeeping associated with managing a test framework allowing
+;;;; the developer to focus on writing tests and code.
+
+;;;; FiveAM was designed with the following premises:
+
+;;;; - Defining tests should be about writing tests, not
+;;;; infrastructure. The developer should be able to focus on what
+;;;; they're testing, not the testing framework.
+
+;;;; - Interactive testing is the norm. Common Lisp is an interactive
+;;;; development environment, the testing environment should allow the
+;;;; developer to quickly and easily redefine, change, remove and run
+;;;; tests.
+
+(defpackage :it.bese.fiveam
+  (:use :common-lisp :alexandria)
+  (:nicknames :5am :fiveam)
+  #+sb-package-locks
+  (:lock t)
+  (:export
+   ;; creating tests and test-suites
+   #:make-suite
+   #:def-suite
+   #:def-suite*
+   #:in-suite
+   #:in-suite*
+   #:test
+   #:def-test
+   #:get-test
+   #:rem-test
+   #:test-names
+   #:*default-test-compilation-time*
+   ;; fixtures
+   #:def-fixture
+   #:with-fixture
+   #:get-fixture
+   #:rem-fixture
+   ;; running checks
+   #:is
+   #:is-every
+   #:is-true
+   #:is-false
+   #:signals
+   #:finishes
+   #:skip
+   #:pass
+   #:fail
+   #:*test-dribble*
+   #:for-all
+   #:*num-trials*
+   #:*max-trials*
+   #:gen-integer
+   #:gen-float
+   #:gen-character
+   #:gen-string
+   #:gen-list
+   #:gen-tree
+   #:gen-buffer
+   #:gen-one-element
+   ;; running tests
+   #:run
+   #:run-all-tests
+   #:explain
+   #:explain!
+   #:run!
+   #:debug!
+   #:!
+   #:!!
+   #:!!!
+   #:*run-test-when-defined*
+   #:*debug-on-error*
+   #:*debug-on-failure*
+   #:*on-error*
+   #:*on-failure*
+   #:*verbose-failures*
+   #:*print-names*
+   #:results-status))
+
+;;;; You can use #+5am to put your test-defining code inline with your
+;;;; other code - and not require people to have fiveam to run your
+;;;; package.
+
+(pushnew :5am *features*)
+
+;;;;@include "check.lisp"
+
+;;;;@include "random.lisp"
+
+;;;;@include "fixture.lisp"
+
+;;;;@include "test.lisp"
+
+;;;;@include "suite.lisp"
+
+;;;;@include "run.lisp"
+
+;;;;@include "explain.lisp"
+
+;;;; * Colophon
+
+;;;; This documentaion was written by Edward Marco Baringer
+;;;; <mb@bese.it> and generated by qbook.
+
+;;;; ** COPYRIGHT
+
+;;;; Copyright (c) 2002-2003, Edward Marco Baringer
+;;;; All rights reserved.
+
+;;;; Redistribution and use in source and binary forms, with or without
+;;;; modification, are permitted provided that the following conditions are
+;;;; met:
+
+;;;;  - Redistributions of source code must retain the above copyright
+;;;;    notice, this list of conditions and the following disclaimer.
+
+;;;;  - 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.
+
+;;;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;;;    of its contributors may be used to endorse or promote products
+;;;;    derived from this software without specific prior written permission.
+
+;;;; 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
diff --git a/third_party/lisp/fiveam/src/random.lisp b/third_party/lisp/fiveam/src/random.lisp
new file mode 100644
index 000000000000..49e14bc8a880
--- /dev/null
+++ b/third_party/lisp/fiveam/src/random.lisp
@@ -0,0 +1,265 @@
+;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
+
+(in-package :it.bese.fiveam)
+
+;;;; ** Random (QuickCheck-ish) testing
+
+;;;; FiveAM provides the ability to automatically generate a
+;;;; collection of random input data for a specific test and run a
+;;;; test multiple times.
+
+;;;; Specification testing is done through the FOR-ALL macro. This
+;;;; macro will bind variables to random data and run a test body a
+;;;; certain number of times. Should the test body ever signal a
+;;;; failure we stop running and report what values of the variables
+;;;; caused the code to fail.
+
+;;;; The generation of the random data is done using "generator
+;;;; functions" (see below for details). A generator function is a
+;;;; function which creates, based on user supplied parameters, a
+;;;; function which returns random data. In order to facilitate
+;;;; generating good random data the FOR-ALL macro also supports guard
+;;;; conditions and creating one random input based on the values of
+;;;; another (see the FOR-ALL macro for details).
+
+;;;; *** Public Interface to the Random Tester
+
+(defparameter *num-trials* 100
+  "Number of times we attempt to run the body of the FOR-ALL test.")
+
+(defparameter *max-trials* 10000
+  "Number of total times we attempt to run the body of the
+  FOR-ALL test including when the body is skipped due to failed
+  guard conditions.
+
+Since we have guard conditions we may get into infinite loops
+where the test code is never run due to the guards never
+returning true. This second run limit prevents that.")
+
+(defmacro for-all (bindings &body body)
+  "Bind BINDINGS to random variables and test BODY *num-trials* times.
+
+BINDINGS is a list of binding forms, each element is a list
+of (BINDING VALUE &optional GUARD). Value, which is evaluated
+once when the for-all is evaluated, must return a generator which
+be called each time BODY is evaluated. BINDING is either a symbol
+or a list which will be passed to destructuring-bind. GUARD is a
+form which, if present, stops BODY from executing when IT returns
+NIL. The GUARDS are evaluated after all the random data has been
+generated and they can refer to the current value of any
+binding. NB: Generator forms, unlike guard forms, can not contain
+references to the bound variables.
+
+Examples:
+
+  (for-all ((a (gen-integer)))
+    (is (integerp a)))
+
+  (for-all ((a (gen-integer) (plusp a)))
+    (is (integerp a))
+    (is (plusp a)))
+
+  (for-all ((less (gen-integer))
+            (more (gen-integer) (< less more)))
+    (is (<= less more)))
+
+  (for-all (((a b) (gen-two-integers)))
+    (is (integerp a))
+    (is (integerp b)))"
+  (with-gensyms (test-lambda-args)
+    `(perform-random-testing
+      (list ,@(mapcar #'second bindings))
+      (lambda (,test-lambda-args)
+        (destructuring-bind ,(mapcar #'first bindings)
+            ,test-lambda-args
+          (if (and ,@(delete-if #'null (mapcar #'third bindings)))
+              (progn ,@body)
+              (throw 'run-once
+                (list :guard-conditions-failed))))))))
+
+;;;; *** Implementation
+
+;;;; We could just make FOR-ALL a monster macro, but having FOR-ALL be
+;;;; a preproccessor for the perform-random-testing function is
+;;;; actually much easier.
+
+(defun perform-random-testing (generators body)
+  (loop
+     with random-state = *random-state*
+     with total-counter = *max-trials*
+     with counter = *num-trials*
+     with run-at-least-once = nil
+     until (or (zerop total-counter)
+               (zerop counter))
+     do (let ((result (perform-random-testing/run-once generators body)))
+          (ecase (first result)
+            (:pass
+             (decf counter)
+             (decf total-counter)
+             (setf run-at-least-once t))
+            (:no-tests
+             (add-result 'for-all-test-no-tests
+                         :reason "No tests"
+                         :random-state random-state)
+             (return-from perform-random-testing nil))
+            (:guard-conditions-failed
+             (decf total-counter))
+            (:fail
+             (add-result 'for-all-test-failed
+                         :reason "Found failing test data"
+                         :random-state random-state
+                         :failure-values (second result)
+                         :result-list (third result))
+             (return-from perform-random-testing nil))))
+     finally (if run-at-least-once
+                 (add-result 'for-all-test-passed)
+                 (add-result 'for-all-test-never-run
+                             :reason "Guard conditions never passed"))))
+
+(defun perform-random-testing/run-once (generators body)
+  (catch 'run-once
+    (bind-run-state ((result-list '()))
+      (let ((values (mapcar #'funcall generators)))
+        (funcall body values)
+        (cond
+          ((null result-list)
+           (throw 'run-once (list :no-tests)))
+          ((every #'test-passed-p result-list)
+           (throw 'run-once (list :pass)))
+          ((notevery #'test-passed-p result-list)
+           (throw 'run-once (list :fail values result-list))))))))
+
+(defclass for-all-test-result ()
+  ((random-state :initarg :random-state)))
+
+(defclass for-all-test-passed (test-passed for-all-test-result)
+  ())
+
+(defclass for-all-test-failed (test-failure for-all-test-result)
+  ((failure-values :initarg :failure-values)
+   (result-list :initarg :result-list)))
+
+(defgeneric for-all-test-failed-p (object)
+  (:method ((object for-all-test-failed)) t)
+  (:method ((object t)) nil))
+
+(defmethod reason ((result for-all-test-failed))
+  (format nil "Falsifiable with ~S" (slot-value result 'failure-values)))
+
+(defclass for-all-test-no-tests (test-failure for-all-test-result)
+  ())
+
+(defclass for-all-test-never-run (test-failure for-all-test-result)
+  ())
+
+;;;; *** Generators
+
+;;;; Since this is random testing we need some way of creating random
+;;;; data to feed to our code. Generators are regular functions which
+;;;; create this random data.
+
+;;;; We provide a set of built-in generators.
+
+(defun gen-integer (&key (max (1+ most-positive-fixnum))
+                         (min (1- most-negative-fixnum)))
+  "Returns a generator which produces random integers greater
+than or equal to MIN and less than or equal to MAX."
+  (lambda ()
+    (+ min (random (1+ (- max min))))))
+
+(defun gen-float (&key bound (type 'short-float))
+  "Returns a generator which produces floats of type TYPE. BOUND,
+if specified, constrains the results to be in the range (-BOUND,
+BOUND)."
+  (lambda ()
+    (let* ((most-negative (ecase type
+                            (short-float most-negative-short-float)
+                            (single-float most-negative-single-float)
+                            (double-float most-negative-double-float)
+                            (long-float most-negative-long-float)))
+           (most-positive (ecase type
+                            (short-float most-positive-short-float)
+                            (single-float most-positive-single-float)
+                            (double-float most-positive-double-float)
+                            (long-float most-positive-long-float)))
+           (bound (or bound (max most-positive (- most-negative)))))
+      (coerce
+       (ecase (random 2)
+         (0 ;; generate a positive number
+          (random (min most-positive bound)))
+         (1 ;; generate a negative number
+          (- (random (min (- most-negative) bound)))))
+       type))))
+
+(defun gen-character (&key (code-limit char-code-limit)
+                           (code (gen-integer :min 0 :max (1- code-limit)))
+                           (alphanumericp nil))
+  "Returns a generator of characters.
+
+CODE must be a generator of random integers. ALPHANUMERICP, if
+non-NIL, limits the returned chars to those which pass
+alphanumericp."
+  (lambda ()
+    (loop
+       for count upfrom 0
+       for char = (code-char (funcall code))
+       until (and char
+                  (or (not alphanumericp)
+                      (alphanumericp char)))
+       when (= 1000 count)
+       do (error "After 1000 iterations ~S has still not generated ~:[a valid~;an alphanumeric~] character :(."
+                 code alphanumericp)
+       finally (return char))))
+
+(defun gen-string (&key (length (gen-integer :min 0 :max 80))
+                        (elements (gen-character))
+                        (element-type 'character))
+  "Returns a generator which produces random strings. LENGTH must
+be a generator which produces integers, ELEMENTS must be a
+generator which produces characters of type ELEMENT-TYPE."
+  (lambda ()
+    (loop
+       with length = (funcall length)
+       with string = (make-string length :element-type element-type)
+       for index below length
+       do (setf (aref string index) (funcall elements))
+       finally (return string))))
+
+(defun gen-list (&key (length (gen-integer :min 0 :max 10))
+                      (elements (gen-integer :min -10 :max 10)))
+  "Returns a generator which produces random lists. LENGTH must be
+an integer generator and ELEMENTS must be a generator which
+produces objects."
+  (lambda ()
+    (loop
+       repeat (funcall length)
+       collect (funcall elements))))
+
+(defun gen-tree (&key (size 20)
+                      (elements (gen-integer :min -10 :max 10)))
+  "Returns a generator which produces random trees. SIZE controls
+the approximate size of the tree, but don't try anything above
+ 30, you have been warned. ELEMENTS must be a generator which
+will produce the elements."
+  (labels ((rec (&optional (current-depth 0))
+             (let ((key (random (+ 3 (- size current-depth)))))
+               (cond ((> key 2)
+                      (list (rec (+ current-depth 1))
+                            (rec (+ current-depth 1))))
+                     (t (funcall elements))))))
+    (lambda ()
+      (rec))))
+
+(defun gen-buffer (&key (length (gen-integer :min 0 :max 50))
+                        (element-type '(unsigned-byte 8))
+                        (elements (gen-integer :min 0 :max (1- (expt 2 8)))))
+  (lambda ()
+    (let ((buffer (make-array (funcall length) :element-type element-type)))
+      (map-into buffer elements))))
+
+(defun gen-one-element (&rest elements)
+  (lambda ()
+    (nth (random (length elements)) elements)))
+
+;;;; The trivial always-produce-the-same-thing generator is done using
+;;;; cl:constantly.
diff --git a/third_party/lisp/fiveam/src/run.lisp b/third_party/lisp/fiveam/src/run.lisp
new file mode 100644
index 000000000000..89c522351504
--- /dev/null
+++ b/third_party/lisp/fiveam/src/run.lisp
@@ -0,0 +1,385 @@
+;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
+
+(in-package :it.bese.fiveam)
+
+;;;; * Running Tests
+
+;;;; Once the programmer has defined what the tests are these need to
+;;;; be run and the expected effects should be compared with the
+;;;; actual effects. FiveAM provides the function RUN for this
+;;;; purpose, RUN executes a number of tests and collects the results
+;;;; of each individual check into a list which is then
+;;;; returned. There are three types of test results: passed, failed
+;;;; and skipped, these are represented by TEST-RESULT objects.
+
+;;;; Generally running a test will return normally, but there are two
+;;;; exceptional situations which can occur:
+
+;;;; - An exception is signaled while running the test. If the
+;;;;   variable *on-error* is :DEBUG than FiveAM will enter the
+;;;;   debugger, otherwise a test failure (of type
+;;;;   unexpected-test-failure) is returned. When entering the
+;;;;   debugger two restarts are made available, one simply reruns the
+;;;;   current test and another signals a test-failure and continues
+;;;;   with the remaining tests.
+
+;;;; - A circular dependency is detected. An error is signaled and a
+;;;;   restart is made available which signals a test-skipped and
+;;;;   continues with the remaining tests. This restart also sets the
+;;;;   dependency status of the test to nil, so any tests which depend
+;;;;   on this one (even if the dependency is not circular) will be
+;;;;   skipped.
+
+;;;; The functions RUN!, !, !! and !!! are convenient wrappers around
+;;;; RUN and EXPLAIN.
+
+(deftype on-problem-action ()
+  '(member :debug :backtrace nil))
+
+(declaim (type on-problem-action *on-error* *on-failure*))
+
+(defvar *on-error* nil
+  "The action to perform on error:
+- :DEBUG if we should drop into the debugger
+- :BACKTRACE to print a backtrace
+- NIL to simply continue")
+
+(defvar *on-failure* nil
+  "The action to perform on check failure:
+- :DEBUG if we should drop into the debugger
+- :BACKTRACE to print a backtrace
+- NIL to simply continue")
+
+(defvar *debug-on-error* nil
+  "T if we should drop into the debugger on error, NIL otherwise.
+OBSOLETE: superseded by *ON-ERROR*")
+
+(defvar *debug-on-failure* nil
+  "T if we should drop into the debugger on a failing check, NIL otherwise.
+OBSOLETE: superseded by *ON-FAILURE*")
+
+(defparameter *print-names* t
+  "T if we should print test running progress, NIL otherwise.")
+
+(defparameter *test-dribble-indent* (make-array 0
+                                        :element-type 'character
+                                        :fill-pointer 0
+                                        :adjustable t)
+  "Used to indent tests and test suites in their parent suite")
+
+(defun import-testing-symbols (package-designator)
+  (import '(5am::is 5am::is-true 5am::is-false 5am::signals 5am::finishes)
+          package-designator))
+
+(defparameter *run-queue* '()
+  "List of test waiting to be run.")
+
+(define-condition circular-dependency (error)
+  ((test-case :initarg :test-case))
+  (:report (lambda (cd stream)
+             (format stream "A circular dependency wes detected in ~S." (slot-value cd 'test-case))))
+  (:documentation "Condition signaled when a circular dependency
+between test-cases has been detected."))
+
+(defgeneric run-resolving-dependencies (test)
+  (:documentation "Given a dependency spec determine if the spec
+is satisfied or not, this will generally involve running other
+tests. If the dependency spec can be satisfied the test is also
+run."))
+
+(defmethod run-resolving-dependencies ((test test-case))
+  "Return true if this test, and its dependencies, are satisfied,
+  NIL otherwise."
+  (case (status test)
+    (:unknown
+     (setf (status test) :resolving)
+     (if (or (not (depends-on test))
+             (eql t (resolve-dependencies (depends-on test))))
+         (progn
+           (run-test-lambda test)
+           (status test))
+         (with-run-state (result-list)
+           (unless (eql :circular (status test))
+             (push (make-instance 'test-skipped
+                                  :test-case test
+                                  :reason "Dependencies not satisfied")
+                   result-list)
+             (setf (status test) :depends-not-satisfied)))))
+    (:resolving
+     (restart-case
+         (error 'circular-dependency :test-case test)
+       (skip ()
+         :report (lambda (s)
+                   (format s "Skip the test ~S and all its dependencies." (name test)))
+         (with-run-state (result-list)
+           (push (make-instance 'test-skipped :reason "Circular dependencies" :test-case test)
+                 result-list))
+         (setf (status test) :circular))))
+    (t (status test))))
+
+(defgeneric resolve-dependencies (depends-on))
+
+(defmethod resolve-dependencies ((depends-on symbol))
+  "A test which depends on a symbol is interpreted as `(AND
+  ,DEPENDS-ON)."
+  (run-resolving-dependencies (get-test depends-on)))
+
+(defmethod resolve-dependencies ((depends-on list))
+  "Return true if the dependency spec DEPENDS-ON is satisfied,
+  nil otherwise."
+  (if (null depends-on)
+      t
+      (flet ((satisfies-depends-p (test)
+               (funcall test (lambda (dep)
+                               (eql t (resolve-dependencies dep)))
+                        (cdr depends-on))))
+        (ecase (car depends-on)
+          (and (satisfies-depends-p #'every))
+          (or  (satisfies-depends-p #'some))
+          (not (satisfies-depends-p #'notany))
+          (:before (every #'(lambda (dep)
+                              (let ((status (status (get-test dep))))
+                                (if (eql :unknown status)
+                                    (run-resolving-dependencies (get-test dep))
+                                    status)))
+                          (cdr depends-on)))))))
+
+(defun results-status (result-list)
+  "Given a list of test results (generated while running a test)
+  return true if no results are of type TEST-FAILURE.  Returns second
+  and third values, which are the set of failed tests and skipped
+  tests respectively."
+  (let ((failed-tests
+          (remove-if-not #'test-failure-p result-list))
+        (skipped-tests
+          (remove-if-not #'test-skipped-p result-list)))
+    (values (null failed-tests)
+            failed-tests
+            skipped-tests)))
+
+(defun return-result-list (test-lambda)
+  "Run the test function TEST-LAMBDA and return a list of all
+  test results generated, does not modify the special environment
+  variable RESULT-LIST."
+  (bind-run-state ((result-list '()))
+    (funcall test-lambda)
+    result-list))
+
+(defgeneric run-test-lambda (test))
+
+(defmethod run-test-lambda ((test test-case))
+  (with-run-state (result-list)
+    (bind-run-state ((current-test test))
+      (labels ((abort-test (e &optional (reason (format nil "Unexpected Error: ~S~%~A." e e)))
+                 (add-result 'unexpected-test-failure
+                             :test-expr nil
+                             :test-case test
+                             :reason reason
+                             :condition e))
+               (run-it ()
+                 (let ((result-list '()))
+                   (declare (special result-list))
+                   (handler-bind ((check-failure (lambda (e)
+                                                   (declare (ignore e))
+                                                   (cond
+                                                     ((eql *on-failure* :debug)
+                                                      nil)
+                                                     (t
+                                                      (when (eql *on-failure* :backtrace)
+                                                        (trivial-backtrace:print-backtrace-to-stream
+                                                         *test-dribble*))
+                                                      (invoke-restart
+                                                       (find-restart 'ignore-failure))))))
+                                  (error (lambda (e)
+                                           (unless (or (eql *on-error* :debug)
+                                                       (typep e 'check-failure))
+                                             (when (eql *on-error* :backtrace)
+                                               (trivial-backtrace:print-backtrace-to-stream
+                                                *test-dribble*))
+                                             (abort-test e)
+                                             (return-from run-it result-list)))))
+                     (restart-case
+                         (handler-case
+                             (let ((*readtable* (copy-readtable))
+                                   (*package* (runtime-package test)))
+                               (when *print-names*
+                                   (format *test-dribble* "~%~ARunning test ~A " *test-dribble-indent* (name test)))
+                               (if (collect-profiling-info test)
+                                   ;; Timing info doesn't get collected ATM, we need a portable library
+                                   ;; (setf (profiling-info test) (collect-timing (test-lambda test)))
+                                   (funcall (test-lambda test))
+                                   (funcall (test-lambda test))))
+                           (storage-condition (e)
+                             ;; heap-exhausted/constrol-stack-exhausted
+                             ;; handler-case unwinds the stack (unlike handler-bind)
+                             (abort-test e (format nil "STORAGE-CONDITION: aborted for safety. ~S~%~A." e e))
+                             (return-from run-it result-list)))
+                       (retest ()
+                         :report (lambda (stream)
+                                   (format stream "~@<Rerun the test ~S~@:>" test))
+                         (return-from run-it (run-it)))
+                       (ignore ()
+                         :report (lambda (stream)
+                                   (format stream "~@<Signal an exceptional test failure and abort the test ~S.~@:>" test))
+                         (abort-test (make-instance 'test-failure :test-case test
+                                                                  :reason "Failure restart."))))
+                     result-list))))
+        (let ((results (run-it)))
+          (setf (status test) (results-status results)
+                result-list (nconc result-list results)))))))
+
+(defgeneric %run (test-spec)
+  (:documentation "Internal method for running a test. Does not
+  update the status of the tests nor the special variables !,
+  !!, !!!"))
+
+(defmethod %run ((test test-case))
+  (run-resolving-dependencies test))
+
+(defmethod %run ((tests list))
+  (mapc #'%run tests))
+
+(defmethod %run ((suite test-suite))
+  (when *print-names*
+    (format *test-dribble* "~%~ARunning test suite ~A" *test-dribble-indent* (name suite)))
+  (let ((suite-results '()))
+    (flet ((run-tests ()
+             (loop
+                for test being the hash-values of (tests suite)
+                do (%run test))))
+      (vector-push-extend #\space *test-dribble-indent*)
+      (unwind-protect
+           (bind-run-state ((result-list '()))
+             (unwind-protect
+                  (if (collect-profiling-info suite)
+                      ;; Timing info doesn't get collected ATM, we need a portable library
+                      ;; (setf (profiling-info suite) (collect-timing #'run-tests))
+                      (run-tests)
+                      (run-tests)))
+             (setf suite-results result-list
+                   (status suite) (every #'test-passed-p suite-results)))
+        (vector-pop *test-dribble-indent*)
+        (with-run-state (result-list)
+          (setf result-list (nconc result-list suite-results)))))))
+
+(defmethod %run ((test-name symbol))
+  (when-let (test (get-test test-name))
+    (%run test)))
+
+(defvar *initial-!* (lambda () (format t "Haven't run that many tests yet.~%")))
+
+(defvar *!* *initial-!*)
+(defvar *!!* *initial-!*)
+(defvar *!!!* *initial-!*)
+
+;;;; ** Public entry points
+
+(defun run! (&optional (test-spec *suite*)
+             &key ((:print-names *print-names*) *print-names*))
+  "Equivalent to (explain! (run TEST-SPEC))."
+  (explain! (run test-spec)))
+
+(defun explain! (result-list)
+  "Explain the results of RESULT-LIST using a
+detailed-text-explainer with output going to *test-dribble*.
+Return a boolean indicating whether no tests failed."
+  (explain (make-instance 'detailed-text-explainer) result-list *test-dribble*)
+  (results-status result-list))
+
+(defun debug! (&optional (test-spec *suite*))
+  "Calls (run! test-spec) but enters the debugger if any kind of error happens."
+  (let ((*on-error* :debug)
+        (*on-failure* :debug))
+    (run! test-spec)))
+
+(defun run (test-spec &key ((:print-names *print-names*) *print-names*))
+  "Run the test specified by TEST-SPEC.
+
+TEST-SPEC can be either a symbol naming a test or test suite, or
+a testable-object object. This function changes the operations
+performed by the !, !! and !!! functions."
+  (psetf *!* (lambda ()
+               (loop :for test :being :the :hash-keys :of *test*
+                     :do (setf (status (get-test test)) :unknown))
+               (bind-run-state ((result-list '()))
+                 (with-simple-restart (explain "Ignore the rest of the tests and explain current results")
+                   (%run test-spec))
+                 result-list))
+         *!!* *!*
+         *!!!* *!!*)
+  (let ((*on-error*
+          (or *on-error* (cond
+                           (*debug-on-error*
+                            (format *test-dribble* "*DEBUG-ON-ERROR* is obsolete. Use *ON-ERROR*.")
+                            :debug)
+                           (t nil))))
+        (*on-failure*
+          (or *on-failure* (cond
+                           (*debug-on-failure*
+                            (format *test-dribble* "*DEBUG-ON-FAILURE* is obsolete. Use *ON-FAILURE*.")
+                            :debug)
+                           (t nil)))))
+    (funcall *!*)))
+
+(defun ! ()
+  "Rerun the most recently run test and explain the results."
+  (explain! (funcall *!*)))
+
+(defun !! ()
+  "Rerun the second most recently run test and explain the results."
+  (explain! (funcall *!!*)))
+
+(defun !!! ()
+  "Rerun the third most recently run test and explain the results."
+  (explain! (funcall *!!!*)))
+
+(defun run-all-tests (&key (summary :end))
+  "Runs all defined test suites, T if all tests passed and NIL otherwise.
+SUMMARY can be :END to print a summary at the end, :SUITE to print it
+after each suite or NIL to skip explanations."
+  (check-type summary (member nil :suite :end))
+  (loop :for suite :in (cons 'nil (sort (copy-list *toplevel-suites*) #'string<=))
+        :for results := (if (suite-emptyp suite) nil (run suite))
+        :when (consp results)
+          :collect results :into all-results
+        :do (cond
+              ((not (eql summary :suite))
+               nil)
+              (results
+               (explain! results))
+              (suite
+               (format *test-dribble* "Suite ~A is empty~%" suite)))
+        :finally (progn
+                   (when (eql summary :end)
+                     (explain! (alexandria:flatten all-results)))
+                   (return (every #'results-status all-results)))))
+
+;; Copyright (c) 2002-2003, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;;
+;;  - 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.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;;
+;; 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.
diff --git a/third_party/lisp/fiveam/src/style.css b/third_party/lisp/fiveam/src/style.css
new file mode 100644
index 000000000000..4a1e6010dce5
--- /dev/null
+++ b/third_party/lisp/fiveam/src/style.css
@@ -0,0 +1,64 @@
+body {
+  background-color: #FFFFFF;
+  color: #000000;
+  padding: 0px; margin: 0px;
+}
+
+.qbook { width: 600px; background-color: #FFFFFF; margin: 0px; 
+         border-left: 3em solid #660000; padding: 3px; }
+
+h1 { text-align: center; margin: 0px;
+     color: #333333; 
+     border-bottom: 0.3em solid #660000; 
+}
+
+p { padding-left: 1em; }
+
+h2 { border-bottom: 0.2em solid #000000; font-family: verdana; }
+
+h3 { border-bottom: 0.1em solid #000000; }
+
+pre.code {
+	background-color: #eeeeee;
+	border: solid 1px #d0d0d0;
+        overflow: auto;
+}
+
+pre.code * .paren { color: #666666; } 
+
+pre.code a:active  { color: #000000; }
+pre.code a:link    { color: #000000; }
+pre.code a:visited { color: #000000; }
+
+pre.code .first-line { font-weight: bold; }
+
+div.contents { font-family: verdana; }
+
+div.contents a:active  { color: #000000; }
+div.contents a:link    { color: #000000; }
+div.contents a:visited { color: #000000; }
+
+div.contents div.contents-heading-1 { padding-left: 0.5em; font-weight: bold; }
+div.contents div.contents-heading-1 a:active  { color: #660000; }
+div.contents div.contents-heading-1 a:link    { color: #660000; }
+div.contents div.contents-heading-1 a:visited { color: #660000; }
+
+div.contents div.contents-heading-2 { padding-left: 1.0em; }
+div.contents div.contents-heading-2 a:active  { color: #660000; }
+div.contents div.contents-heading-2 a:link    { color: #660000; }
+div.contents div.contents-heading-2 a:visited { color: #660000; }
+
+div.contents div.contents-heading-3 { padding-left: 1.5em; }
+div.contents div.contents-heading-3 a:active  { color: #660000; }
+div.contents div.contents-heading-3 a:link    { color: #660000; }
+div.contents div.contents-heading-3 a:visited { color: #660000; }
+
+div.contents div.contents-heading-4 { padding-left: 2em; }
+div.contents div.contents-heading-4 a:active  { color: #660000; }
+div.contents div.contents-heading-4 a:link    { color: #660000; }
+div.contents div.contents-heading-4 a:visited { color: #660000; }
+
+div.contents div.contents-heading-5 { padding-left: 2.5em; }
+div.contents div.contents-heading-5 a:active  { color: #660000; }
+div.contents div.contents-heading-5 a:link    { color: #660000; }
+div.contents div.contents-heading-5 a:visited { color: #660000; }
diff --git a/third_party/lisp/fiveam/src/suite.lisp b/third_party/lisp/fiveam/src/suite.lisp
new file mode 100644
index 000000000000..8497a9d12ddc
--- /dev/null
+++ b/third_party/lisp/fiveam/src/suite.lisp
@@ -0,0 +1,140 @@
+;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
+
+(in-package :it.bese.fiveam)
+
+;;;; * Test Suites
+
+;;;; Test suites allow us to collect multiple tests into a single
+;;;; object and run them all using asingle name. Test suites do not
+;;;; affect the way test are run nor the way the results are handled,
+;;;; they are simply a test organizing group.
+
+;;;; Test suites can contain both tests and other test suites. Running
+;;;; a test suite causes all of its tests and test suites to be
+;;;; run. Suites do not affect test dependencies, running a test suite
+;;;; can cause tests which are not in the suite to be run.
+
+;;;; ** Current Suite
+
+(defvar *suite* nil
+  "The current test suite object")
+(net.didierverna.asdf-flv:set-file-local-variable *suite*)
+
+;;;; ** Creating Suits
+
+;; Suites that have no parent suites.
+(defvar *toplevel-suites* nil)
+
+(defgeneric suite-emptyp (suite)
+  (:method ((suite symbol))
+    (suite-emptyp (get-test suite)))
+  (:method ((suite test-suite))
+    (= 0 (hash-table-count (tests suite)))))
+
+(defmacro def-suite (name &key description in)
+  "Define a new test-suite named NAME.
+
+IN (a symbol), if provided, causes this suite te be nested in the
+suite named by IN. NB: This macro is built on top of make-suite,
+as such it, like make-suite, will overrwrite any existing suite
+named NAME."
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+     (make-suite ',name
+                 ,@(when description `(:description ,description))
+                 ,@(when in `(:in ',in)))
+     ',name))
+
+(defmacro def-suite* (name &rest def-suite-args)
+  `(progn
+     (def-suite ,name ,@def-suite-args)
+     (in-suite ,name)))
+
+(defun make-suite (name &key description ((:in parent-suite)))
+  "Create a new test suite object.
+
+Overrides any existing suite named NAME."
+  (let ((suite (make-instance 'test-suite :name name)))
+    (when description
+      (setf (description suite) description))
+    (when (and name
+               (null (name *suite*))
+               (null parent-suite))
+      (pushnew name *toplevel-suites*))
+    (loop for i in (ensure-list parent-suite)
+          for in-suite = (get-test i)
+          do (progn
+               (when (null in-suite)
+                 (cerror "Create a new suite named ~A." "Unknown suite ~A." i)
+                 (setf (get-test in-suite) (make-suite i)
+                       in-suite (get-test in-suite)))
+               (setf (gethash name (tests in-suite)) suite)))
+    (setf (get-test name) suite)
+    suite))
+
+(eval-when (:load-toplevel :execute)
+  (setf *suite*
+        (setf (get-test 'nil)
+              (make-suite 'nil :description "Global Suite"))))
+
+(defun list-all-suites ()
+  "Returns an unordered LIST of all suites."
+  (hash-table-values *suite*))
+
+;;;; ** Managing the Current Suite
+
+(defmacro in-suite (suite-name)
+  "Set the *suite* special variable so that all tests defined
+after the execution of this form are, unless specified otherwise,
+in the test-suite named SUITE-NAME.
+
+See also: DEF-SUITE *SUITE*"
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+     (%in-suite ,suite-name)))
+
+(defmacro in-suite* (suite-name &key in)
+  "Just like in-suite, but silently creates missing suites."
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+     (%in-suite ,suite-name :in ,in :fail-on-error nil)))
+
+(defmacro %in-suite (suite-name &key (fail-on-error t) in)
+  (with-gensyms (suite)
+    `(progn
+       (if-let (,suite (get-test ',suite-name))
+         (setf *suite* ,suite)
+         (progn
+           (when ,fail-on-error
+             (cerror "Create a new suite named ~A."
+                     "Unknown suite ~A." ',suite-name))
+           (setf (get-test ',suite-name) (make-suite ',suite-name :in ',in)
+                 *suite* (get-test ',suite-name))))
+       ',suite-name)))
+
+;; Copyright (c) 2002-2003, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;;
+;;  - 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.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;;
+;; 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
diff --git a/third_party/lisp/fiveam/src/test.lisp b/third_party/lisp/fiveam/src/test.lisp
new file mode 100644
index 000000000000..4a6f2fee9a0a
--- /dev/null
+++ b/third_party/lisp/fiveam/src/test.lisp
@@ -0,0 +1,167 @@
+;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
+
+(in-package :it.bese.fiveam)
+
+;;;; * Tests
+
+;;;; While executing checks and collecting the results is the core job
+;;;; of a testing framework it is also important to be able to
+;;;; organize checks into groups, fiveam provides two mechanisms for
+;;;; organizing checks: tests and test suites. A test is a named
+;;;; collection of checks which can be run and a test suite is a named
+;;;; collection of tests and test suites.
+
+(declaim (special *suite*))
+
+(defvar *test*
+  (make-hash-table :test 'eql)
+  "Lookup table mapping test (and test suite)
+  names to objects.")
+
+(defun get-test (key &optional default)
+  (gethash key *test* default))
+
+(defun (setf get-test) (value key)
+  (setf (gethash key *test*) value))
+
+(defun rem-test (key)
+  (remhash key *test*))
+
+(defun test-names ()
+  (hash-table-keys *test*))
+
+(defmacro test (name &body body)
+  "Create a test named NAME. If NAME is a list it must be of the
+form:
+
+  (name &key depends-on suite fixture compile-at profile)
+
+NAME is the symbol which names the test.
+
+DEPENDS-ON is a list of the form:
+
+ (AND . test-names) - This test is run only if all of the tests
+ in TEST-NAMES have passed, otherwise a single test-skipped
+ result is generated.
+
+ (OR . test-names) - If any of TEST-NAMES has passed this test is
+ run, otherwise a test-skipped result is generated.
+
+ (NOT test-name) - This is test is run only if TEST-NAME failed.
+
+AND, OR and NOT can be combined to produce complex dependencies.
+
+If DEPENDS-ON is a symbol it is interpreted as `(AND
+,depends-on), this is accomadate the common case of one test
+depending on another.
+
+FIXTURE specifies a fixture to wrap the body in.
+
+If PROFILE is T profiling information will be collected as well."
+  (destructuring-bind (name &rest args)
+      (ensure-list name)
+    `(def-test ,name (,@args) ,@body)))
+
+(defvar *default-test-compilation-time* :definition-time)
+
+(defmacro def-test (name (&key depends-on (suite '*suite* suite-p) fixture
+                            (compile-at *default-test-compilation-time*) profile)
+                    &body body)
+  "Create a test named NAME.
+
+NAME is the symbol which names the test.
+
+DEPENDS-ON is a list of the form:
+
+ (AND . test-names) - This test is run only if all of the tests
+ in TEST-NAMES have passed, otherwise a single test-skipped
+ result is generated.
+
+ (OR . test-names) - If any of TEST-NAMES has passed this test is
+ run, otherwise a test-skipped result is generated.
+
+ (NOT test-name) - This is test is run only if TEST-NAME failed.
+
+AND, OR and NOT can be combined to produce complex dependencies.
+
+If DEPENDS-ON is a symbol it is interpreted as `(AND
+,depends-on), this is accomadate the common case of one test
+depending on another.
+
+FIXTURE specifies a fixture to wrap the body in.
+
+If PROFILE is T profiling information will be collected as well."
+  (check-type compile-at (member :run-time :definition-time))
+  (multiple-value-bind (forms decls docstring)
+      (parse-body body :documentation t :whole name)
+    (let* ((description (or docstring ""))
+           (body-forms (append decls forms))
+           (suite-form (if suite-p
+                           `(get-test ',suite)
+                           (or suite '*suite*)))
+           (effective-body (if fixture
+                               (destructuring-bind (name &rest args)
+                                   (ensure-list fixture)
+                                 `((with-fixture ,name ,args ,@body-forms)))
+                               body-forms)))
+      `(progn
+         (register-test ',name ,description ',effective-body ,suite-form ',depends-on ,compile-at ,profile)
+         (when *run-test-when-defined*
+           (run! ',name))
+         ',name))))
+
+(defun register-test (name description body suite depends-on compile-at profile)
+  (let ((lambda-name
+          (format-symbol t "%~A-~A" '#:test name))
+        (inner-lambda-name
+          (format-symbol t "%~A-~A" '#:inner-test name)))
+    (setf (get-test name)
+          (make-instance 'test-case
+                         :name name
+                         :runtime-package (find-package (package-name *package*))
+                         :test-lambda
+                         (eval
+                          `(named-lambda ,lambda-name ()
+                             ,@(ecase compile-at
+                                 (:run-time `((funcall
+                                               (let ((*package* (find-package ',(package-name *package*))))
+                                                 (compile ',inner-lambda-name
+                                                          '(lambda () ,@body))))))
+                                 (:definition-time body))))
+                         :description description
+                         :depends-on depends-on
+                         :collect-profiling-info profile))
+    (setf (gethash name (tests suite)) name)))
+
+(defvar *run-test-when-defined* nil
+  "When non-NIL tests are run as soon as they are defined.")
+
+;; Copyright (c) 2002-2003, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;;
+;;  - 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.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;;
+;; 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.
diff --git a/third_party/lisp/fiveam/src/utils.lisp b/third_party/lisp/fiveam/src/utils.lisp
new file mode 100644
index 000000000000..49d552fa000e
--- /dev/null
+++ b/third_party/lisp/fiveam/src/utils.lisp
@@ -0,0 +1,226 @@
+;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
+
+(in-package :it.bese.fiveam)
+
+(defmacro dolist* ((iterator list &optional return-value) &body body)
+  "Like DOLIST but destructuring-binds the elements of LIST.
+
+If ITERATOR is a symbol then dolist* is just like dolist EXCEPT
+that it creates a fresh binding."
+  (if (listp iterator)
+      (let ((i (gensym "DOLIST*-I-")))
+        `(dolist (,i ,list ,return-value)
+           (destructuring-bind ,iterator ,i
+             ,@body)))
+      `(dolist (,iterator ,list ,return-value)
+         (let ((,iterator ,iterator))
+           ,@body))))
+
+(defun make-collector (&optional initial-value)
+  "Create a collector function.
+
+A Collector function will collect, into a list, all the values
+passed to it in the order in which they were passed. If the
+callector function is called without arguments it returns the
+current list of values."
+  (let ((value initial-value)
+        (cdr (last initial-value)))
+    (lambda (&rest items)
+      (if items
+          (progn
+            (if value
+                (if cdr
+                    (setf (cdr cdr) items
+                          cdr (last items))
+                    (setf cdr (last items)))
+                (setf value items
+                      cdr (last items)))
+            items)
+          value))))
+
+(defun partitionx (list &rest lambdas)
+  (let ((collectors (mapcar (lambda (l)
+                              (cons (if (and (symbolp l)
+                                             (member l (list :otherwise t)
+                                                     :test #'string=))
+                                        (constantly t)
+                                        l)
+                                    (make-collector)))
+                            lambdas)))
+    (dolist (item list)
+      (block item
+        (dolist* ((test-func . collector-func) collectors)
+          (when (funcall test-func item)
+            (funcall collector-func item)
+            (return-from item)))))
+    (mapcar #'funcall (mapcar #'cdr collectors))))
+
+;;;; ** Anaphoric conditionals
+
+(defmacro if-bind (var test &body then/else)
+  "Anaphoric IF control structure.
+
+VAR (a symbol) will be bound to the primary value of TEST. If
+TEST returns a true value then THEN will be executed, otherwise
+ELSE will be executed."
+  (assert (first then/else)
+          (then/else)
+          "IF-BIND missing THEN clause.")
+  (destructuring-bind (then &optional else)
+      then/else
+    `(let ((,var ,test))
+       (if ,var ,then ,else))))
+
+(defmacro aif (test then &optional else)
+  "Just like IF-BIND but the var is always IT."
+  `(if-bind it ,test ,then ,else))
+
+;;;; ** Simple list matching based on code from Paul Graham's On Lisp.
+
+(defmacro acond2 (&rest clauses)
+  (if (null clauses)
+      nil
+      (with-gensyms (val foundp)
+        (destructuring-bind ((test &rest progn) &rest others)
+            clauses
+          `(multiple-value-bind (,val ,foundp)
+               ,test
+             (if (or ,val ,foundp)
+                 (let ((it ,val))
+                   (declare (ignorable it))
+                   ,@progn)
+                 (acond2 ,@others)))))))
+
+(defun varsymp (x)
+  (and (symbolp x)
+       (let ((name (symbol-name x)))
+         (and (>= (length name) 2)
+              (char= (char name 0) #\?)))))
+
+(defun binding (x binds)
+  (labels ((recbind (x binds)
+             (aif (assoc x binds)
+                  (or (recbind (cdr it) binds)
+                      it))))
+    (let ((b (recbind x binds)))
+      (values (cdr b) b))))
+
+(defun list-match (x y &optional binds)
+  (acond2
+    ((or (eql x y) (eql x '_) (eql y '_))
+     (values binds t))
+    ((binding x binds) (list-match it y binds))
+    ((binding y binds) (list-match x it binds))
+    ((varsymp x) (values (cons (cons x y) binds) t))
+    ((varsymp y) (values (cons (cons y x) binds) t))
+    ((and (consp x) (consp y) (list-match (car x) (car y) binds))
+     (list-match (cdr x) (cdr y) it))
+    (t (values nil nil))))
+
+(defun vars (match-spec)
+  (let ((vars nil))
+    (labels ((find-vars (spec)
+               (cond
+                 ((null spec) nil)
+                 ((varsymp spec) (push spec vars))
+                 ((consp spec)
+                  (find-vars (car spec))
+                  (find-vars (cdr spec))))))
+      (find-vars match-spec))
+    (delete-duplicates vars)))
+
+(defmacro list-match-case (target &body clauses)
+  (if clauses
+      (destructuring-bind ((test &rest progn) &rest others)
+          clauses
+        (with-gensyms (tgt binds success)
+          `(let ((,tgt ,target))
+             (multiple-value-bind (,binds ,success)
+                 (list-match ,tgt ',test)
+               (declare (ignorable ,binds))
+               (if ,success
+                   (let ,(mapcar (lambda (var)
+                                   `(,var (cdr (assoc ',var ,binds))))
+                                 (vars test))
+                     (declare (ignorable ,@(vars test)))
+                     ,@progn)
+                   (list-match-case ,tgt ,@others))))))
+      nil))
+
+;;;; * def-special-environment
+
+(defun check-required (name vars required)
+  (dolist (var required)
+    (assert (member var vars)
+            (var)
+            "Unrecognized symbol ~S in ~S." var name)))
+
+(defmacro def-special-environment (name (&key accessor binder binder*)
+                                  &rest vars)
+  "Define two macros for dealing with groups or related special variables.
+
+ACCESSOR is defined as a macro: (defmacro ACCESSOR (VARS &rest
+BODY)).  Each element of VARS will be bound to the
+current (dynamic) value of the special variable.
+
+BINDER is defined as a macro for introducing (and binding new)
+special variables. It is basically a readable LET form with the
+prorpe declarations appended to the body. The first argument to
+BINDER must be a form suitable as the first argument to LET.
+
+ACCESSOR defaults to a new symbol in the same package as NAME
+which is the concatenation of \"WITH-\" NAME. BINDER is built as
+\"BIND-\" and BINDER* is BINDER \"*\"."
+  (unless accessor
+    (setf accessor (format-symbol (symbol-package name) "~A-~A" '#:with name)))
+  (unless binder
+    (setf binder   (format-symbol (symbol-package name) "~A-~A" '#:bind name)))
+  (unless binder*
+    (setf binder*  (format-symbol (symbol-package binder) "~A~A" binder '#:*)))
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+     (flet ()
+       (defmacro ,binder (requested-vars &body body)
+         (check-required ',name ',vars (mapcar #'car requested-vars))
+         `(let ,requested-vars
+            (declare (special ,@(mapcar #'car requested-vars)))
+            ,@body))
+       (defmacro ,binder* (requested-vars &body body)
+         (check-required ',name ',vars (mapcar #'car requested-vars))
+         `(let* ,requested-vars
+            (declare (special ,@(mapcar #'car requested-vars)))
+            ,@body))
+       (defmacro ,accessor (requested-vars &body body)
+         (check-required ',name ',vars requested-vars)
+         `(locally (declare (special ,@requested-vars))
+            ,@body))
+       ',name)))
+
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;;  - Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;;
+;;  - 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.
+;;
+;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+;;    of its contributors may be used to endorse or promote products
+;;    derived from this software without specific prior written permission.
+;;
+;; 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
diff --git a/third_party/lisp/fiveam/t/example.lisp b/third_party/lisp/fiveam/t/example.lisp
new file mode 100644
index 000000000000..c949511a28cd
--- /dev/null
+++ b/third_party/lisp/fiveam/t/example.lisp
@@ -0,0 +1,126 @@
+;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
+
+;;;; * FiveAM Example (poor man's tutorial)
+
+(asdf:oos 'asdf:load-op :fiveam)
+
+(defpackage :it.bese.fiveam.example
+  (:use :common-lisp
+	:it.bese.fiveam))
+
+(in-package :it.bese.fiveam.example)
+
+;;;; First we need some functions to test.
+
+(defun add-2 (n)
+  (+ n 2))
+
+(defun add-4 (n) 
+  (+ n 4))
+
+;;;; Now we need to create a test which makes sure that add-2 and add-4
+;;;; work as specified.
+
+;;;; we create a test named ADD-2 and supply a short description.
+(test add-2
+ "Test the ADD-2 function" ;; a short description
+ ;; the checks
+ (is (= 2 (add-2 0)))
+ (is (= 0 (add-2 -2))))
+
+;;;; we can already run add-2. This will return the list of test
+;;;; results, it should be a list of two test-passed objects.
+
+(run 'add-2) 
+
+;;;; since we'd like to have some kind of readbale output we'll explain
+;;;; the results
+
+(explain! (run 'add-2))
+
+;;;; or we could do both at once:
+
+(run! 'add-2)
+
+;;;; So now we've defined and run a single test. Since we plan on
+;;;; having more than one test and we'd like to run them together let's
+;;;; create a simple test suite.
+
+(def-suite example-suite :description "The example test suite.")
+
+;;;; we could explictly specify that every test we create is in the the
+;;;; example-suite suite, but it's easier to just change the default
+;;;; suite:
+
+(in-suite example-suite)
+
+;;;; now we'll create a new test for the add-4 function.
+
+(test add-4
+  (is (= 0 (add-4 -4))))
+
+;;;; now let's run the test
+
+(run! 'add-4)
+
+;;;; we can get the same effect by running the suite:
+
+(run! 'example-suite)
+
+;;;; since we'd like both add-2 and add-4 to be in the same suite, let's
+;;;; redefine add-2 to be in this suite:
+
+(test add-2 "Test the ADD-2 function"
+ (is (= 2 (add-2 0)))
+ (is (= 0 (add-2 -2))))
+
+;;;; now we can run the suite and we'll see that both add-2 and add-4
+;;;; have been run (we know this since we no get 4 checks as opposed to
+;;;; 2 as before.
+
+(run! 'example-suite)
+
+;;;; Just for fun let's see what happens when a test fails. Again we'll
+;;;; redefine add-2, but add in a third, failing, check:
+
+(test add-2 "Test the ADD-2 function"
+ (is (= 2 (add-2 0)))
+ (is (= 0 (add-2 -2)))
+ (is (= 0 (add-2 0))))
+
+;;;; Finally let's try out the specification based testing.
+
+(defun dummy-add (a b)
+  (+ a b))
+
+(defun dummy-strcat (a b)
+  (concatenate 'string a b))
+
+(test dummy-add
+  (for-all ((a (gen-integer))
+            (b (gen-integer)))
+    ;; assuming we have an "oracle" to compare our function results to
+    ;; we can use it:
+    (is (= (+ a b) (dummy-add a b)))
+    ;; if we don't have an oracle (as in most cases) we just ensure
+    ;; that certain properties hold:
+    (is (= (dummy-add a b)
+           (dummy-add b a)))
+    (is (= a (dummy-add a 0)))
+    (is (= 0 (dummy-add a (- a))))
+    (is (< a (dummy-add a 1)))
+    (is (= (* 2 a) (dummy-add a a)))))
+
+(test dummy-strcat
+  (for-all ((result (gen-string))
+            (split-point (gen-integer :min 0 :max 10000)
+                         (< split-point (length result))))
+    (is (string= result (dummy-strcat (subseq result 0 split-point)
+                                      (subseq result split-point))))))
+
+(test random-failure
+  (for-all ((result (gen-integer :min 0 :max 1)))
+    (is (plusp result))
+    (is (= result 0))))
+
+(run! 'example-suite)
diff --git a/third_party/lisp/fiveam/t/tests.lisp b/third_party/lisp/fiveam/t/tests.lisp
new file mode 100644
index 000000000000..ed1c565e7d4a
--- /dev/null
+++ b/third_party/lisp/fiveam/t/tests.lisp
@@ -0,0 +1,280 @@
+;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
+
+(in-package :it.bese.fiveam)
+
+(in-suite* :it.bese.fiveam)
+
+(def-suite test-suite :description "Suite for tests which should fail.")
+
+(defmacro with-test-results ((results test-name) &body body)
+  `(let ((,results (with-*test-dribble* nil (run ',test-name))))
+     ,@body))
+
+(def-fixture null-fixture ()
+  `(progn ,@(&body)))
+
+;;;; Test the checks
+
+(def-test is1 (:suite test-suite)
+  (is (plusp 1))
+  (is (< 0 1))
+  (is (not (plusp -1)))
+  (is (not (< 1 0)))
+  (is-true t)
+  (is-false nil))
+
+(def-test is2 (:suite test-suite :fixture null-fixture)
+  (is (plusp 0))
+  (is (< 0 -1))
+  (is (not (plusp 1)))
+  (is (not (< 0 1)))
+  (is-true nil)
+  (is-false t))
+
+(def-test is (:profile t)
+  (with-test-results (results is1)
+    (is (= 6 (length results)))
+    (is (every #'test-passed-p results)))
+  (with-test-results (results is2)
+    (is (= 6 (length results)))
+    (is (every #'test-failure-p results))))
+
+(def-test signals/finishes ()
+  (signals error
+    (error "an error"))
+  (finishes
+   (signals error
+    (error "an error"))))
+
+(def-test pass ()
+  (pass))
+
+(def-test fail1 (:suite test-suite)
+  (fail "This is supposed to fail"))
+
+(def-test fail ()
+  (with-test-results (results fail1)
+    (is (= 1 (length results)))
+    (is (test-failure-p (first results)))))
+
+;;;; non top level checks
+
+(def-test foo-bar ()
+  (let ((state 0))
+    (is (= 0 state))
+    (is (= 1 (incf state)))))
+
+;;;; Test dependencies
+
+(def-test ok (:suite test-suite)
+  (pass))
+
+(def-test not-ok (:suite test-suite)
+  (fail "This is supposed to fail."))
+
+(def-test and1 (:depends-on (and ok not-ok) :suite test-suite)
+  (fail))
+
+(def-test and2 (:depends-on (and ok) :suite test-suite)
+  (pass))
+
+(def-test dep-and ()
+  (with-test-results (results and1)
+    (is (= 3 (length results)))
+    ;; we should have one skippedw one failed and one passed
+    (is (some #'test-passed-p results))
+    (is (some #'test-skipped-p results))
+    (is (some #'test-failure-p results)))
+  (with-test-results (results and2)
+    (is (= 2 (length results)))
+    (is (every #'test-passed-p results))))
+
+(def-test or1 (:depends-on (or ok not-ok) :suite test-suite)
+  (pass))
+
+(def-test or2 (:depends-on (or not-ok ok) :suite test-suite)
+  (pass))
+
+(def-test dep-or ()
+  (with-test-results (results or1)
+    (is (= 2 (length results)))
+    (is (every #'test-passed-p results)))
+  (with-test-results (results or2)
+    (is (= 3 (length results)))
+    (is (= 2 (length (remove-if-not #'test-passed-p results))))))
+
+(def-test not1 (:depends-on (not not-ok) :suite test-suite)
+  (pass))
+
+(def-test not2 (:depends-on (not ok) :suite test-suite)
+  (fail))
+
+(def-test not ()
+  (with-test-results (results not1)
+    (is (= 2 (length results)))
+    (is (some #'test-passed-p results))
+    (is (some #'test-failure-p results)))
+  (with-test-results (results not2)
+    (is (= 2 (length results)))
+    (is (some #'test-passed-p results))
+    (is (some #'test-skipped-p results))))
+
+(def-test nested-logic (:depends-on (and ok (not not-ok) (not not-ok))
+                        :suite test-suite)
+  (pass))
+
+(def-test dep-nested ()
+  (with-test-results (results nested-logic)
+    (is (= 3 (length results)))
+    (is (= 2 (length (remove-if-not #'test-passed-p results))))
+    (is (= 1 (length (remove-if-not #'test-failure-p results))))))
+
+(def-test circular-0 (:depends-on (and circular-1 circular-2 or1) 
+                      :suite test-suite)
+  (fail "we depend on a circular dependency, we should not be tested."))
+
+(def-test circular-1 (:depends-on (and circular-2)
+                      :suite test-suite)
+  (fail "we have a circular depednency, we should not be tested."))
+
+(def-test circular-2 (:depends-on (and circular-1)
+                      :suite test-suite)
+  (fail "we have a circular depednency, we should not be tested."))
+
+(def-test circular ()
+  (signals circular-dependency
+    (run 'circular-0))
+  (signals circular-dependency
+    (run 'circular-1))
+  (signals circular-dependency
+    (run 'circular-2)))
+
+
+(defun stack-exhaust ()
+  (declare (optimize (debug 3) (speed 0) (space 0) (safety 3)))
+  (cons 42 (stack-exhaust)))
+
+;; Disable until we determine on which implementations it's actually safe
+;; to exhaust the stack.
+#|
+(def-test stack-exhaust (:suite test-suite)
+  (stack-exhaust))
+
+(def-test test-stack-exhaust ()
+  (with-test-results (results stack-exhaust)
+    (is (= 1 (length results)))
+    (is (test-failure-p (first results)))))
+|#
+
+(def-suite before-test-suite :description "Suite for before test")
+
+(def-test before-0 (:suite before-test-suite)
+  (fail))
+
+(def-test before-1 (:depends-on (:before before-0)
+                    :suite before-test-suite)
+  (pass))
+
+(def-suite before-test-suite-2 :description "Suite for before test")
+
+(def-test before-2 (:depends-on (:before before-3)
+                    :suite before-test-suite-2)
+  (pass))
+
+(def-test before-3 (:suite before-test-suite-2)
+  (pass))
+
+(def-test before ()
+  (with-test-results (results before-test-suite)
+    (is (some #'test-skipped-p results)))
+  
+  (with-test-results (results before-test-suite-2)
+    (is (every #'test-passed-p results))))
+
+
+;;;; dependencies with symbol
+(def-test dep-with-symbol-first (:suite test-suite)
+  (pass))
+
+(def-test dep-with-symbol-dependencies-not-met (:depends-on (not dep-with-symbol-first)
+                                                :suite test-suite)
+  (fail "Error in the test of the test, this should not ever happen"))
+
+(def-test dep-with-symbol-depends-on-ok (:depends-on dep-with-symbol-first :suite test-suite)
+  (pass))
+
+(def-test dep-with-symbol-depends-on-failed-dependency (:depends-on dep-with-symbol-dependencies-not-met
+                                                        :suite test-suite)
+  (fail "No, I should not be tested because I depend on a test that in its turn has a failed dependecy."))
+
+(def-test dependencies-with-symbol ()
+  (with-test-results (results dep-with-symbol-first)
+    (is (some #'test-passed-p results)))
+
+  (with-test-results (results dep-with-symbol-depends-on-ok)
+    (is (some #'test-passed-p results)))
+
+  (with-test-results (results dep-with-symbol-dependencies-not-met)
+    (is (some #'test-skipped-p results)))
+
+  ;; No failure here, because it means the test was run.
+  (with-test-results (results dep-with-symbol-depends-on-failed-dependency)
+    (is (not (some #'test-failure-p results)))))
+
+
+;;;; test for-all
+
+(def-test gen-integer ()
+  (for-all ((a (gen-integer)))
+    (is (integerp a))))
+
+(def-test for-all-guarded ()
+  (for-all ((less (gen-integer))
+            (more (gen-integer) (< less more)))
+    (is (< less more))))
+
+(def-test gen-float ()
+  (macrolet ((test-gen-float (type)
+               `(for-all ((unbounded (gen-float :type ',type))
+                          (bounded   (gen-float :type ',type :bound 42)))
+                  (is (typep unbounded ',type))
+                  (is (typep bounded ',type))
+                  (is (<= (abs bounded) 42)))))
+    (test-gen-float single-float)
+    (test-gen-float short-float)
+    (test-gen-float double-float)
+    (test-gen-float long-float)))
+
+(def-test gen-character ()
+  (for-all ((c (gen-character)))
+    (is (characterp c)))
+  (for-all ((c (gen-character :code (gen-integer :min 32 :max 40))))
+    (is (characterp c))
+    (member c (list #\Space #\! #\" #\# #\$ #\% #\& #\' #\())))
+
+(def-test gen-string ()
+  (for-all ((s (gen-string)))
+    (is (stringp s)))
+  (for-all ((s (gen-string :length (gen-integer :min 0 :max 2))))
+    (is (<= (length s) 2)))
+  (for-all ((s (gen-string :elements (gen-character :code (gen-integer :min 0 :max 0))
+                           :length (constantly 2))))
+    (is (= 2 (length s)))
+    (is (every (curry #'char= #\Null) s))))
+
+(defun dummy-mv-generator ()
+  (lambda ()
+    (list 1 1)))
+
+(def-test for-all-destructuring-bind ()
+  (for-all (((a b) (dummy-mv-generator)))
+    (is (= 1 a))
+    (is (= 1 b))))
+
+(def-test return-values ()
+  "Return values indicate test failures."
+  (is-true (with-*test-dribble* nil (explain! (run 'is1))))
+  (is-true (with-*test-dribble* nil (run! 'is1)))
+
+  (is-false (with-*test-dribble* nil (explain! (run 'is2))))
+  (is-false (with-*test-dribble* nil (run! 'is2))))
diff --git a/third_party/lisp/fiveam/version.sexp b/third_party/lisp/fiveam/version.sexp
new file mode 100644
index 000000000000..e0e0284e6761
--- /dev/null
+++ b/third_party/lisp/fiveam/version.sexp
@@ -0,0 +1,2 @@
+;; -*- lisp -*-
+"1.4.1"
diff --git a/third_party/lisp/flexi-streams.nix b/third_party/lisp/flexi-streams.nix
new file mode 100644
index 000000000000..8cdf062f1cf2
--- /dev/null
+++ b/third_party/lisp/flexi-streams.nix
@@ -0,0 +1,34 @@
+# Flexible bivalent streams for Common Lisp
+{ depot, ... }:
+
+let src = builtins.fetchGit {
+  url = "https://github.com/edicl/flexi-streams.git";
+  rev = "0fd872ae32022e834ef861a67d86879cf33a6b64";
+};
+in depot.nix.buildLisp.library {
+  name = "flexi-streams";
+  deps = [ depot.third_party.lisp.trivial-gray-streams ];
+
+  srcs = map (f: src + ("/" + f)) [
+    "packages.lisp"
+    "mapping.lisp"
+    "ascii.lisp"
+    "koi8-r.lisp"
+    "iso-8859.lisp"
+    "code-pages.lisp"
+    "specials.lisp"
+    "util.lisp"
+    "conditions.lisp"
+    "external-format.lisp"
+    "length.lisp"
+    "encode.lisp"
+    "decode.lisp"
+    "in-memory.lisp"
+    "stream.lisp"
+    "output.lisp"
+    "input.lisp"
+    "io.lisp"
+    "strings.lisp"
+ ];
+}
+
diff --git a/third_party/lisp/hunchentoot.nix b/third_party/lisp/hunchentoot.nix
new file mode 100644
index 000000000000..9977405c65a1
--- /dev/null
+++ b/third_party/lisp/hunchentoot.nix
@@ -0,0 +1,61 @@
+# Hunchentoot is a web framework for Common Lisp.
+{ depot, ...}:
+
+let
+  src = depot.third_party.fetchFromGitHub {
+    owner = "edicl";
+    repo = "hunchentoot";
+    rev = "585b45b6b873f2da421fdf456b61860ab5868207";
+    sha256 = "13nazwix067mdclq9vgjhsi2vpr57a8dz51dd5d3h99ccsq4mik5";
+  };
+  url-rewrite = depot.nix.buildLisp.library {
+    name = "url-rewrite";
+
+    srcs = map (f: src + ("/url-rewrite/" + f)) [
+      "packages.lisp"
+      "specials.lisp"
+      "primitives.lisp"
+      "util.lisp"
+      "url-rewrite.lisp"
+    ];
+  };
+in depot.nix.buildLisp.library {
+  name = "hunchentoot";
+
+  deps = with depot.third_party.lisp; [
+    alexandria
+    bordeaux-threads
+    chunga
+    cl-base64
+    cl-fad
+    rfc2388
+    cl-plus-ssl
+    cl-ppcre
+    flexi-streams
+    md5
+    trivial-backtrace
+    usocket
+    url-rewrite
+  ];
+
+  srcs = map (f: src + ("/" + f)) [
+    "hunchentoot.asd"
+    "packages.lisp"
+    "compat.lisp"
+    "specials.lisp"
+    "conditions.lisp"
+    "mime-types.lisp"
+    "util.lisp"
+    "log.lisp"
+    "cookie.lisp"
+    "reply.lisp"
+    "request.lisp"
+    "session.lisp"
+    "misc.lisp"
+    "headers.lisp"
+    "set-timeouts.lisp"
+    "taskmaster.lisp"
+    "acceptor.lisp"
+    "easy-handlers.lisp"
+  ];
+}
diff --git a/third_party/lisp/iterate.nix b/third_party/lisp/iterate.nix
new file mode 100644
index 000000000000..2e6873885f54
--- /dev/null
+++ b/third_party/lisp/iterate.nix
@@ -0,0 +1,15 @@
+# iterate is an iteration construct for Common Lisp, similar to the
+# LOOP macro.
+{ depot, ... }:
+
+let src = builtins.fetchGit {
+  url = "https://gitlab.common-lisp.net/iterate/iterate.git";
+  rev = "a1c47b2b74f6c96149d717be90c07a1b273ced69";
+};
+in depot.nix.buildLisp.library {
+  name = "iterate";
+  srcs = [
+    "${src}/package.lisp"
+    "${src}/iterate.lisp"
+  ];
+}
diff --git a/third_party/lisp/lisp-binary.nix b/third_party/lisp/lisp-binary.nix
new file mode 100644
index 000000000000..f2dab565c2c1
--- /dev/null
+++ b/third_party/lisp/lisp-binary.nix
@@ -0,0 +1,30 @@
+# A library to easily read and write complex binary formats.
+{ depot, ... }:
+
+let src = depot.third_party.fetchFromGitHub {
+  owner = "j3pic";
+  repo = "lisp-binary";
+  rev = "1aefc8618b7734f68697ddf59bc93cb8522aa0bf";
+  sha256 = "1hflzn3mjp32jz9fxx9wayp3c3x58s77cgjfbs06nrynqkv0c6df";
+};
+in depot.nix.buildLisp.library {
+  name = "lisp-binary";
+
+  deps = with depot.third_party.lisp; [
+    cffi
+    quasiquote_2
+    moptilities
+    flexi-streams
+    closer-mop
+  ];
+
+  srcs = map (f: src + ("/" + f)) [
+    "utils.lisp"
+    "integer.lisp"
+    "float.lisp"
+    "simple-bit-stream.lisp"
+    "reverse-stream.lisp"
+    "binary-1.lisp"
+    "binary-2.lisp"
+  ];
+}
diff --git a/third_party/lisp/local-time.nix b/third_party/lisp/local-time.nix
new file mode 100644
index 000000000000..52e7c257e497
--- /dev/null
+++ b/third_party/lisp/local-time.nix
@@ -0,0 +1,18 @@
+# Library for manipulating dates & times
+{ depot, ... }:
+
+let src = depot.third_party.fetchFromGitHub {
+  owner = "dlowe-net";
+  repo = "local-time";
+  rev = "dc54f61415c76ee755a6f69d4154a3a282f2789f";
+  sha256 = "1l9v07ghx7g9p2gp003fki4j8bsa1w2gbm40qc41i94mdzikc0ry";
+};
+in depot.nix.buildLisp.library {
+  name = "local-time";
+  deps = [ depot.third_party.lisp.cl-fad ];
+
+  srcs = [
+    "${src}/src/package.lisp"
+    "${src}/src/local-time.lisp"
+  ];
+}
diff --git a/third_party/lisp/md5.nix b/third_party/lisp/md5.nix
new file mode 100644
index 000000000000..3f2ed371de83
--- /dev/null
+++ b/third_party/lisp/md5.nix
@@ -0,0 +1,16 @@
+# MD5 hash implementation
+{ depot, ... }:
+
+with depot.nix;
+
+let src = depot.third_party.fetchFromGitHub {
+  owner = "pmai";
+  repo = "md5";
+  rev = "b1412600f60d526ee34a7ba1596ec483da7894ab";
+  sha256 = "0lzip6b6xg7gd70xl1xmqp24fvxqj6ywjnz9lmx7988zpj20nhl2";
+};
+in buildLisp.library {
+  name = "md5";
+  deps = [ (buildLisp.bundled "sb-rotate-byte") ];
+  srcs = [ (src + "/md5.lisp") ];
+}
diff --git a/third_party/lisp/moptilities.nix b/third_party/lisp/moptilities.nix
new file mode 100644
index 000000000000..24a7f2c06d51
--- /dev/null
+++ b/third_party/lisp/moptilities.nix
@@ -0,0 +1,14 @@
+# Compatibility layer for minor MOP implementation differences
+{ depot, ... }:
+
+let src = depot.third_party.fetchFromGitHub {
+  owner = "gwkkwg";
+  repo = "moptilities";
+  rev = "a436f16b357c96b82397ec018ea469574c10dd41";
+  sha256 = "1q12bqjbj47lx98yim1kfnnhgfhkl80102fkgp9pdqxg0fp6g5fc";
+};
+in depot.nix.buildLisp.library {
+  name = "moptilities";
+  deps = [ depot.third_party.lisp.closer-mop ];
+  srcs = [ "${src}/dev/moptilities.lisp" ];
+}
diff --git a/third_party/lisp/puri.nix b/third_party/lisp/puri.nix
new file mode 100644
index 000000000000..51728c7646f3
--- /dev/null
+++ b/third_party/lisp/puri.nix
@@ -0,0 +1,15 @@
+# Portable URI library
+{ depot, ... }:
+
+let src = builtins.fetchGit {
+  url = "http://git.kpe.io/puri.git";
+  rev = "ef5afb9e5286c8e952d4344f019c1a636a717b97";
+};
+in depot.nix.buildLisp.library {
+  name = "puri";
+  srcs = [
+    (src + "/src.lisp")
+  ];
+}
+
+
diff --git a/third_party/lisp/quasiquote_2/README.md b/third_party/lisp/quasiquote_2/README.md
new file mode 100644
index 000000000000..2d590a0564ae
--- /dev/null
+++ b/third_party/lisp/quasiquote_2/README.md
@@ -0,0 +1,258 @@
+quasiquote-2.0
+==============
+
+Why should it be hard to write macros that write other macros?
+Well, it shouldn't!
+
+quasiquote-2.0 defines slightly different rules for quasiquotation,
+that make writing macro-writing macros very smooth experience.
+
+NOTE: quasiquote-2.0 does horrible things to shared structure!!!
+(it does a lot of COPY-TREE's, so shared-ness is destroyed).
+So, it's indeed a tool to construct code (where it does not matter much if the
+structure is shared or not) and not the data (or, at least, not the data with shared structure)
+
+
+```lisp
+(quasiquote-2.0:enable-quasiquote-2.0)
+
+(defmacro define-my-macro (name args &body body)
+  `(defmacro ,name ,args
+     `(sample-thing-to-expand-to
+        ,,@body))) ; note the difference from usual way
+
+(define-my-macro foo (x y)
+  ,x ; now here injections of quotation constructs work
+  ,y)
+
+(define-my-macro bar (&body body)
+  ,@body) ; splicing is also easy
+```
+
+The "injections" in macros FOO and BAR work as naively expected, as if I had written
+```lisp
+(defmacro foo (x y)
+  `(sample-thing-to-expand-to ,x ,y))
+
+(defmacro bar (&body body)
+  `(sample-thing-to-expand-to ,@body))
+
+(macroexpand-1 '(foo a b))
+
+  '(SAMPLE-THING-TO-EXPAND-TO A B)
+
+(macroexpand-1 '(bar a b c))
+
+  '(SAMPLE-THING-TO-EXPAND-TO A B C)
+```
+
+
+So, how is this effect achieved?
+
+
+DIG, INJECT and SPLICE
+-------------------------
+
+The transformations of backquote occur at macroexpansion-time and not at read-time.
+It is totally possible not to use any special reader syntax, but just
+underlying macros directly!
+
+At the core is a macro DIG, which expands to the code that generates the
+expression according to the rules, which are roughly these:
+  * each DIG increases "depth" by one (hence the name)
+  * each INJECT or SPLICE decreases "depth" by one
+  * if depth is 0, evaluation is turned on
+  * if depth if not zero (even if it's negative!) evaluation is off
+  * SPLICE splices the form, similarly to ordinary `,@`, INJECT simply injects, same as `,`
+
+```lisp
+;; The example using macros, without special reader syntax
+
+(dig ; depth is 1 here
+  (a b
+     (dig ; depth is 2 here
+       ((inject c) ; this inject is not evaluated, because depth is nonzero
+        (inject (d ;depth becomes 1 here again
+                (inject e) ; and this inject is evaluated, because depth becomes zero
+                ))
+        (inject 2 f) ; this inject with level specification is evaluated, because it
+                     ; decreases depth by 2
+        ))))
+
+
+;; the same example using ENABLE-QUASIQUOTE-2.0 syntax is written as
+`(a b `(,c ,(d ,e) ,,f)) ; note double comma acts different than usually
+```
+
+
+The ENABLE-QUASIQUOTE-2.0 macro just installs reader that reads
+`FORM as (DIG FORM), ,FORM as (INJECT FORM) and ,@FORM as (SPLICE FORM).
+You can just as well type DIG's, INJECT's and SPLICE's directly, 
+(in particular, when writing utility functions that generate macro-generating code)
+or roll your own convenient reader syntax (pull requests are welcome).
+
+So, these two lines (with ENABLE-QUASIQUOTE-2.0) read the same
+```lisp
+`(a (,b `,,c) d)
+
+(dig (a ((inject b) (dig (inject 2 c))) d))
+```
+
+You may notice the (INJECT 2 ...) form appearing, which is described below.
+
+
+At "level 1", i.e. when only \` , and ,@ are used, and not, say \`\` ,, ,', ,,@ ,',@
+this behaves exactly as usual quasiquotation.
+
+
+The optional N argument
+--------------
+
+All quasiquote-2.0 operators accept optional "depth" argument,
+which goes before the form for human readability.
+
+Namely, (DIG N FORM) increases depth by N instead of one and
+(INJECT N FORM) decreases depth by N instead of one.
+
+```lisp
+(DIG 2 (INJECT 2 A))
+
+; gives the same result as
+
+(DIG (INJECT A))
+```
+
+
+In fact, with ENABLE-QUASIQUOTE-2.0, say, ,,,,,FORM (5 quotes) reads as (INJECT 5 FORM)
+and ,,,,,@FORM as (SPLICE 5 FORM)
+
+
+More examples
+-------------
+
+For fairly complicated example, which uses ,,,@ and OINJECT (see below),
+ see DEFINE-BINOP-DEFINER macro
+in CG-LLVM (https://github.com/mabragor/cg-llvm/src/basics.lisp),
+desire to write which was the initial impulse for this project.
+
+
+For macro, that is not a macro-writing macro, yet benefits from
+ability to inject using `,` and `,@`, consider JOINING-WITH-COMMA-SPACE macro
+(also from CG-LLVM)
+
+```lisp
+(defmacro joining-with-comma-space (&body body)
+  ;; joinl just joins strings in the list with specified string
+  `(joinl ", " (mapcar #'emit-text-repr
+		       (remove-if-not #'identity  `(,,@body)))))
+
+;; the macro can be then used uniformly over strings and lists of strings
+(defun foo (x y &rest z)
+  (joining-with-comma-space ,x ,y ,@z))
+
+(foo "a" "b" "c" "d")
+  ;; produces
+  "a, b, c, d"
+```
+
+
+ODIG and OINJECT and OSPLICE
+----------------------------
+
+Sometimes you don't want DIG's macroexpansion to look further into the structure of
+some INJECT or SPLICE or DIG in its subform,
+if the depth does not match. In these cases you need "opaque" versions of
+DIG, INJECT and SPLICE, named, respectively, ODIG, OINJECT and OSPLICE.
+
+```lisp
+;; here injection of B would occur
+(defun foo (b)
+  (dig (dig (inject (a (inject b))))))
+
+;; and here not, because macroexpansion does not look into OINJECT form
+(defun bar (b)
+  (dig (dig (oinject (a (inject b))))))
+
+(foo 1)
+
+  '(DIG (INJECT (A 1)))
+
+(bar 1)
+
+  '(DIG (OINJECT (A (INJECT B))))
+```
+
+MACRO-INJECT and MACRO-SPLICE
+-----------------------------
+
+Sometimes you just want to abstract-out some common injection patterns...
+That is, you want macros, that expand into common injection patterns.
+However, you want this only sometimes, and only in special circumstances.
+So it won't do, if INJECT and SPLICE just expanded something, whenever it
+turned out to be macro. For that, use MACRO-INJECT and MACRO-SPLICE.
+
+```lisp
+;; with quasiquote-2.0 syntax turned on
+(defmacro inject-n-times (form n)
+  (make-list n :initial-element `(inject ,form)))
+
+(let (x 0)
+  `(dig (a (macro-inject (inject-n-times (incf x) 3)))))
+;; yields
+'(a (1 2 3))
+
+;;and same with MACRO-SPLICE
+(let (x 0)
+  `(dig (a (macro-splice (inject-n-times (incf x) 3)))))
+;; yields
+'(a 1 2 3)
+```
+
+OMACRO-INJECT and OMACRO-SPLICE are, as usual, opaque variants of MACRO-INJECT and MACRO-SPLICE.
+
+Both MACRO-INJECT and MACRO-SPLICE expand their subform exactly once (using MACROEXPAND-1),
+before plugging it into list.
+If you want to expand as much as it's possible, use MACRO-INJECT-ALL and MACRO-SPLICE-ALL,
+which expand using MACROEXPAND before injecting/splicing, respectively.
+That implies, that while subform of MACRO-INJECT and MACRO-SPLICE is checked to be
+macro-form, the subform of MACRO-INJECT-ALL is not.
+
+
+Terse syntax of the ENABLE-QUASIQUOTE-2.0
+-----------------------------------------
+
+Of course, typing all those MACRO-INJECT-ALL, or OMACRO-SPLICE-ALL or whatever explicitly
+every time you want this special things is kind of clumsy. For that, default reader
+of quasiquote-2.0 provides extended syntax
+
+```lisp
+',,,,!oma@x
+
+;; reads as
+'(OMACRO-SPLICE-ALL 4 X)
+```
+
+That is, the regexp of the syntax is
+[,]+![o][m][a][@]<whatever>
+
+As usual, number of commas determine the anti-depth of the injector, exclamation mark
+turns on the syntax, if `o` is present, opaque version of injector will be used,
+if `m` is present, macro-expanding version of injector will be used and if
+`a` is present, macro-all version of injector will be used.
+
+Note: it's possible to write ,!ax, which will read as (INJECT-ALL X), but
+this will not correspond to the actual macro name.
+
+Note: it was necessary to introduce special escape-char for extended syntax,
+since usual idioms like `,args` would otherwise be completely screwed.
+
+
+TODO
+----
+
+* WITH-QUASIQUOTE-2.0 read-macro-token for local enabling of ` and , overloading
+* wrappers for convenient definition of custom overloading schemes
+* some syntax for opaque operations
+
+P.S. Name "quasiquote-2.0" comes from "patronus 2.0" spell from www.hpmor.com
+     and has nothing to do with being "the 2.0" version of quasiquote.
\ No newline at end of file
diff --git a/third_party/lisp/quasiquote_2/default.nix b/third_party/lisp/quasiquote_2/default.nix
new file mode 100644
index 000000000000..521c384787fe
--- /dev/null
+++ b/third_party/lisp/quasiquote_2/default.nix
@@ -0,0 +1,17 @@
+# Quasiquote more suitable for macros that define other macros
+{ depot, ... }:
+
+depot.nix.buildLisp.library {
+  name = "quasiquote-2.0";
+
+  deps = [
+    depot.third_party.lisp.iterate
+  ];
+
+  srcs = [
+    ./package.lisp
+    ./quasiquote-2.0.lisp
+    ./macros.lisp
+    ./readers.lisp
+  ];
+}
diff --git a/third_party/lisp/quasiquote_2/macros.lisp b/third_party/lisp/quasiquote_2/macros.lisp
new file mode 100644
index 000000000000..6ebeb47d081e
--- /dev/null
+++ b/third_party/lisp/quasiquote_2/macros.lisp
@@ -0,0 +1,15 @@
+
+(in-package #:quasiquote-2.0)
+
+(defmacro define-dig-like-macro (name)
+  `(defmacro ,name (n-or-form &optional (form nil form-p) &environment env)
+     (if (not form-p)
+	 `(,',name 1 ,n-or-form)
+	 (let ((*env* env))
+	   (transform-dig-form `(,',name ,n-or-form ,form))))))
+
+
+(define-dig-like-macro dig)
+(define-dig-like-macro odig)
+
+
diff --git a/third_party/lisp/quasiquote_2/package.lisp b/third_party/lisp/quasiquote_2/package.lisp
new file mode 100644
index 000000000000..9b140ef84c32
--- /dev/null
+++ b/third_party/lisp/quasiquote_2/package.lisp
@@ -0,0 +1,11 @@
+;;;; package.lisp
+
+(defpackage #:quasiquote-2.0
+  (:use #:cl #:iterate)
+  (:export #:%codewalk-dig-form #:transform-dig-form
+	   #:dig #:inject #:splice #:odig #:oinject #:osplice
+	   #:macro-inject #:omacro-inject #:macro-splice #:omacro-splice
+	   #:macro-inject-all #:omacro-inject-all #:macro-splice-all #:omacro-splice-all
+	   #:enable-quasiquote-2.0 #:disable-quasiquote-2.0))
+
+
diff --git a/third_party/lisp/quasiquote_2/quasiquote-2.0.asd b/third_party/lisp/quasiquote_2/quasiquote-2.0.asd
new file mode 100644
index 000000000000..3acfd32b80e6
--- /dev/null
+++ b/third_party/lisp/quasiquote_2/quasiquote-2.0.asd
@@ -0,0 +1,30 @@
+;;;; quasiquote-2.0.asd
+
+(defpackage :quasiquote-2.0-system
+  (:use :cl :asdf))
+
+(in-package quasiquote-2.0-system)
+
+(asdf:defsystem #:quasiquote-2.0
+  :serial t
+  :description "Writing macros that write macros. Effortless."
+  :author "Alexandr Popolitov <popolit@gmail.com>"
+  :license "MIT"
+  :version "0.3"
+  :depends-on (#:iterate)
+  :components ((:file "package")
+               (:file "quasiquote-2.0")
+	       (:file "macros")
+	       (:file "readers")))
+
+(defsystem :quasiquote-2.0-tests
+  :description "Tests for QUASIQUOTE-2.0"
+  :licence "MIT"
+  :depends-on (:quasiquote-2.0 :fiveam)
+  :components ((:file "tests")
+	       (:file "tests-macro")
+	       ))
+
+(defmethod perform ((op test-op) (sys (eql (find-system :quasiquote-2.0))))
+  (load-system :quasiquote-2.0)
+  (funcall (intern "RUN-TESTS" :quasiquote-2.0)))
diff --git a/third_party/lisp/quasiquote_2/quasiquote-2.0.lisp b/third_party/lisp/quasiquote_2/quasiquote-2.0.lisp
new file mode 100644
index 000000000000..10043fe0ecbc
--- /dev/null
+++ b/third_party/lisp/quasiquote_2/quasiquote-2.0.lisp
@@ -0,0 +1,340 @@
+;;;; quasiquote-2.0.lisp
+
+(in-package #:quasiquote-2.0)
+
+(defparameter *env* nil)
+
+(defmacro nonsense-error (str)
+  `(error ,(concatenate 'string
+			str
+			" appears as a bare, non DIG-enclosed form. "
+			"For now I don't know how to make sense of this.")))
+
+(defmacro define-nonsense-when-bare (name)
+  `(defmacro ,name (n-or-form &optional form)
+     (declare (ignore n-or-form form))
+     (nonsense-error ,(string name))))
+
+(define-nonsense-when-bare inject)
+(define-nonsense-when-bare oinject)
+(define-nonsense-when-bare splice)
+(define-nonsense-when-bare osplice)
+(define-nonsense-when-bare macro-inject)
+
+(defparameter *depth* 0)
+
+
+(defparameter *injectors* nil)
+
+(defparameter *void-elt* nil)
+(defparameter *void-filter-needed* nil)
+
+;; (defmacro with-injector-parsed (form)
+;;   `(let ((kwd (intern (string 
+
+(defun reset-injectors ()
+  (setf *injectors* nil))
+
+(defparameter *known-injectors* '(inject splice oinject osplice
+				  macro-inject omacro-inject
+				  macro-splice omacro-splice
+				  macro-inject-all omacro-inject-all
+				  macro-splice-all omacro-splice-all))
+
+(defun injector-form-p (form)
+  (and (consp form)
+       (find (car form) *known-injectors* :test #'eq)))
+
+(defun injector-level (form)
+  (if (equal 2 (length form))
+      1
+      (cadr form)))
+
+(defun injector-subform (form)
+  (if (equal 2 (length form))
+      (values (cdr form) '(cdr))
+      (values (cddr form) '(cddr))))
+
+(defparameter *opaque-injectors* '(odig oinject osplice omacro-inject))
+
+(defun transparent-p (form)
+  (not (find (car form) *opaque-injectors* :test #'eq)))
+
+(defun look-into-injector (form path)
+  (let ((*depth* (- *depth* (injector-level form))))
+    (multiple-value-bind (subform subpath) (injector-subform form)
+      (search-all-active-sites subform (append subpath path) nil))))
+
+(defparameter *known-diggers* '(dig odig))
+
+(defun dig-form-p (form)
+  (and (consp form)
+       (find (car form) *known-diggers* :test #'eq)))
+
+(defun look-into-dig (form path)
+  (let ((*depth* (+ *depth* (injector-level form))))
+    (multiple-value-bind (subform subpath) (injector-subform form)
+      (search-all-active-sites subform (append subpath path) nil))))
+
+(defun handle-macro-1 (form)
+  (if (atom form)
+      (error "Sorry, symbol-macros are not implemented for now")
+      (let ((fun (macro-function (car form) *env*)))
+	(if (not fun)
+	    (error "The subform of MACRO-1 injector is supposed to be macro, perhaps, something went wrong..."))
+	(macroexpand-1 form *env*))))
+
+(defun handle-macro-all (form)
+  (if (atom form)
+      (error "Sorry, symbol-macros are not implemented for now")
+      (macroexpand form *env*)))
+
+
+(defparameter *macro-handlers* `((macro-inject . ,#'handle-macro-1)
+				 (omacro-inject . ,#'handle-macro-1)
+				 (macro-splice . ,#'handle-macro-1)
+				 (omacro-splice . ,#'handle-macro-1)
+				 (macro-inject-all . ,#'handle-macro-all)
+				 (omacro-inject-all . ,#'handle-macro-all)
+				 (macro-splice-all . ,#'handle-macro-all)
+				 (omacro-splice-all . ,#'handle-macro-all)))
+
+(defun get-macro-handler (sym)
+  (or (cdr (assoc sym *macro-handlers*))
+      (error "Don't know how to handle this macro injector: ~a" sym)))
+
+	
+
+(defun macroexpand-macroinjector (place)
+  (if (not (splicing-injector (car place)))
+      (progn (setf (car place) (funcall (get-macro-handler (caar place))
+					(car (injector-subform (car place)))))
+	     nil)
+      (let ((new-forms (funcall (get-macro-handler (caar place))
+				(car (injector-subform (car place))))))
+	(cond ((not new-forms)
+	       (setf *void-filter-needed* t
+		     (car place) *void-elt*))
+	      ((atom new-forms) (error "We need to splice the macroexpansion, but got atom: ~a" new-forms))
+	      (t (setf (car place) (car new-forms))
+		 (let ((tail (cdr place)))
+		   (setf (cdr place) (cdr new-forms)
+			 (cdr (last new-forms)) tail))))
+	t)))
+	    
+
+(defun search-all-active-sites (form path toplevel-p)
+  ;; (format t "SEARCH-ALL-ACTIVE-SITES: got form ~a~%" form)
+  (if (not form)
+      nil
+      (if toplevel-p
+	  (cond ((atom (car form)) :just-quote-it!)
+		((injector-form-p (car form)) (if (equal *depth* (injector-level (car form)))
+						  :just-form-it!
+						  (if (transparent-p (car form))
+						      (look-into-injector (car form) (cons 'car path)))))
+		((dig-form-p (car form))
+		 ;; (format t "Got dig form ~a~%" form)
+		 (if (transparent-p (car form))
+		     (look-into-dig (car form) (cons 'car path))))
+		(t (search-all-active-sites (car form) (cons 'car path) nil)
+		   (search-all-active-sites (cdr form) (cons 'cdr path) nil)))
+	  (when (consp form)
+	    (cond ((dig-form-p (car form))
+		   ;; (format t "Got dig form ~a~%" form)
+		   (if (transparent-p (car form))
+		       (look-into-dig (car form) (cons 'car path))))
+		  ((injector-form-p (car form))
+		   ;; (format t "Got injector form ~a ~a ~a~%" form *depth* (injector-level (car form)))
+		   (if (equal *depth* (injector-level (car form)))
+		       (if (macro-injector-p (car form))
+			   (progn (macroexpand-macroinjector form)
+				  (return-from search-all-active-sites
+				    (search-all-active-sites form path nil)))
+			   (progn (push (cons form (cons 'car path)) *injectors*)
+				  nil))
+		       (if (transparent-p (car form))
+			   (look-into-injector (car form) (cons 'car path)))))
+		  (t (search-all-active-sites (car form) (cons 'car path) nil)))
+	    (search-all-active-sites (cdr form) (cons 'cdr path) nil)))))
+
+	  
+	      
+(defun codewalk-dig-form (form)
+  (reset-injectors)
+  (let ((it (search-all-active-sites form nil t)))
+    (values (nreverse *injectors*) it)))
+
+(defun %codewalk-dig-form (form)
+  (if (not (dig-form-p form))
+      (error "Supposed to be called on dig form")
+      (let ((*depth* (+ (injector-level form) *depth*)))
+	(codewalk-dig-form (injector-subform form)))))
+
+(defun path->setfable (path var)
+  (let ((res var))
+    ;; First element is artifact of extra CAR-ing
+    (dolist (spec (cdr (reverse path)))
+      (setf res (list spec res)))
+    res))
+
+(defun tree->cons-code (tree)
+  (if (atom tree)
+      `(quote ,tree)
+      `(cons ,(tree->cons-code (car tree))
+	     ,(tree->cons-code (cdr tree)))))
+
+(defparameter *known-splicers* '(splice osplice
+				 macro-splice omacro-splice
+				 macro-splice-all omacro-splice-all))
+
+(defun splicing-injector (form)
+  (and (consp form)
+       (find (car form) *known-splicers* :test #'eq)))
+
+(defparameter *known-macro-injectors* '(macro-inject omacro-inject
+					macro-splice omacro-splice
+					macro-inject-all omacro-inject-all
+					macro-splice-all omacro-splice-all
+					))
+
+(defun macro-injector-p (form)
+  (and (consp form)
+       (find (car form) *known-macro-injectors* :test #'eq)))
+
+(defun filter-out-voids (lst void-sym)
+  (let (caars cadrs cdars cddrs)
+    ;; search for all occurences of VOID
+    (labels ((rec (x)
+	       (if (consp x)
+		   (progn (cond ((consp (car x))
+				 (cond ((eq void-sym (caar x)) (push x caars))
+				       ((eq void-sym (cdar x)) (push x cdars))))
+				((consp (cdr x))
+				 (cond ((eq void-sym (cadr x)) (push x cadrs))
+				       ((eq void-sym (cddr x)) (push x cddrs)))))
+			  (rec (car x))
+			  (rec (cdr x))))))
+      (rec lst))
+    (if (or cdars cddrs)
+	(error "Void sym found on CDR position, which should not have happened"))
+    ;; destructively transform LST
+    (dolist (elt caars)
+      (setf (car elt) (cdar elt)))
+    (dolist (elt cadrs)
+      (setf (cdr elt) (cddr elt)))
+    ;; check that we indeed filtered-out all VOIDs
+    (labels ((rec (x)
+	       (if (not (atom x))
+		   (progn (rec (car x))
+			  (rec (cdr x)))
+		   (if (eq void-sym x)
+		       (error "Not all VOIDs were filtered")))))
+      (rec lst))
+    lst))
+
+(defun transform-dig-form (form)
+  (let ((the-form (copy-tree form)))
+    (let ((*void-filter-needed* nil)
+	  (*void-elt* (gensym "VOID")))
+      (multiple-value-bind (site-paths cmd) (%codewalk-dig-form the-form)
+	(cond ((eq cmd :just-quote-it!)
+	       `(quote ,(car (injector-subform the-form))))
+	      ((eq cmd :just-form-it!)
+	       (car (injector-subform (car (injector-subform the-form)))))
+	      (t (let ((cons-code (if (not site-paths)
+				      (tree->cons-code (car (injector-subform the-form)))
+				      (really-transform-dig-form the-form site-paths))))
+		   (if (not *void-filter-needed*)
+		       cons-code
+		       `(filter-out-voids ,cons-code ',*void-elt*)))))))))
+
+(defmacro make-list-form (o!-n form)
+  (let ((g!-n (gensym "N"))
+	(g!-i (gensym "I"))
+	(g!-res (gensym "RES")))
+    `(let ((,g!-n ,o!-n)
+	   (,g!-res nil))
+       (dotimes (,g!-i ,g!-n)
+	 (push ,form ,g!-res))
+       (nreverse ,g!-res))))
+
+(defun mk-splicing-injector-let (x)
+  `(let ((it ,(car (injector-subform x))))
+     (assert (listp it))
+     (copy-list it)))
+
+
+
+(defun mk-splicing-injector-setf (path g!-list g!-splicee)
+  (assert (eq 'car (car path)))
+  (let ((g!-rest (gensym "REST")))
+    `(let ((,g!-rest ,(path->setfable (cons 'cdr (cdr path)) g!-list)))
+       (assert (or (not ,g!-rest) (consp ,g!-rest)))
+       (if (not ,g!-splicee)
+	   (setf ,(path->setfable (cdr path) g!-list)
+		 ,g!-rest)
+	   (progn (setf ,(path->setfable (cdr path) g!-list) ,g!-splicee)
+		  (setf (cdr (last ,g!-splicee)) ,g!-rest))))))
+
+
+(defun really-transform-dig-form (the-form site-paths)
+  (let ((gensyms (make-list-form (length site-paths) (gensym "INJECTEE"))))
+    (let ((g!-list (gensym "LIST")))
+      (let ((lets nil)
+	    (splicing-setfs nil)
+	    (setfs nil))
+	(do ((site-path site-paths (cdr site-path))
+	     (gensym gensyms (cdr gensym)))
+	    ((not site-path))
+	  (destructuring-bind (site . path) (car site-path)
+	    (push `(,(car gensym) ,(if (not (splicing-injector (car site)))
+				       (car (injector-subform (car site)))
+				       (mk-splicing-injector-let (car site))))
+		  lets)
+	    (if (not (splicing-injector (car site)))
+		(push `(setf ,(path->setfable path g!-list) ,(car gensym)) setfs)
+		(push (mk-splicing-injector-setf path g!-list (car gensym)) splicing-setfs))
+	    (setf (car site) nil)))
+	`(let ,(nreverse lets)
+	   (let ((,g!-list ,(tree->cons-code (car (injector-subform the-form)))))
+	     ,@(nreverse setfs)
+	     ;; we apply splicing setf in reverse order for them not to bork the paths of each other
+	     ,@splicing-setfs
+	     ,g!-list))))))
+
+
+;; There are few types of recursive injection that may happen:
+;;   * compile-time injection:
+;;     (dig (inject (dig (inject a)))) -- this type will be handled automatically by subsequent macroexpansions
+;;   * run-time injection:
+;;     (dig (dig (inject 2 a)))
+;;     and A is '(dig (inject 3 'foo)) -- this one we guard against ? (probably, first we just ignore it
+;;     -- do not warn about it, and then it wont really happen.
+;;   * macroexpanded compile-time injection:
+;;     (dig (inject (my-macro a b c))),
+;;     where MY-MACRO expands into, say (splice (list 'a 'b 'c))
+;;     This is *not* handled automatically, and therefore we must do it by hand.
+
+      
+;; OK, now how to implement splicing ?
+;;   (dig (a (splice (list b c)) d))
+;; should transform into code that yields
+;;   (a b c d)
+;; what this code is?
+;;   (let ((#:a (copy-list (list b c))))
+;;     (let ((#:res (cons 'a nil 'd)))
+;;       ;; all non-splicing injects go here, as they do not spoil the path-structure
+;;       (setf (cdr #:res) #:a)
+;;       (setf (cdr (last #:a)) (cdr (cdr #:res)))
+;;       #:res)))
+
+
+;; How this macroexpansion should work in general?
+;;   * We go over the cons-tree, keeping track of the depth level, which is
+;;   controlled by DIG's
+;;   * Once we find the INJECT with matching level, we remember the place, where
+;;     this happens
+;;   * We have two special cases:
+;;     * cons-tree is an atom
+;;     * cons-tree is just a single INJECT
diff --git a/third_party/lisp/quasiquote_2/readers.lisp b/third_party/lisp/quasiquote_2/readers.lisp
new file mode 100644
index 000000000000..7c4c5a30c98e
--- /dev/null
+++ b/third_party/lisp/quasiquote_2/readers.lisp
@@ -0,0 +1,77 @@
+
+
+(in-package #:quasiquote-2.0)
+
+(defun read-n-chars (stream char)
+  (let (new-char
+	(n 0))
+    (loop
+       (setf new-char (read-char stream nil :eof t))
+       (if (not (char= new-char char))
+	   (progn (unread-char new-char stream)
+		  (return n))
+	   (incf n)))))
+
+(defmacro define-dig-reader (name symbol)
+  `(defun ,name (stream char)
+     (let ((depth (1+ (read-n-chars stream char))))
+       (if (equal 1 depth)
+	   (list ',symbol (read stream t nil t))
+	   (list ',symbol
+		 depth
+		 (read stream t nil t))))))
+
+(define-dig-reader dig-reader dig)
+(define-dig-reader odig-reader odig)
+
+(defun expect-char (char stream)
+  (let ((new-char (read-char stream t nil t)))
+    (if (char= char new-char)
+	t
+	(unread-char new-char stream))))
+
+(defun guess-injector-name (opaque-p macro-p all-p splicing-p)
+  (intern (concatenate 'string
+		       (if opaque-p "O" "")
+		       (if macro-p "MACRO-" "")
+		       (if splicing-p "SPLICE" "INJECT")
+		       (if all-p "-ALL" ""))
+	  "QUASIQUOTE-2.0"))
+
+(defun inject-reader (stream char)
+  (let ((anti-depth (1+ (read-n-chars stream char)))
+	(extended-syntax (expect-char #\! stream)))
+    (let ((injector-name (if (not extended-syntax)
+			     (guess-injector-name nil nil nil (expect-char #\@ stream))
+			     (guess-injector-name (expect-char #\o stream)
+						  (expect-char #\m stream)
+						  (expect-char #\a stream)
+						  (expect-char #\@ stream)))))
+      `(,injector-name ,@(if (not (equal 1 anti-depth)) `(,anti-depth))
+		       ,(read stream t nil t)))))
+
+
+
+(defvar *previous-readtables* nil)
+
+(defun %enable-quasiquote-2.0 ()
+  (push *readtable*
+        *previous-readtables*)
+  (setq *readtable* (copy-readtable))
+  (set-macro-character #\` #'dig-reader)
+  (set-macro-character #\, #'inject-reader)
+  (values))
+
+(defun %disable-quasiquote-2.0 ()
+  (if *previous-readtables*
+      (setf *readtable* (pop *previous-readtables*))
+      (setf *readtable* (copy-readtable nil)))
+  (values))
+
+(defmacro enable-quasiquote-2.0 ()
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+     (%enable-quasiquote-2.0)))
+(defmacro disable-quasiquote-2.0 ()
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+     (%disable-quasiquote-2.0)))
+  
diff --git a/third_party/lisp/quasiquote_2/tests-macro.lisp b/third_party/lisp/quasiquote_2/tests-macro.lisp
new file mode 100644
index 000000000000..df6c43e21d77
--- /dev/null
+++ b/third_party/lisp/quasiquote_2/tests-macro.lisp
@@ -0,0 +1,21 @@
+
+(in-package #:quasiquote-2.0-tests)
+
+(in-suite quasiquote-2.0)
+
+(enable-quasiquote-2.0)
+
+(defmacro define-sample-macro (name args &body body)
+  `(defmacro ,name ,args
+     `(sample-thing-to-macroexpand-to
+       ,,@body)))
+
+(define-sample-macro sample-macro-1 (x y)
+  ,x ,y)
+
+(define-sample-macro sample-macro-2 (&body body)
+  ,@body)
+
+(test macro-defined-macroexpansions
+  (is (equal '(sample-thing-to-macroexpand-to a b) (macroexpand-1 '(sample-macro-1 a b))))
+  (is (equal '(sample-thing-to-macroexpand-to a b c) (macroexpand-1 '(sample-macro-2 a b c)))))
\ No newline at end of file
diff --git a/third_party/lisp/quasiquote_2/tests.lisp b/third_party/lisp/quasiquote_2/tests.lisp
new file mode 100644
index 000000000000..6c8ab08cc1af
--- /dev/null
+++ b/third_party/lisp/quasiquote_2/tests.lisp
@@ -0,0 +1,143 @@
+(in-package :cl-user)
+
+(defpackage :quasiquote-2.0-tests
+  (:use :cl :quasiquote-2.0 :fiveam)
+  (:export #:run-tests))
+
+(in-package :quasiquote-2.0-tests)
+
+(def-suite quasiquote-2.0)
+(in-suite quasiquote-2.0)
+
+(defun run-tests ()
+  (let ((results (run 'quasiquote-2.0)))
+    (fiveam:explain! results)
+    (unless (fiveam:results-status results)
+      (error "Tests failed."))))
+
+(test basic
+  (is (equal '(nil :just-quote-it!) (multiple-value-list (%codewalk-dig-form '(dig nil)))))
+  (is (equal '(nil :just-form-it!) (multiple-value-list (%codewalk-dig-form '(dig (inject a))))))
+  (is (equal '(nil :just-form-it!) (multiple-value-list (%codewalk-dig-form '(dig 2 (inject 2 a))))))
+  (is (equal '(((((inject b) c (inject d)) car cdr car) (((inject d)) car cdr cdr cdr car)) nil)
+	     (multiple-value-list (%codewalk-dig-form '(dig (a (inject b) c (inject d)))))))
+  (is (equal '(nil nil)
+	     (multiple-value-list (%codewalk-dig-form '(dig (dig (a (inject b) c (inject d))))))))
+  (is (equal '(((((inject 2 d)) car cdr cdr cdr car cdr car)) nil)
+	     (multiple-value-list (%codewalk-dig-form '(dig (dig (a (inject b) c (inject 2 d)))))))))
+  
+(test transform
+  (is (equal '(quote a) (transform-dig-form '(dig a))))
+  (is (equal '(quote a) (transform-dig-form '(dig 2 a))))
+  (is (equal 'a (transform-dig-form '(dig (inject a)))))
+  (is (equal 'a (transform-dig-form '(dig 2 (inject 2 a))))))
+
+(defun foo (b d)
+  (dig (a (inject b) c (inject d))))
+
+(defun foo1-transparent (x)
+  (declare (ignorable x))
+  (dig (dig (a (inject (b (inject x) c))))))
+
+(defun foo1-opaque (x)
+  (declare (ignorable x))
+  (dig (dig (a (oinject (b (inject x) c))))))
+
+(defun foo-recursive (x y)
+  (dig (a (inject (list x (dig (c (inject y))))))))
+  
+
+(test foos
+  (is (equal '(a 1 c 2) (foo 1 2)))
+  (is (equal '(a 100 c 200) (foo 100 200))))
+
+(test opaque-vs-transparent
+  (is (equal '(quote a) (transform-dig-form '(odig a))))
+  (is (equal '(quote a) (transform-dig-form '(odig 2 a))))
+  (is (equal 'a (transform-dig-form '(odig (inject a)))))
+  (is (equal 'a (transform-dig-form '(odig 2 (inject 2 a)))))
+  (is (equal '(odig (inject 2 a)) (eval (transform-dig-form '(dig (odig (inject 2 a)))))))
+  (is (equal '(dig (a (inject (b 3 c)))) (foo1-transparent 3)))
+  (is (equal '(dig (a (oinject (b (inject x) c)))) (foo1-opaque 3))))
+
+(test recursive-compile-time
+  (is (equal '(a (1 (c 2))) (foo-recursive 1 2))))
+	     
+
+(test splicing
+  (is (equal '(a b c d) (eval (transform-dig-form '(dig (a (splice '(b c)) d))))))
+  (is (equal '(b c d) (eval (transform-dig-form '(dig ((splice '(b c)) d))))))
+  (is (equal '(a b c) (eval (transform-dig-form '(dig (a (splice '(b c))))))))
+  (is (equal '(a b) (eval (transform-dig-form '(dig (a (splice nil) b))))))
+  (is (equal '(b) (eval (transform-dig-form '(dig ((splice nil) b))))))
+  (is (equal '(a) (eval (transform-dig-form '(dig (a (splice nil)))))))
+  (is (equal '() (eval (transform-dig-form '(dig ((splice nil)))))))
+  (is (equal '(a b) (eval (transform-dig-form '(dig ((splice '(a b)))))))))
+
+
+(test are-they-macro
+  (is (not (equal '(dig (a b)) (macroexpand-1 '(dig (a b))))))
+  (is (not (equal '(odig (a b)) (macroexpand-1 '(odig (a b)))))))
+
+
+(defmacro triple-var (x)
+  `((inject ,x) (inject ,x) (inject ,x)))
+
+(test correct-order-of-effects
+  (is (equal '(a 1 2 3) (let ((x 0))
+			  (dig (a (inject (incf x)) (inject (incf x)) (inject (incf x)))))))
+  (is (equal '(a (((1))) 2)
+	     (let ((x 0))
+	       (dig (a ((((inject (incf x))))) (inject (incf x))))))))
+
+(test macro-injects
+  (is (equal '(a (3 3 3)) (let ((x 3))
+			    (dig (a (macro-inject (triple-var x)))))))
+  (is (equal '(a (1 2 3)) (let ((x 0))
+			    (dig (a (macro-inject (triple-var (incf x))))))))
+  (macrolet ((frob (form n)
+	       (mapcar (lambda (x)
+			 `(inject ,x))
+		       (make-list n :initial-element form)))
+	     (frob1 (form)
+	       `(frob ,form 4)))
+    (is (equal '(a (1 2 3 4 5))
+	       (let ((x 0))
+		 (dig (a (macro-inject (frob (incf x) 5)))))))
+    (is (equal '(a 1 2 3 4 5)
+	       (let ((x 0))
+		 (dig (a (macro-splice (frob (incf x) 5)))))))
+    (is (equal '(a)
+	       (let ((x 0))
+		 (declare (ignorable x))
+		 (dig (a (macro-splice (frob (incf x) 0)))))))
+    (is (equal '(a frob (incf x) 4)
+	       (let ((x 0))
+		 (declare (ignorable x))
+		 (dig (a (macro-splice (frob1 (incf x))))))))
+    (is (equal '(a 1 2 3 4)
+	       (let ((x 0))
+		 (dig (a (macro-splice-all (frob1 (incf x))))))))))
+    
+	       
+(quasiquote-2.0:enable-quasiquote-2.0)
+
+(test reader
+  (is (equal '(inject x) ',x))
+  (is (equal '(inject 3 x) ',,,x))
+  (is (equal '(splice x) ',@x))
+  (is (equal '(splice 3 x) ',,,@x))
+  (is (equal '(omacro-splice-all 4 x) ',,,,!oma@x))
+  (is (equal '(inject 4 oma@x) ',,,,oma@x)))
+
+(test macro-splices
+  (macrolet ((splicer (x)
+	       ``(splice ,x)))
+    (is (equal '(a 1 2 3) (let ((x '(1 2 3)))
+			    `(a ,!m(splicer x)))))))
+
+(test repeated-splices
+  (is (equal '(a) `(a ,@nil ,@nil ,@nil ,@nil)))
+  (is (equal '(a b c d e f g) `(a ,@(list 'b 'c) ,@(list 'd 'e) ,@nil ,@(list 'f 'g)))))
+
+  
\ No newline at end of file
diff --git a/third_party/lisp/rfc2388.nix b/third_party/lisp/rfc2388.nix
new file mode 100644
index 000000000000..8288094904c2
--- /dev/null
+++ b/third_party/lisp/rfc2388.nix
@@ -0,0 +1,17 @@
+# Implementation of RFC2388 (multipart/form-data)
+{ depot, ... }:
+
+let src = depot.third_party.fetchFromGitHub {
+  owner = "jdz";
+  repo = "rfc2388";
+  rev = "591bcf7e77f2c222c43953a80f8c297751dc0c4e";
+  sha256 = "0phh5n3clhl9ji8jaxrajidn22d3f0aq87mlbfkkxlnx2pnw694k";
+};
+in depot.nix.buildLisp.library {
+  name = "rfc2388";
+
+  srcs = map (f: src + ("/" + f)) [
+    "packages.lisp"
+    "rfc2388.lisp"
+  ];
+}
diff --git a/third_party/lisp/s-sysdeps.nix b/third_party/lisp/s-sysdeps.nix
new file mode 100644
index 000000000000..aebd7c3f7b26
--- /dev/null
+++ b/third_party/lisp/s-sysdeps.nix
@@ -0,0 +1,17 @@
+# A Common Lisp abstraction layer over platform dependent functionality.
+{ depot, ... }:
+
+let src = depot.third_party.fetchFromGitHub {
+  owner = "svenvc";
+  repo = "s-sysdeps";
+  rev = "d28246b5dffef9e73a0e0e6cfbc4e878006fe34d";
+  sha256 = "14b69b81yrxmjlvmm3lfxk04x5v7hqz4fql121334wh72czznfh9";
+};
+in depot.nix.buildLisp.library {
+  name = "s-sysdeps";
+
+  srcs = [
+    "${src}/src/package.lisp"
+    "${src}/src/sysdeps.lisp"
+  ];
+}
diff --git a/third_party/lisp/s-xml/.gitignore b/third_party/lisp/s-xml/.gitignore
new file mode 100644
index 000000000000..40caffa8e257
--- /dev/null
+++ b/third_party/lisp/s-xml/.gitignore
@@ -0,0 +1,28 @@
+# CVS default ignores begin
+tags
+TAGS
+.make.state
+.nse_depinfo
+*~
+#*
+.#*
+,*
+_$*
+*$
+*.old
+*.bak
+*.BAK
+*.orig
+*.rej
+.del-*
+*.a
+*.olb
+*.o
+*.obj
+*.so
+*.exe
+*.Z
+*.elc
+*.ln
+core
+# CVS default ignores end
diff --git a/third_party/lisp/s-xml/ChangeLog b/third_party/lisp/s-xml/ChangeLog
new file mode 100644
index 000000000000..ac196619c0aa
--- /dev/null
+++ b/third_party/lisp/s-xml/ChangeLog
@@ -0,0 +1,66 @@
+2006-01-19 Sven Van Caekenberghe <svc@mac.com>
+
+	* added a set of patches contributed by David Tolpin dvd@davidashen.net : we're now using char of type 
+	Character and #\Null instead of null, read/unread instead of peek/read and some more declarations for
+	more efficiency - added hooks for customizing parsing attribute names and values
+
+2005-11-20 Sven Van Caekenberghe <svc@mac.com>
+
+	* added xml prefix namespace as per REC-xml-names-19990114 (by Rudi Schlatte)
+
+2005-11-06 Sven Van Caekenberghe <svc@mac.com>
+
+	* removed Debian packaging directory (on Luca's request)
+	* added CDATA support (patch contributed by Peter Van Eynde pvaneynd@mailworks.org)
+
+2005-08-30 Sven Van Caekenberghe <svc@mac.com>
+
+	* added Debian packaging directory (contributed by Luca Capello luca@pca.it)
+	* added experimental XML namespace support 
+
+2005-02-03 Sven Van Caekenberghe <svc@mac.com>
+
+        * release 5 (cvs tag RELEASE_5)
+	* added :start and :end keywords to print-string-xml
+	* fixed a bug: in a tag containing whitespace, like <foo> </foo> the parser collapsed 
+	  and ingnored all whitespace and considered the tag to be empty!
+          this is now fixed and a unit test has been added
+	* cleaned up xml character escaping a bit: single quotes and all normal whitespace  
+	  (newline, return and tab) is preserved a unit test for this has been added
+	* IE doesn't understand the &apos; XML entity, so I've commented that out for now. 
+	  Also, using actual newlines for newlines is probably better than using #xA, 
+	  which won't get any end of line conversion by the server or user agent.
+
+June 2004 Sven Van Caekenberghe <svc@mac.com>
+
+	* release 4
+	* project moved to common-lisp.net, renamed to s-xml, 
+	* added examples counter, tracer and remove-markup, improved documentation
+
+13 Jan 2004 Sven Van Caekenberghe <svc@mac.com>
+	
+	* release 3
+	* added ASDF systems
+	* optimized print-string-xml
+
+10 Jun 2003 Sven Van Caekenberghe <svc@mac.com>
+	
+	* release 2
+	* added echo-xml function: we are no longer taking the car when
+	  the last seed is returned from start-parse-xml
+
+25 May 2003 Sven Van Caekenberghe <svc@mac.com>
+	
+	* release 1
+	* first public release of working code
+	* tested on OpenMCL
+	* rewritten to be event-based, to improve efficiency and 
+	  to optionally use different DOM representations
+	* more documentation
+
+end of 2002 Sven Van Caekenberghe <svc@mac.com>
+	
+	* release 0
+	* as part of an XML-RPC implementation
+
+$Id: ChangeLog,v 1.5 2005/11/20 14:24:33 scaekenberghe Exp $
diff --git a/third_party/lisp/s-xml/Makefile b/third_party/lisp/s-xml/Makefile
new file mode 100644
index 000000000000..0c7292ea9fb5
--- /dev/null
+++ b/third_party/lisp/s-xml/Makefile
@@ -0,0 +1,35 @@
+# $Id: Makefile,v 1.2 2004/06/11 13:46:48 scaekenberghe Exp $
+
+default:
+	@echo Possible targets:
+	@echo clean-openmcl --- remove all '*.dfsl' recursively
+	@echo clean-lw --- remove all '*.nfasl' recursively
+	@echo clean-emacs --- remove all '*~' recursively
+	@echo clean --- all of the above
+
+clean-openmcl:
+	find . -name "*.dfsl" | xargs rm
+
+clean-lw:
+	find . -name "*.nfasl" | xargs rm
+
+clean-emacs:
+	find . -name "*~" | xargs rm
+
+clean: clean-openmcl clean-lw clean-emacs
+
+#
+# This can obviously only be done by a specific person in a very specific context ;-)
+#
+
+PRJ=s-xml
+ACCOUNT=scaekenberghe
+CVSRT=:ext:$(ACCOUNT)@common-lisp.net:/project/$(PRJ)/cvsroot
+
+release:
+	rm -rf /tmp/$(PRJ) /tmp/public_html /tmp/$(PRJ).tgz /tmp/$(PRJ).tgz.asc
+	cd /tmp; cvs -d$(CVSRT) export -r HEAD $(PRJ); cvs -d$(CVSRT) export -r HEAD public_html
+	mv /tmp/public_html /tmp/$(PRJ)/doc
+	cd /tmp; gnutar cvfz $(PRJ).tgz $(PRJ); gpg -a -b $(PRJ).tgz
+	scp /tmp/$(PRJ).tgz $(ACCOUNT)@common-lisp.net:/project/$(PRJ)/public_html
+	scp /tmp/$(PRJ).tgz.asc $(ACCOUNT)@common-lisp.net:/project/$(PRJ)/public_html
diff --git a/third_party/lisp/s-xml/default.nix b/third_party/lisp/s-xml/default.nix
new file mode 100644
index 000000000000..82b6317f372c
--- /dev/null
+++ b/third_party/lisp/s-xml/default.nix
@@ -0,0 +1,17 @@
+# XML serialiser for Common Lisp.
+#
+# This system was imported from a Quicklisp tarball at 's-xml-20150608'.
+{ depot, ... }:
+
+depot.nix.buildLisp.library {
+  name = "s-xml";
+
+  srcs = [
+    ./src/package.lisp
+    ./src/xml.lisp
+    ./src/dom.lisp
+    ./src/lxml-dom.lisp
+    ./src/sxml-dom.lisp
+    ./src/xml-struct-dom.lisp
+  ];
+}
diff --git a/third_party/lisp/s-xml/examples/counter.lisp b/third_party/lisp/s-xml/examples/counter.lisp
new file mode 100644
index 000000000000..b26453e6ea66
--- /dev/null
+++ b/third_party/lisp/s-xml/examples/counter.lisp
@@ -0,0 +1,47 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: counter.lisp,v 1.2 2004/06/11 11:14:43 scaekenberghe Exp $
+;;;;
+;;;; A simple SSAX counter example that can be used as a performance test
+;;;;
+;;;; Copyright (C) 2004 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :s-xml)
+
+(defclass count-xml-seed ()
+  ((elements :initform 0)
+   (attributes :initform 0)
+   (characters :initform 0)))
+
+(defun count-xml-new-element-hook (name attributes seed)
+  (declare (ignore name))
+  (incf (slot-value seed 'elements))
+  (incf (slot-value seed 'attributes) (length attributes))
+  seed)
+
+(defun count-xml-text-hook (string seed)
+  (incf (slot-value seed 'characters) (length string))
+  seed)
+  
+(defun count-xml (in)
+  "Parse a toplevel XML element from stream in, counting elements, attributes and characters"
+  (start-parse-xml in
+		   (make-instance 'xml-parser-state
+				  :seed (make-instance 'count-xml-seed)
+				  :new-element-hook #'count-xml-new-element-hook
+				  :text-hook #'count-xml-text-hook)))
+
+(defun count-xml-file (pathname)
+  "Parse XMl from the file at pathname, counting elements, attributes and characters"
+  (with-open-file (in pathname)
+    (let ((result (count-xml in)))
+      (with-slots (elements attributes characters) result
+        (format t 
+                "~a contains ~d XML elements, ~d attributes and ~d characters.~%" 
+                pathname elements attributes characters)))))
+
+;;;; eof
diff --git a/third_party/lisp/s-xml/examples/echo.lisp b/third_party/lisp/s-xml/examples/echo.lisp
new file mode 100644
index 000000000000..a0befe2cbbbb
--- /dev/null
+++ b/third_party/lisp/s-xml/examples/echo.lisp
@@ -0,0 +1,64 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: echo.lisp,v 1.1 2005/08/17 13:44:30 scaekenberghe Exp $
+;;;;
+;;;; A simple example as well as a useful tool: parse, echo and pretty print XML
+;;;;
+;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :s-xml)
+
+(defun indent (stream count)
+  (loop :repeat (* count 2) :do (write-char #\space stream)))
+
+(defclass echo-xml-seed ()
+  ((stream :initarg :stream)
+   (level :initarg :level :initform 0)))
+
+#+NIL
+(defmethod print-object ((seed echo-xml-seed) stream)
+  (with-slots (stream level) seed
+    (print-unreadable-object (seed stream :type t)
+      (format stream "level=~d" level))))
+
+(defun echo-xml-new-element-hook (name attributes seed)
+  (with-slots (stream level) seed
+    (indent stream level)
+    (format stream "<~a" name)
+    (dolist (attribute (reverse attributes)) 
+      (format stream " ~a=\'" (car attribute))
+      (print-string-xml (cdr attribute) stream)
+      (write-char #\' stream))
+    (format stream ">~%")
+    (incf level)
+    seed))
+
+(defun echo-xml-finish-element-hook (name attributes parent-seed seed)
+  (declare (ignore attributes parent-seed))
+  (with-slots (stream level) seed 
+    (decf level)
+    (indent stream level)
+    (format stream "</~a>~%" name)
+    seed))
+
+(defun echo-xml-text-hook (string seed)
+  (with-slots (stream level) seed
+    (indent stream level)
+    (print-string-xml string stream)
+    (terpri stream)
+    seed))
+  
+(defun echo-xml (in out)
+  "Parse a toplevel XML element from stream in, echoing and pretty printing the result to stream out"
+  (start-parse-xml in
+		   (make-instance 'xml-parser-state
+				  :seed (make-instance 'echo-xml-seed :stream out)
+				  :new-element-hook #'echo-xml-new-element-hook
+				  :finish-element-hook #'echo-xml-finish-element-hook
+				  :text-hook #'echo-xml-text-hook)))
+
+;;;; eof
diff --git a/third_party/lisp/s-xml/examples/remove-markup.lisp b/third_party/lisp/s-xml/examples/remove-markup.lisp
new file mode 100644
index 000000000000..41d858b4a8c5
--- /dev/null
+++ b/third_party/lisp/s-xml/examples/remove-markup.lisp
@@ -0,0 +1,21 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: remove-markup.lisp,v 1.1 2004/06/11 11:14:43 scaekenberghe Exp $
+;;;;
+;;;; Remove markup from an XML document using the SSAX interface
+;;;;
+;;;; Copyright (C) 2004 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :s-xml)
+
+(defun remove-xml-markup (in)
+  (let* ((state (make-instance 'xml-parser-state
+                              :text-hook #'(lambda (string seed) (cons string seed))))
+         (result (start-parse-xml in state)))
+    (apply #'concatenate 'string (nreverse result))))
+
+;;;; eof
\ No newline at end of file
diff --git a/third_party/lisp/s-xml/examples/tracer.lisp b/third_party/lisp/s-xml/examples/tracer.lisp
new file mode 100644
index 000000000000..c8a3eaec1f2b
--- /dev/null
+++ b/third_party/lisp/s-xml/examples/tracer.lisp
@@ -0,0 +1,57 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: tracer.lisp,v 1.2 2004/06/11 11:14:43 scaekenberghe Exp $
+;;;;
+;;;; A simple SSAX tracer example that can be used to understand how the hooks are called
+;;;;
+;;;; Copyright (C) 2004 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :s-xml)
+
+(defun trace-xml-log (level msg &rest args)
+  (indent *standard-output* level)
+  (apply #'format *standard-output* msg args)
+  (terpri *standard-output*))
+
+(defun trace-xml-new-element-hook (name attributes seed)
+  (let ((new-seed (cons (1+ (car seed)) (1+ (cdr seed)))))
+    (trace-xml-log (car seed) 
+                   "(new-element :name ~s :attributes ~:[()~;~:*~s~] :seed ~s) => ~s" 
+                   name attributes seed new-seed)
+    new-seed))
+
+(defun trace-xml-finish-element-hook (name attributes parent-seed seed)
+  (let ((new-seed (cons (1- (car seed)) (1+ (cdr seed)))))
+    (trace-xml-log (car parent-seed)
+                   "(finish-element :name ~s :attributes ~:[()~;~:*~s~] :parent-seed ~s :seed ~s) => ~s" 
+                   name attributes parent-seed seed new-seed)
+    new-seed))
+
+(defun trace-xml-text-hook (string seed)
+  (let ((new-seed (cons (car seed) (1+ (cdr seed)))))
+    (trace-xml-log (car seed) 
+                   "(text :string ~s :seed ~s) => ~s" 
+                   string seed new-seed)
+    new-seed))
+
+(defun trace-xml (in)
+  "Parse and trace a toplevel XML element from stream in"
+  (start-parse-xml in
+		   (make-instance 'xml-parser-state
+				  :seed (cons 0 0) 
+                                  ;; seed car is xml element nesting level
+                                  ;; seed cdr is ever increasing from element to element
+				  :new-element-hook #'trace-xml-new-element-hook
+                                  :finish-element-hook #'trace-xml-finish-element-hook
+				  :text-hook #'trace-xml-text-hook)))
+
+(defun trace-xml-file (pathname)
+  "Parse and trace XMl from the file at pathname"
+  (with-open-file (in pathname)
+    (trace-xml in)))
+
+;;;; eof
diff --git a/third_party/lisp/s-xml/s-xml.asd b/third_party/lisp/s-xml/s-xml.asd
new file mode 100644
index 000000000000..651f5e5844c2
--- /dev/null
+++ b/third_party/lisp/s-xml/s-xml.asd
@@ -0,0 +1,49 @@
+;;;; -*- Mode: LISP -*-
+;;;;
+;;;; $Id: s-xml.asd,v 1.2 2005/12/14 21:49:04 scaekenberghe Exp $
+;;;;
+;;;; The S-XML ASDF system definition
+;;;;
+;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :asdf)
+
+(defsystem :s-xml
+  :name "S-XML"
+  :author "Sven Van Caekenberghe <svc@mac.com>"
+  :version "3"
+  :maintainer "Sven Van Caekenberghe <svc@mac.com>, Brian Mastenbrook <>, Rudi Schlatte <>"
+  :licence "Lisp Lesser General Public License (LLGPL)"
+  :description "Simple Common Lisp XML Parser"
+  :long-description "S-XML is a Common Lisp implementation of a simple XML parser, with a SAX-like and DOM interface"
+
+  :components
+  ((:module
+    :src
+    :components ((:file "package")
+                 (:file "xml" :depends-on ("package"))
+                 (:file "dom" :depends-on ("package" "xml"))
+                 (:file "lxml-dom" :depends-on ("dom"))
+                 (:file "sxml-dom" :depends-on ("dom"))
+                 (:file "xml-struct-dom" :depends-on ("dom"))))))
+
+(defsystem :s-xml.test
+  :depends-on (:s-xml)
+  :components ((:module :test
+		:components ((:file "test-xml")
+ 			     (:file "test-xml-struct-dom")
+			     (:file "test-lxml-dom")
+ 			     (:file "test-sxml-dom")))))
+
+(defsystem :s-xml.examples
+  :depends-on (:s-xml)
+  :components ((:module :examples
+		:components ((:file "counter")
+			     (:file "echo")
+			     (:file "remove-markup")
+			     (:file "tracer")))))
+;;;; eof
diff --git a/third_party/lisp/s-xml/src/dom.lisp b/third_party/lisp/s-xml/src/dom.lisp
new file mode 100644
index 000000000000..74d1c371db22
--- /dev/null
+++ b/third_party/lisp/s-xml/src/dom.lisp
@@ -0,0 +1,75 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: dom.lisp,v 1.1.1.1 2004/06/07 18:49:56 scaekenberghe Exp $
+;;;;
+;;;; This is the generic simple DOM parser and printer interface.
+;;;;
+;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :s-xml)
+
+;;; top level DOM parser interface
+
+(defgeneric parse-xml-dom (stream output-type)
+  (:documentation "Parse a character stream as XML and generate a DOM of output-type"))
+
+(defun parse-xml (stream &key (output-type :lxml))
+  "Parse a character stream as XML and generate a DOM of output-type, defaulting to :lxml"
+  (parse-xml-dom stream output-type))
+  
+(defun parse-xml-string (string &key (output-type :lxml))
+  "Parse a string as XML and generate a DOM of output-type, defaulting to :lxml"
+  (with-input-from-string (stream string)
+    (parse-xml-dom stream output-type)))
+
+(defun parse-xml-file (filename &key (output-type :lxml))
+  "Parse a character file as XML and generate a DOM of output-type, defaulting to :lxml"
+  (with-open-file (in filename :direction :input)
+    (parse-xml-dom in output-type)))
+
+;;; top level DOM printer interface
+
+(defgeneric print-xml-dom (dom input-type stream pretty level)
+  (:documentation "Generate XML output on a character stream from a DOM of input-type, optionally pretty printing using level"))
+
+(defun print-xml (dom &key (stream t) (pretty nil) (input-type :lxml) (header))
+  "Generate XML output on a character stream (t by default) from a DOM of input-type (:lxml by default), optionally pretty printing (off by default), or adding a header (none by default)"
+  (when header (format stream header))
+  (when pretty (terpri stream))
+  (print-xml-dom dom input-type stream pretty 1))
+
+(defun print-xml-string (dom &key (pretty nil) (input-type :lxml))
+  "Generate XML output to a string from a DOM of input-type (:lxml by default), optionally pretty printing (off by default)"
+  (with-output-to-string (stream)
+    (print-xml dom :stream stream :pretty pretty :input-type input-type)))
+
+;;; shared/common support functions
+
+(defun print-spaces (n stream &optional (preceding-newline t))
+  (when preceding-newline 
+    (terpri stream))
+  (loop :repeat n 
+        :do (write-char #\Space stream)))
+
+(defun print-solitary-tag (tag stream)
+  (write-char #\< stream) 
+  (print-identifier tag stream) 
+  (write-string "/>" stream))
+
+(defun print-closing-tag (tag stream)
+  (write-string "</" stream) 
+  (print-identifier tag stream) 
+  (write-char #\> stream))
+  
+(defun print-attribute (name value stream)
+  (write-char #\space stream)
+  (print-identifier name stream t)
+  (write-string "=\"" stream)
+  (print-string-xml value stream)
+  (write-char #\" stream))
+
+;;;; eof
diff --git a/third_party/lisp/s-xml/src/lxml-dom.lisp b/third_party/lisp/s-xml/src/lxml-dom.lisp
new file mode 100644
index 000000000000..d43df6cf8171
--- /dev/null
+++ b/third_party/lisp/s-xml/src/lxml-dom.lisp
@@ -0,0 +1,83 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: lxml-dom.lisp,v 1.5 2005/09/20 09:57:44 scaekenberghe Exp $
+;;;;
+;;;; LXML implementation of the generic DOM parser and printer.
+;;;;
+;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :s-xml)
+
+;;; the lxml hooks to generate lxml
+
+(defun lxml-new-element-hook (name attributes seed)
+  (declare (ignore name attributes seed))
+  '())
+
+(defun lxml-finish-element-hook (name attributes parent-seed seed)
+  (let ((xml-element
+	 (cond ((and (null seed) (null attributes))
+		name)
+	       (attributes
+		`((,name ,@(let (list)
+			     (dolist (attribute attributes list)
+			       (push (cdr attribute) list)
+			       (push (car attribute) list))))
+		  ,@(nreverse seed)))
+	       (t
+		`(,name ,@(nreverse seed))))))
+    (cons xml-element parent-seed)))
+
+(defun lxml-text-hook (string seed)
+  (cons string seed))
+
+;;; standard DOM interfaces
+
+(defmethod parse-xml-dom (stream (output-type (eql :lxml)))
+  (car (start-parse-xml stream
+			(make-instance 'xml-parser-state
+				       :new-element-hook #'lxml-new-element-hook
+				       :finish-element-hook #'lxml-finish-element-hook
+				       :text-hook #'lxml-text-hook))))
+
+(defun plist->alist (plist)
+  (when plist 
+    (cons (cons (first plist) (second plist))
+          (plist->alist (rest (rest plist))))))
+
+(defmethod print-xml-dom (dom (input-type (eql :lxml)) stream pretty level)
+  (declare (special *namespaces*))
+  (cond ((symbolp dom) (print-solitary-tag dom stream))
+	((stringp dom) (print-string-xml dom stream))
+	((consp dom)
+	 (let (tag attributes)
+	   (cond ((symbolp (first dom)) (setf tag (first dom)))
+		 ((consp (first dom)) (setf tag (first (first dom)) 
+                                            attributes (plist->alist (rest (first dom)))))
+		 (t (error "Input not recognized as LXML ~s" dom)))
+           (let ((*namespaces* (extend-namespaces attributes *namespaces*)))
+             (write-char #\< stream) 
+             (print-identifier tag stream)
+             (loop :for (name . value) :in attributes 
+                   :do (print-attribute name value stream))
+             (if (rest dom)
+                 (let ((children (rest dom)))
+                   (write-char #\> stream)
+                   (if (and (= (length children) 1) (stringp (first children)))
+                       (print-string-xml (first children) stream)
+                     (progn
+                       (dolist (child children)
+                         (when pretty (print-spaces (* 2 level) stream))
+                         (if (stringp child)
+                             (print-string-xml child stream)
+                           (print-xml-dom child input-type stream pretty (1+ level))))
+                       (when pretty (print-spaces (* 2 (1- level)) stream))))
+                   (print-closing-tag tag stream))
+               (write-string "/>" stream)))))
+	(t (error "Input not recognized as LXML ~s" dom))))
+  
+;;;; eof
\ No newline at end of file
diff --git a/third_party/lisp/s-xml/src/package.lisp b/third_party/lisp/s-xml/src/package.lisp
new file mode 100644
index 000000000000..f90f0f49a166
--- /dev/null
+++ b/third_party/lisp/s-xml/src/package.lisp
@@ -0,0 +1,46 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: package.lisp,v 1.7 2006/01/19 20:00:06 scaekenberghe Exp $
+;;;;
+;;;; This is a Common Lisp implementation of a very basic XML parser.
+;;;; The parser is non-validating.
+;;;; The API into the parser is pure functional parser hook model that comes from SSAX,
+;;;; see also http://pobox.com/~oleg/ftp/Scheme/xml.html or http://ssax.sourceforge.net
+;;;; Different DOM models are provided, an XSML, an LXML and a xml-element struct based one.
+;;;;
+;;;; Copyright (C) 2002, 2003, 2004, 2005, 2006 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(defpackage s-xml
+  (:use common-lisp)
+  (:export
+   ;; main parser interface
+   #:start-parse-xml
+   #:print-string-xml
+   #:xml-parser-error #:xml-parser-error-message #:xml-parser-error-args #:xml-parser-error-stream
+   #:xml-parser-state #:get-entities #:get-seed
+   #:get-new-element-hook #:get-finish-element-hook #:get-text-hook
+   ;; callbacks
+   #:*attribute-name-parser*
+   #:*attribute-value-parser*
+   #:parse-attribute-name
+   #:parse-attribute-value
+   ;; dom parser and printer
+   #:parse-xml-dom #:parse-xml #:parse-xml-string #:parse-xml-file
+   #:print-xml-dom #:print-xml #:print-xml-string
+   ;; xml-element structure
+   #:make-xml-element #:xml-element-children #:xml-element-name 
+   #:xml-element-attribute #:xml-element-attributes
+   #:xml-element-p #:new-xml-element #:first-xml-element-child
+   ;; namespaces
+   #:*ignore-namespaces* #:*local-namespace* #:*namespaces*
+   #:*require-existing-symbols* #:*auto-export-symbols* #:*auto-create-namespace-packages*
+   #:find-namespace #:register-namespace #:get-prefix #:get-uri #:get-package
+   #:resolve-identifier #:extend-namespaces #:print-identifier #:split-identifier)
+  (:documentation 
+   "A simple XML parser with an efficient, purely functional, event-based interface as well as a DOM interface"))
+
+;;;; eof
diff --git a/third_party/lisp/s-xml/src/sxml-dom.lisp b/third_party/lisp/s-xml/src/sxml-dom.lisp
new file mode 100644
index 000000000000..c9e0f9e0db4e
--- /dev/null
+++ b/third_party/lisp/s-xml/src/sxml-dom.lisp
@@ -0,0 +1,76 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: sxml-dom.lisp,v 1.4 2005/09/20 09:57:48 scaekenberghe Exp $
+;;;;
+;;;; LXML implementation of the generic DOM parser and printer.
+;;;;
+;;;; Copyright (C) 2003, 2004 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :s-xml)
+
+;;; the sxml hooks to generate sxml
+
+(defun sxml-new-element-hook (name attributes seed)
+  (declare (ignore name attributes seed))
+  '())
+
+(defun sxml-finish-element-hook (name attributes parent-seed seed)
+  (let ((xml-element (append (list name)
+			     (when attributes
+			       (list (let (list)
+				       (dolist (attribute attributes (cons :@ list))
+					 (push (list (car attribute) (cdr attribute)) list)))))
+			     (nreverse seed))))
+    (cons xml-element parent-seed)))
+
+(defun sxml-text-hook (string seed)
+  (cons string seed))
+
+;;; the standard DOM interfaces
+
+(defmethod parse-xml-dom (stream (output-type (eql :sxml)))
+  (car (start-parse-xml stream
+			(make-instance 'xml-parser-state
+				       :new-element-hook #'sxml-new-element-hook
+				       :finish-element-hook #'sxml-finish-element-hook
+				       :text-hook #'sxml-text-hook))))
+
+(defmethod print-xml-dom (dom (input-type (eql :sxml)) stream pretty level)
+  (declare (special *namespaces*))
+  (cond ((stringp dom) (print-string-xml dom stream))
+	((consp dom)
+	 (let ((tag (first dom))
+	       attributes
+	       children)
+	   (if (and (consp (second dom)) (eq (first (second dom)) :@))
+	       (setf attributes (rest (second dom))
+		     children (rest (rest dom)))
+	     (setf children (rest dom)))
+           (let ((*namespaces* (extend-namespaces (loop :for (name value) :in attributes 
+                                                        :collect (cons name value))
+                                                  *namespaces*)))
+             (write-char #\< stream)
+             (print-identifier tag stream)
+             (loop :for (name value) :in attributes
+                   :do (print-attribute name value stream))
+             (if children
+                 (progn
+                   (write-char #\> stream)
+                   (if (and (= (length children) 1) (stringp (first children)))
+                       (print-string-xml (first children) stream)
+                     (progn
+                       (dolist (child children)
+                         (when pretty (print-spaces (* 2 level) stream))
+                         (if (stringp child)
+                             (print-string-xml child stream)
+                           (print-xml-dom child input-type stream pretty (1+ level))))
+                       (when pretty (print-spaces (* 2 (1- level)) stream))))
+                   (print-closing-tag tag stream))
+               (write-string "/>" stream)))))
+	(t (error "Input not recognized as SXML ~s" dom))))
+
+;;;; eof
diff --git a/third_party/lisp/s-xml/src/xml-struct-dom.lisp b/third_party/lisp/s-xml/src/xml-struct-dom.lisp
new file mode 100644
index 000000000000..70373889152f
--- /dev/null
+++ b/third_party/lisp/s-xml/src/xml-struct-dom.lisp
@@ -0,0 +1,125 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: xml-struct-dom.lisp,v 1.2 2005/08/29 15:01:47 scaekenberghe Exp $
+;;;;
+;;;; XML-STRUCT implementation of the generic DOM parser and printer.
+;;;;
+;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :s-xml)
+
+;;; xml-element struct datastructure and API
+
+(defstruct xml-element
+  name        ; :tag-name
+  attributes  ; a assoc list of (:attribute-name . "attribute-value")
+  children    ; a list of children/content either text strings or xml-elements
+  )
+
+(setf (documentation 'xml-element-p 'function)
+      "Return T when the argument is an xml-element struct"
+      (documentation 'xml-element-attributes 'function)
+      "Return the alist of attribute names and values dotted pairs from an xml-element struct"
+      (documentation 'xml-element-children 'function)
+      "Return the list of children from an xml-element struct"
+      (documentation 'xml-element-name 'function)
+      "Return the name from an xml-element struct"
+      (documentation 'make-xml-element 'function)
+      "Make and return a new xml-element struct")
+
+(defun xml-element-attribute (xml-element key)
+  "Return the string value of the attribute with name the keyword :key
+  of xml-element if any, return null if not found"
+  (let ((pair (assoc key (xml-element-attributes xml-element) :test #'eq)))
+    (when pair (cdr pair))))
+
+(defun (setf xml-element-attribute) (value xml-element key)
+  "Set the string value of the attribute with name the keyword :key of
+  xml-element, creating a new attribute if necessary or overwriting an
+  existing one, returning the value"
+  (let ((attributes (xml-element-attributes xml-element)))
+    (if (null attributes)
+	(push (cons key value) (xml-element-attributes xml-element))
+      (let ((pair (assoc key attributes :test #'eq)))
+	(if pair
+	    (setf (cdr pair) value)
+	  (push (cons key value) (xml-element-attributes xml-element)))))
+    value))
+
+(defun new-xml-element (name &rest children)
+  "Make a new xml-element with name and children"
+  (make-xml-element :name name :children children))
+
+(defun first-xml-element-child (xml-element)
+  "Get the first child of an xml-element"
+  (first (xml-element-children xml-element)))
+
+(defun xml-equal (xml-1 xml-2)
+  (and (xml-element-p xml-1)
+       (xml-element-p xml-2)
+       (eq (xml-element-name xml-1)
+	   (xml-element-name xml-2))
+       (equal (xml-element-attributes xml-1)
+	      (xml-element-attributes xml-2))
+       (reduce #'(lambda (&optional (x t) (y t)) (and x y))
+	       (mapcar #'(lambda (x y)
+			   (or (and (stringp x) (stringp y) (string= x y))
+			       (xml-equal x y)))
+		       (xml-element-children xml-1)
+		       (xml-element-children xml-2)))))
+
+;;; printing xml structures
+
+(defmethod print-xml-dom (xml-element (input-type (eql :xml-struct)) stream pretty level)
+  (declare (special *namespaces*))
+  (let ((*namespaces* (extend-namespaces (xml-element-attributes xml-element)
+                                         *namespaces*)))
+    (write-char #\< stream)
+    (print-identifier (xml-element-name xml-element) stream)
+    (loop :for (name . value) :in (xml-element-attributes xml-element)
+          :do (print-attribute name value stream))
+    (let ((children (xml-element-children xml-element))) 
+      (if children
+          (progn
+            (write-char #\> stream)
+            (if (and (= (length children) 1) (stringp (first children)))
+                (print-string-xml (first children) stream)
+              (progn
+                (dolist (child children)
+                  (when pretty (print-spaces (* 2 level) stream))
+                  (if (stringp child)
+                      (print-string-xml child stream)
+                    (print-xml-dom child input-type stream pretty (1+ level))))
+                (when pretty (print-spaces (* 2 (1- level)) stream))))
+            (print-closing-tag (xml-element-name xml-element) stream))
+        (write-string "/>" stream)))))
+
+;;; the standard hooks to generate xml-element structs
+
+(defun standard-new-element-hook (name attributes seed)
+  (declare (ignore name attributes seed))
+  '())
+
+(defun standard-finish-element-hook (name attributes parent-seed seed)
+  (let ((xml-element (make-xml-element :name name
+				       :attributes attributes
+				       :children (nreverse seed))))
+    (cons xml-element parent-seed)))
+
+(defun standard-text-hook (string seed)
+  (cons string seed))
+
+;;; top level standard parser interfaces
+
+(defmethod parse-xml-dom (stream (output-type (eql :xml-struct)))
+  (car (start-parse-xml stream
+			(make-instance 'xml-parser-state
+				       :new-element-hook #'standard-new-element-hook
+				       :finish-element-hook #'standard-finish-element-hook
+				       :text-hook #'standard-text-hook))))
+
+;;;; eof
diff --git a/third_party/lisp/s-xml/src/xml.lisp b/third_party/lisp/s-xml/src/xml.lisp
new file mode 100644
index 000000000000..8a2076985a49
--- /dev/null
+++ b/third_party/lisp/s-xml/src/xml.lisp
@@ -0,0 +1,702 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: xml.lisp,v 1.15 2006/01/19 20:00:06 scaekenberghe Exp $
+;;;;
+;;;; This is a Common Lisp implementation of a basic but usable XML parser.
+;;;; The parser is non-validating and not complete (no PI).
+;;;; Namespace and entities are handled.
+;;;; The API into the parser is a pure functional parser hook model that comes from SSAX,
+;;;; see also http://pobox.com/~oleg/ftp/Scheme/xml.html or http://ssax.sourceforge.net
+;;;; Different DOM models are provided, an XSML, an LXML and a xml-element struct based one.
+;;;;
+;;;; Copyright (C) 2002, 2003, 2004, 2005, 2006 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :s-xml)
+
+;;; (tazjin): moved up here because something was wonky with the
+;;; definition order
+(defvar *ignore-namespaces* nil
+  "When t, namespaces are ignored like in the old version of S-XML")
+
+;;; error reporting
+
+(define-condition xml-parser-error (error)
+  ((message :initarg :message :reader xml-parser-error-message)
+   (args :initarg :args :reader xml-parser-error-args)
+   (stream :initarg :stream :reader xml-parser-error-stream :initform nil))
+  (:report (lambda (condition stream)
+	     (format stream
+		     "XML parser ~?~@[ near stream position ~d~]."
+		     (xml-parser-error-message condition)
+		     (xml-parser-error-args condition)
+		     (and (xml-parser-error-stream condition)
+			  (file-position (xml-parser-error-stream condition))))))
+  (:documentation "Thrown by the XML parser to indicate errorneous input"))
+
+(setf (documentation 'xml-parser-error-message 'function)
+      "Get the message from an XML parser error"
+      (documentation 'xml-parser-error-args 'function)
+      "Get the error arguments from an XML parser error"
+      (documentation 'xml-parser-error-stream 'function)
+      "Get the stream from an XML parser error")
+
+(defun parser-error (message &optional args stream)
+  (make-condition 'xml-parser-error
+		  :message message
+		  :args args
+		  :stream stream))
+
+;; attribute parsing hooks
+;; this is a bit complicated, refer to the mailing lists for a more detailed explanation
+
+(defun parse-attribute-name (string)
+  "Default parser for the attribute name"
+  (declare (special *namespaces*))
+  (resolve-identifier string *namespaces* t))
+
+(defun parse-attribute-value (name string)
+  "Default parser for the attribute value"
+  (declare (ignore name)
+           (special *ignore-namespace*))
+  (if *ignore-namespaces*
+      (copy-seq string)
+      string))
+
+(defparameter *attribute-name-parser* #'parse-attribute-name
+  "Called to compute interned attribute name from a buffer that will be reused")
+
+(defparameter *attribute-value-parser* #'parse-attribute-value
+  "Called to compute an element of an attribute list from a buffer that will be reused")
+
+;;; utilities
+
+(defun whitespace-char-p (char)
+  "Is char an XML whitespace character ?"
+  (declare (type character char))
+  (or (char= char #\space)
+      (char= char #\tab)
+      (char= char #\return)
+      (char= char #\linefeed)))
+
+(defun identifier-char-p (char)
+  "Is char an XML identifier character ?"
+  (declare (type character char))
+  (or (and (char<= #\A char) (char<= char #\Z))
+      (and (char<= #\a char) (char<= char #\z))
+      (and (char<= #\0 char) (char<= char #\9))
+      (char= char #\-)
+      (char= char #\_)
+      (char= char #\.)
+      (char= char #\:)))
+
+(defun skip-whitespace (stream)
+  "Skip over XML whitespace in stream, return first non-whitespace
+  character which was peeked but not read, return nil on eof"
+  (loop
+   (let ((char (peek-char nil stream nil #\Null)))
+     (declare (type character char))
+     (if (whitespace-char-p char)
+	 (read-char stream)
+       (return char)))))
+
+(defun make-extendable-string (&optional (size 10))
+  "Make an extendable string which is a one-dimensional character
+  array which is adjustable and has a fill pointer"
+  (make-array size
+	      :element-type 'character
+	      :adjustable t
+	      :fill-pointer 0))
+
+(defun print-string-xml (string stream &key (start 0) end)
+  "Write the characters of string to stream using basic XML conventions"
+  (loop for offset upfrom start below (or end (length string))
+        for char = (char string offset)
+	do (case char
+	     (#\& (write-string "&amp;" stream))
+	     (#\< (write-string "&lt;" stream))
+	     (#\> (write-string "&gt;" stream))
+	     (#\" (write-string "&quot;" stream))
+             ((#\newline #\return #\tab) (write-char char stream))
+	     (t (if (and (<= 32 (char-code char))
+			 (<= (char-code char) 126))
+		    (write-char char stream)
+		  (progn
+		    (write-string "&#x" stream)
+		    (write (char-code char) :stream stream :base 16)
+		    (write-char #\; stream)))))))
+
+(defun make-standard-entities ()
+  "A hashtable mapping XML entity names to their replacement strings,
+  filled with the standard set"
+  (let ((entities (make-hash-table :test #'equal)))
+    (setf (gethash "amp" entities) (string #\&)
+	  (gethash "quot" entities) (string #\")
+	  (gethash "apos" entities) (string #\')
+	  (gethash "lt" entities) (string #\<)
+	  (gethash "gt" entities) (string #\>)
+	  (gethash "nbsp" entities) (string #\space))
+    entities))
+
+(defun resolve-entity (stream extendable-string entities entity)
+  "Read and resolve an XML entity from stream, positioned after the '&' entity marker,
+  accepting &name; &#DEC; and &#xHEX; formats,
+  destructively modifying string, which is also returned,
+  destructively modifying entity, incorrect entity formats result in errors"
+  (declare (type (vector character) entity))
+  (loop
+   (let ((char (read-char stream nil #\Null)))
+     (declare (type character char))
+     (cond ((char= char #\Null) (error (parser-error "encountered eof before end of entity")))
+	   ((char= #\; char) (return))
+	   (t (vector-push-extend char entity)))))
+  (if (char= (char entity 0) #\#)
+      (let ((code (if (char= (char entity 1) #\x)
+		      (parse-integer entity :start 2 :radix 16 :junk-allowed t)
+		    (parse-integer entity :start 1 :radix 10 :junk-allowed t))))
+	(when (null code)
+          (error (parser-error "encountered incorrect entity &~s;" (list entity) stream)))
+	(vector-push-extend (code-char code) extendable-string))
+    (let ((value (gethash entity entities)))
+      (if value
+	  (loop :for char :across value
+                :do (vector-push-extend char extendable-string))
+	(error (parser-error "encountered unknown entity &~s;" (list entity) stream)))))
+  extendable-string)
+
+;;; namespace support
+
+(defclass xml-namespace ()
+  ((uri :documentation "The URI used to identify this namespace"
+        :accessor get-uri
+        :initarg :uri)
+   (prefix :documentation "The preferred prefix assigned to this namespace"
+           :accessor get-prefix
+           :initarg :prefix
+           :initform nil)
+   (package :documentation "The Common Lisp package where this namespace's symbols are interned"
+            :accessor get-package
+            :initarg :package
+            :initform nil))
+  (:documentation "Describes an XML namespace and how it is handled"))
+
+(setf (documentation 'get-uri 'function)
+      "The URI used to identify this namespace"
+      (documentation 'get-prefix 'function)
+      "The preferred prefix assigned to this namespace"
+      (documentation 'get-package 'function)
+      "The Common Lisp package where this namespace's symbols are interned")
+
+(defmethod print-object ((object xml-namespace) stream)
+  (print-unreadable-object (object stream :type t :identity t)
+    (format stream "~A - ~A" (get-prefix object) (get-uri object))))
+
+(defvar *local-namespace* (make-instance 'xml-namespace
+                                         :uri "local"
+                                         :prefix ""
+                                         :package (find-package :keyword))
+  "The local (global default) XML namespace")
+
+(defvar *xml-namespace* (make-instance 'xml-namespace
+                                       :uri "http://www.w3.org/XML/1998/namespace"
+                                       :prefix "xml"
+                                       :package (or (find-package :xml)
+                                                    (make-package :xml :nicknames '("XML"))))
+  "REC-xml-names-19990114 says the prefix xml is bound to the namespace http://www.w3.org/XML/1998/namespace.")
+
+(defvar *known-namespaces* (list *local-namespace* *xml-namespace*)
+  "The list of known/defined namespaces")
+
+(defvar *namespaces* `(("xml" . ,*xml-namespace*) ("" . ,*local-namespace*))
+  "Ordered list of (prefix . XML-namespace) bindings currently in effect - special variable")
+
+(defun find-namespace (uri)
+  "Find a registered XML namespace identified by uri"
+  (find uri *known-namespaces* :key #'get-uri :test #'string-equal))
+
+(defun register-namespace (uri prefix package)
+  "Register a new or redefine an existing XML namespace defined by uri with prefix and package"
+  (let ((namespace (find-namespace uri)))
+    (if namespace
+        (setf (get-prefix namespace) prefix
+              (get-package namespace) (find-package package))
+      (push (setf namespace (make-instance 'xml-namespace
+                                           :uri uri
+                                           :prefix prefix
+                                           :package (find-package package)))
+            *known-namespaces*))
+    namespace))
+
+(defun find-namespace-binding (prefix namespaces)
+  "Find the XML namespace currently bound to prefix in the namespaces bindings"
+  (cdr (assoc prefix namespaces :test #'string-equal)))
+
+(defun split-identifier (identifier)
+  "Split an identifier 'prefix:name' and return (values prefix name)"
+  (when (symbolp identifier)
+    (setf identifier (symbol-name identifier)))
+  (let ((colon-position (position #\: identifier :test #'char=)))
+    (if colon-position
+        (values (subseq identifier 0 colon-position)
+                (subseq identifier (1+ colon-position)))
+      (values nil identifier))))
+
+(defvar *require-existing-symbols* nil
+  "If t, each XML identifier must exist as symbol already")
+
+(defvar *auto-export-symbols* t
+  "If t, export newly interned symbols form their packages")
+
+(defun resolve-identifier (identifier namespaces &optional as-attribute)
+  "Resolve the string identifier in the list of namespace bindings"
+  (if *ignore-namespaces*
+      (intern identifier :keyword)
+    (flet ((intern-symbol (string package) ; intern string as a symbol in package
+             (if *require-existing-symbols*
+                 (let ((symbol (find-symbol string package)))
+                   (or symbol
+                       (error "Symbol ~s does not exist in ~s" string package)))
+               (let ((symbol (intern string package)))
+                 (when (and *auto-export-symbols*
+                            (not (eql package (find-package :keyword))))
+                   (export symbol package))
+                 symbol))))
+      (multiple-value-bind (prefix name)
+          (split-identifier identifier)
+        (if (or (null prefix) (string= prefix "xmlns"))
+            (if as-attribute
+                (intern (if (string= prefix "xmlns") identifier name) (get-package *local-namespace*))
+              (let ((default-namespace (find-namespace-binding "" namespaces)))
+                (intern-symbol name (get-package default-namespace))))
+          (let ((namespace (find-namespace-binding prefix namespaces)))
+            (if namespace
+                (intern-symbol name (get-package namespace))
+              (error "namespace not found for prefix ~s" prefix))))))))
+
+(defvar *auto-create-namespace-packages* t
+  "If t, new packages will be created for namespaces, if needed, named by the prefix")
+
+(defun new-namespace (uri &optional prefix)
+  "Register a new namespace for uri and prefix, creating a package if necessary"
+  (if prefix
+      (register-namespace uri
+                          prefix
+                          (or (find-package prefix)
+                              (if *auto-create-namespace-packages*
+                                  (make-package prefix :nicknames `(,(string-upcase prefix)))
+                                (error "Cannot find or create package ~s" prefix))))
+    (let ((unique-name (loop :for i :upfrom 0
+                             :do (let ((name (format nil "ns-~d" i)))
+                                   (when (not (find-package name))
+                                     (return name))))))
+      (register-namespace uri
+                          unique-name
+                          (if *auto-create-namespace-packages*
+                              (make-package (string-upcase unique-name) :nicknames `(,unique-name))
+                            (error "Cannot create package ~s" unique-name))))))
+
+(defun extend-namespaces (attributes namespaces)
+  "Given possible 'xmlns[:prefix]' attributes, extend the namespaces bindings"
+  (unless *ignore-namespaces*
+    (let (default-namespace-uri)
+      (loop :for (key . value) :in attributes
+            :do (if (string= key "xmlns")
+                    (setf default-namespace-uri value)
+                  (multiple-value-bind (prefix name)
+                      (split-identifier key)
+                    (when (string= prefix "xmlns")
+                      (let* ((uri value)
+                             (prefix name)
+                             (namespace (find-namespace uri)))
+                        (unless namespace
+                          (setf namespace (new-namespace uri prefix)))
+                        (push `(,prefix . ,namespace) namespaces))))))
+      (when default-namespace-uri
+        (let ((namespace (find-namespace default-namespace-uri)))
+          (unless namespace
+            (setf namespace (new-namespace default-namespace-uri)))
+          (push `("" . ,namespace) namespaces)))))
+  namespaces)
+
+(defun print-identifier (identifier stream &optional as-attribute)
+  "Print identifier on stream using namespace conventions"
+  (declare (ignore as-attribute) (special *namespaces*))
+  (if *ignore-namespaces*
+      (princ identifier stream)
+    (if (symbolp identifier)
+        (let ((package (symbol-package identifier))
+              (name (symbol-name identifier)))
+          (let* ((namespace (find package *known-namespaces* :key #'get-package))
+                 (prefix (or (car (find namespace *namespaces* :key #'cdr))
+                             (get-prefix namespace))))
+            (if (string= prefix "")
+                (princ name stream)
+              (format stream "~a:~a" prefix name))))
+      (princ identifier stream))))
+
+;;; the parser state
+
+(defclass xml-parser-state ()
+  ((entities :documentation "A hashtable mapping XML entity names to their replacement stings"
+	     :accessor get-entities
+	     :initarg :entities
+	     :initform (make-standard-entities))
+   (seed :documentation "The user seed object"
+	 :accessor get-seed
+	 :initarg :seed
+	 :initform nil)
+   (buffer :documentation "The main reusable character buffer"
+	   :accessor get-buffer
+	   :initform (make-extendable-string))
+   (mini-buffer :documentation "The secondary, smaller reusable character buffer"
+		:accessor get-mini-buffer
+		:initform (make-extendable-string))
+   (new-element-hook :documentation "Called when new element starts"
+		     ;; Handle the start of a new xml element with name and attributes,
+		     ;; receiving seed from previous element (sibling or parent)
+		     ;; return seed to be used for first child (content)
+                     ;; or directly to finish-element-hook
+		     :accessor get-new-element-hook
+		     :initarg :new-element-hook
+		     :initform #'(lambda (name attributes seed)
+				   (declare (ignore name attributes))
+                                   seed))
+   (finish-element-hook :documentation "Called when element ends"
+			;; Handle the end of an xml element with name and attributes,
+			;; receiving parent-seed, the seed passed to us when this element started,
+                        ;; i.e. passed to our corresponding new-element-hook
+			;; and receiving seed from last child (content)
+                        ;; or directly from new-element-hook
+			;; return final seed for this element to next element (sibling or parent)
+			:accessor get-finish-element-hook
+			:initarg :finish-element-hook
+			:initform #'(lambda (name attributes parent-seed seed)
+				      (declare (ignore name attributes parent-seed))
+                                      seed))
+   (text-hook :documentation "Called when text is found"
+	      ;; Handle text in string, found as contents,
+	      ;; receiving seed from previous element (sibling or parent),
+              ;; return final seed for this element to next element (sibling or parent)
+	      :accessor get-text-hook
+	      :initarg :text-hook
+	      :initform #'(lambda (string seed)
+			    (declare (ignore string))
+                            seed)))
+  (:documentation "The XML parser state passed along all code making up the parser"))
+
+(setf (documentation 'get-seed 'function)
+      "Get the initial user seed of an XML parser state"
+      (documentation 'get-entities 'function)
+      "Get the entities hashtable of an XML parser state"
+      (documentation 'get-new-element-hook 'function)
+      "Get the new element hook of an XML parser state"
+      (documentation 'get-finish-element-hook 'function)
+      "Get the finish element hook of an XML parser state"
+      (documentation 'get-text-hook 'function)
+      "Get the text hook of an XML parser state")
+
+#-allegro
+(setf (documentation '(setf get-seed) 'function)
+      "Set the initial user seed of an XML parser state"
+      (documentation '(setf get-entities) 'function)
+      "Set the entities hashtable of an XML parser state"
+      (documentation '(setf get-new-element-hook) 'function)
+      "Set the new element hook of an XML parser state"
+      (documentation '(setf get-finish-element-hook) 'function)
+      "Set the finish element hook of an XML parser state"
+      (documentation '(setf get-text-hook) 'function)
+      "Set the text hook of an XML parser state")
+
+(defmethod get-mini-buffer :after ((state xml-parser-state))
+  "Reset and return the reusable mini buffer"
+  (with-slots (mini-buffer) state
+    (setf (fill-pointer mini-buffer) 0)))
+
+(defmethod get-buffer :after ((state xml-parser-state))
+  "Reset and return the main reusable buffer"
+  (with-slots (buffer) state
+    (setf (fill-pointer buffer) 0)))
+
+;;; parser support
+
+(defun parse-whitespace (stream extendable-string)
+  "Read and collect XML whitespace from stream in string which is
+  destructively modified, return first non-whitespace character which
+  was peeked but not read, return #\Null on eof"
+  (declare (type (vector character) extendable-string))
+  (loop
+   (let ((char (peek-char nil stream nil #\Null)))
+     (declare (type character char))
+     (if (whitespace-char-p char)
+	 (vector-push-extend (read-char stream) extendable-string)
+       (return char)))))
+
+(defun parse-string (stream state string)
+  "Read and return an XML string from stream, delimited by either
+  single or double quotes, the stream is expected to be on the opening
+  delimiter, at the end the closing delimiter is also read, entities
+  are resolved, eof before end of string is an error"
+  (declare (type (vector character) string))
+  (let ((delimiter (read-char stream nil #\Null))
+	(char #\Null))
+    (declare (type character delimiter char))
+    (unless (or (char= delimiter #\') (char= delimiter #\"))
+      (error (parser-error "expected string delimiter" nil stream)))
+    (loop
+     (setf char (read-char stream nil #\Null))
+     (cond ((char= char #\Null) (error (parser-error "encountered eof before end of string")))
+	   ((char= char delimiter) (return))
+	   ((char= char #\&) (resolve-entity stream string (get-entities state) (get-mini-buffer state)))
+	   (t (vector-push-extend char string))))
+    string))
+
+(defun parse-text (stream state extendable-string)
+  "Read and collect XML text from stream in string which is
+  destructively modified, the text ends with a '<', which is peeked and
+  returned, entities are resolved, eof is considered an error"
+  (declare (type (vector character) extendable-string))
+  (let ((char #\Null))
+    (declare (type character char))
+    (loop
+     (setf char (peek-char nil stream nil #\Null))
+     (when (char= char #\Null) (error (parser-error "encountered unexpected eof in text")))
+     (when (char= char #\<) (return))
+     (read-char stream)
+     (if (char= char #\&)
+	 (resolve-entity stream extendable-string (get-entities state) (get-mini-buffer state))
+       (vector-push-extend char extendable-string)))
+    char))
+
+(defun parse-identifier (stream identifier)
+  "Read and returns an XML identifier from stream, positioned at the
+  start of the identifier, ending with the first non-identifier
+  character, which is peeked, the identifier is written destructively
+  into identifier which is also returned"
+  (declare (type (vector character) identifier))
+  (loop
+   (let ((char (read-char stream nil #\Null)))
+     (declare (type character char))
+     (cond ((identifier-char-p char)
+	    (vector-push-extend char identifier))
+	   (t
+            (when (char/= char #\Null) (unread-char char stream))
+	    (return identifier))))))
+
+(defun skip-comment (stream)
+  "Skip an XML comment in stream, positioned after the opening '<!--',
+  consumes the closing '-->' sequence, unexpected eof or a malformed
+  closing sequence result in a error"
+  (let ((dashes-to-read 2))
+    (loop
+     (if (zerop dashes-to-read) (return))
+     (let ((char (read-char stream nil #\Null)))
+       (declare (type character char))
+       (if (char= char #\Null)
+	   (error (parser-error "encountered unexpected eof for comment")))
+       (if (char= char #\-)
+	   (decf dashes-to-read)
+	 (setf dashes-to-read 2)))))
+  (if (char/= (read-char stream nil #\Null) #\>)
+      (error (parser-error "expected > ending comment" nil stream))))
+
+(defun read-cdata (stream state string)
+  "Reads in the CDATA and calls the callback for CDATA if it exists"
+  ;; we already read the <![CDATA[ stuff
+  ;; continue to read until we hit ]]>
+  (let ((char #\space)
+	(last-3-characters (list #\[ #\A #\T))
+	(pattern (list #\> #\] #\])))
+    (declare (type character char))
+    (loop
+     (setf char (read-char stream nil #\Null))
+     (when (char= char #\Null) (error (parser-error "encountered unexpected eof in text")))
+     (push char last-3-characters)
+     (setf (cdddr last-3-characters) nil)
+     (cond
+       ((equal last-3-characters
+	       pattern)
+	(setf (fill-pointer string)
+	      (- (fill-pointer string) 2))
+	(setf (get-seed state)
+	      (funcall (get-text-hook state)
+		       (copy-seq string)
+		       (get-seed state)))
+	(return-from read-cdata))
+       (t
+	(vector-push-extend char string))))))
+
+(defun skip-special-tag (stream state)
+  "Skip an XML special tag (comments and processing instructions) in
+  stream, positioned after the opening '<', unexpected eof is an error"
+  ;; opening < has been read, consume ? or !
+  (read-char stream)
+  (let ((char (read-char stream nil #\Null)))
+    (declare (type character char))
+    ;; see if we are dealing with a comment
+    (when (char= char #\-)
+      (setf char (read-char stream nil #\Null))
+      (when (char= char #\-)
+	(skip-comment stream)
+	(return-from skip-special-tag)))
+    ;; maybe we are dealing with CDATA?
+    (when (and (char= char #\[)
+	       (loop :for pattern :across "CDATA["
+		     :for char = (read-char stream nil #\Null)
+		     :when (char= char #\Null) :do
+		     (error (parser-error "encountered unexpected eof in cdata"))
+		     :always (char= char pattern)))
+      (read-cdata stream state (get-buffer state))
+      (return-from skip-special-tag))
+    ;; loop over chars, dealing with strings (skipping their content)
+    ;; and counting opening and closing < and > chars
+    (let ((taglevel 1)
+	  (string-delimiter #\Null))
+      (declare (type character string-delimiter))
+      (loop
+       (when (zerop taglevel) (return))
+       (setf char (read-char stream nil #\Null))
+       (when (char= char #\Null)
+	 (error (parser-error "encountered unexpected eof for special (! or ?) tag" nil stream)))
+       (if (char/= string-delimiter #\Null)
+	   ;; inside a string we only look for a closing string delimiter
+	   (when (char= char string-delimiter)
+	     (setf string-delimiter #\Null))
+	 ;; outside a string we count < and > and watch out for strings
+	 (cond ((or (char= char #\') (char= char #\")) (setf string-delimiter char))
+	       ((char= char #\<) (incf taglevel))
+	       ((char= char #\>) (decf taglevel))))))))
+
+;;; the XML parser proper
+
+(defun parse-xml-element-attributes (stream state)
+  "Parse XML element attributes from stream positioned after the tag
+  identifier, returning the attributes as an assoc list, ending at
+  either a '>' or a '/' which is peeked and also returned"
+  (declare (special *namespaces*))
+  (let ((char #\Null) attributes)
+    (declare (type character char))
+    (loop
+     ;; skip whitespace separating items
+     (setf char (skip-whitespace stream))
+     ;; start tag attributes ends with > or />
+     (when (or (char= char #\>) (char= char #\/)) (return))
+     ;; read the attribute key
+     (let ((key (let ((string (parse-identifier stream (get-mini-buffer state))))
+                  (if *ignore-namespaces*
+                      (funcall *attribute-name-parser* string)
+                      (copy-seq string)))))
+       ;; skip separating whitespace
+       (setf char (skip-whitespace stream))
+       ;; require = sign (and consume it if present)
+       (if (char= char #\=)
+	   (read-char stream)
+	 (error (parser-error "expected =" nil stream)))
+       ;; skip separating whitespace
+       (skip-whitespace stream)
+       ;; read the attribute value as a string
+       (push (cons key (let ((string (parse-string stream state (get-buffer state))))
+                         (if *ignore-namespaces*
+                             (funcall *attribute-value-parser* key string)
+                             (copy-seq string))))
+	     attributes)))
+    ;; return attributes peek char ending loop
+    (values attributes char)))
+
+(defun parse-xml-element (stream state)
+  "Parse and return an XML element from stream, positioned after the opening '<'"
+  (declare (special *namespaces*))
+  ;; opening < has been read
+  (when (char= (peek-char nil stream nil #\Null) #\!)
+    (skip-special-tag stream state)
+    (return-from parse-xml-element))
+  (let ((char #\Null) buffer open-tag parent-seed has-children)
+    (declare (type character char))
+    (setf parent-seed (get-seed state))
+    ;; read tag name (no whitespace between < and name ?)
+    (setf open-tag (copy-seq (parse-identifier stream (get-mini-buffer state))))
+    ;; tag has been read, read attributes if any
+    (multiple-value-bind (attributes peeked-char)
+	(parse-xml-element-attributes stream state)
+      (let ((*namespaces* (extend-namespaces attributes *namespaces*)))
+        (setf open-tag (resolve-identifier open-tag *namespaces*))
+        (unless *ignore-namespaces*
+          (dolist (attribute attributes)
+            (setf (car attribute) (funcall *attribute-name-parser* (car attribute))
+                  (cdr attribute) (funcall *attribute-value-parser* (car attribute) (cdr attribute)))))
+        (setf (get-seed state) (funcall (get-new-element-hook state)
+                                        open-tag attributes (get-seed state)))
+        (setf char peeked-char)
+        (when (char= char #\/)
+          ;; handle solitary tag of the form <tag .. />
+          (read-char stream)
+          (setf char (read-char stream nil #\Null))
+          (if (char= #\> char)
+              (progn
+                (setf (get-seed state) (funcall (get-finish-element-hook state)
+                                                open-tag attributes parent-seed (get-seed state)))
+                (return-from parse-xml-element))
+            (error (parser-error "expected >" nil stream))))
+        ;; consume >
+        (read-char stream)
+        (loop
+         (setf buffer (get-buffer state))
+         ;; read whitespace into buffer
+         (setf char (parse-whitespace stream buffer))
+         ;; see what ended the whitespace scan
+         (cond ((char= char #\Null) (error (parser-error "encountered unexpected eof handling ~a"
+                                                         (list open-tag))))
+               ((char= char #\<)
+                ;; consume the <
+                (read-char stream)
+                (if (char= (peek-char nil stream nil #\Null) #\/)
+                    (progn
+                      ;; handle the matching closing tag </tag> and done
+                      ;; if we read whitespace as this (leaf) element's contents, it is significant
+                      (when (and (not has-children) (plusp (length buffer)))
+                        (setf (get-seed state) (funcall (get-text-hook state)
+                                                        (copy-seq buffer) (get-seed state))))
+                      (read-char stream)
+                      (let ((close-tag (resolve-identifier (parse-identifier stream (get-mini-buffer state))
+                                                           *namespaces*)))
+                        (unless (eq open-tag close-tag)
+                          (error (parser-error "found <~a> not matched by </~a> but by <~a>"
+                                               (list open-tag open-tag close-tag) stream)))
+                        (unless (char= (read-char stream nil #\Null) #\>)
+                          (error (parser-error "expected >" nil stream)))
+                        (setf (get-seed state) (funcall (get-finish-element-hook state)
+                                                        open-tag attributes parent-seed (get-seed state))))
+                      (return))
+                  ;; handle child tag and loop, no hooks to call here
+                  ;; whitespace between child elements is skipped
+                  (progn
+                    (setf has-children t)
+                    (parse-xml-element stream state))))
+               (t
+                ;; no child tag, concatenate text to whitespace in buffer
+                ;; handle text content and loop
+                (setf char (parse-text stream state buffer))
+                (setf (get-seed state) (funcall (get-text-hook state)
+                                                (copy-seq buffer) (get-seed state))))))))))
+
+(defun start-parse-xml (stream &optional (state (make-instance 'xml-parser-state)))
+  "Parse and return a toplevel XML element from stream, using parser state"
+  (loop
+   (let ((char (skip-whitespace stream)))
+     (when (char= char #\Null) (return-from start-parse-xml))
+     ;; skip whitespace until start tag
+     (unless (char= char #\<)
+       (error (parser-error "expected <" nil stream)))
+     (read-char stream)			; consume peeked char
+     (setf char (peek-char nil stream nil #\Null))
+     (if (or (char= char #\!) (char= char #\?))
+	 ;; deal with special tags
+	 (skip-special-tag stream state)
+       (progn
+	 ;; read the main element
+	 (parse-xml-element stream state)
+	 (return-from start-parse-xml (get-seed state)))))))
+
+;;;; eof
diff --git a/third_party/lisp/s-xml/test/ant-build-file.xml b/third_party/lisp/s-xml/test/ant-build-file.xml
new file mode 100644
index 000000000000..91d78707b8a1
--- /dev/null
+++ b/third_party/lisp/s-xml/test/ant-build-file.xml
@@ -0,0 +1,252 @@
+<!-- $Id: ant-build-file.xml,v 1.1 2003/03/18 08:22:09 sven Exp $ -->
+<!-- Ant 1.2 build file -->
+
+<project name="Libretto" default="compile" basedir=".">
+
+  <!-- set global properties for this build -->
+  <property name="src" value="${basedir}/src" />
+  <property name="rsrc" value="${basedir}/rsrc" />
+  <property name="build" value="${basedir}/bin" />
+  <property name="api" value="${basedir}/api" />
+  <property name="lib" value="${basedir}/lib" />
+  <property name="junit" value="${basedir}/junit" />
+  <property name="rsrc" value="${basedir}/rsrc" />
+  
+  <target name="prepare">
+    <!-- Create the time stamp -->
+    <tstamp/>
+    <!-- Create the build directory structure used by compile -->
+    <mkdir dir="${build}" />
+    <mkdir dir="${api}" />
+    <mkdir dir="${junit}" />
+    <copy file="${rsrc}/build/build.version" tofile="${build}/build.properties"/>
+    <replace file="${build}/build.properties" token="@@@BUILD_ID@@@" value="${DSTAMP}-${TSTAMP}"/>
+  </target>
+
+  <target name="compile" depends="copy-rsrc">
+    <!-- Compile the java code from ${src} into ${build} -->
+    <javac srcdir="${src}" destdir="${build}" debug="on">
+      <classpath>
+        <fileset dir="${lib}">
+          <include name="log4j-core.jar" />
+          <include name="jaxp.jar" />
+          <include name="crimson.jar" />
+          <include name="jdom.jar" />
+          <include name="beanshell.jar" />
+        </fileset>
+      </classpath>
+    </javac>
+  </target>
+
+  <target name="compile-junit" depends="copy-rsrc">
+    <!-- Compile the java code from ${src} into ${build} -->
+    <javac srcdir="${junit}" destdir="${build}" debug="on">
+      <classpath>
+        <fileset dir="${lib}">
+          <include name="*.jar" />
+        </fileset>
+      </classpath>
+    </javac>
+  </target>
+
+  <target name="copy-rsrc" depends="prepare">
+    <!-- Copy various resource files into ${build} -->
+    <copy todir="${build}">
+      <fileset
+        dir="${basedir}"
+        includes="images/*.gif, images/*.jpg" />
+    </copy>
+    <copy todir="${build}">
+      <fileset
+        dir="${src}"
+        includes="be/beta9/libretto/data/*.txt" />
+    </copy>
+    <copy todir="${build}">
+      <fileset
+        dir="${rsrc}/log4j"
+        includes="log4j.properties" />
+    </copy>
+  </target>
+  
+  <target name="c-header" depends="compile">
+      <javah destdir="${rsrc}/VC_source" class="be.beta9.libretto.io.ParallelPort">
+         <classpath>
+            <pathelement location="${build}" />
+         </classpath>
+      </javah>
+  </target>
+  
+  <target name="test-parport" depends="compile">
+      <java
+      classname="be.beta9.libretto.io.ParallelPortWriter"
+      fork="yes">
+      <classpath>
+        <pathelement location="${build}" />
+        <fileset dir="${lib}">
+          <include name="*.jar" />
+        </fileset>
+      </classpath>
+    </java>
+  </target>
+  
+  <target name="jar-simple" depends="compile">
+    <!-- Put everything in ${build} into the a jar file -->
+    <jar
+      jarfile="${basedir}/libretto.jar"
+      basedir="${build}"
+      manifest="${rsrc}/manifest/libretto.mf"/>
+  </target>
+
+  <target name="jar" depends="compile">
+    <!-- Put everything in ${build} into the a jar file including all dependecies -->
+    <unjar src="${lib}/jaxp.jar" dest="${build}" />
+    <unjar src="${lib}/crimson.jar" dest="${build}" />
+    <unjar src="${lib}/jdom.jar" dest="${build}" />
+    <unjar src="${lib}/log4j-core.jar" dest="${build}" />
+    <jar
+      jarfile="${basedir}/libretto.jar"
+      basedir="${build}"
+      manifest="${rsrc}/manifest/libretto.mf"/>
+  </target>
+  
+  <target name="client-jar" depends="background-jar">
+    <!-- Put everything in ${build} into the a jar file including all dependecies -->
+    <unjar src="${lib}/log4j-core.jar" dest="${build}" />
+    <jar jarfile="${basedir}/libretto-client.jar" manifest="${rsrc}/manifest/libretto-client.mf">
+      <fileset dir="${build}">
+        <include name="build.properties"/>
+        <include name="log4j.properties"/>
+        <include name="be/beta9/libretto/io/*.class"/>
+        <include name="be/beta9/libretto/application/Build.class"/>
+        <include name="be/beta9/libretto/net/LibrettoTextClient*.class"/>
+        <include name="be/beta9/libretto/net/TestClientMessage.class"/>
+        <include name="be/beta9/libretto/net/ClientStatusMessageResult.class"/>
+        <include name="be/beta9/libretto/net/Client*.class"/>
+        <include name="be/beta9/libretto/net/Constants.class"/>
+        <include name="be/beta9/libretto/net/TextMessage.class"/>
+        <include name="be/beta9/libretto/net/MessageResult.class"/>
+        <include name="be/beta9/libretto/net/MessageException.class"/>
+        <include name="be/beta9/libretto/net/SingleTextMessage.class"/>
+        <include name="be/beta9/libretto/net/Message.class"/>
+        <include name="be/beta9/libretto/net/Util.class"/>
+        <include name="be/beta9/libretto/gui/ShowSingleTextFrame*.class"/>
+        <include name="be/beta9/libretto/gui/AWTTextView*.class"/>
+        <include name="be/beta9/libretto/model/AttributedString*.class"/>
+        <include name="be/beta9/libretto/model/AWTTextStyle.class"/>
+        <include name="be/beta9/libretto/model/LTextStyle.class"/>
+        <include name="be/beta9/libretto/model/AWTCharacterAttributes.class"/>
+        <include name="be/beta9/libretto/model/Java2DTextStyle.class"/>
+        <include name="be/beta9/libretto/model/LCharacterAttributes.class"/>
+        <include name="be/beta9/libretto/model/Java2DCharacterAttributes.class"/>
+        <include name="be/beta9/libretto/util/TextStyleManager.class"/>
+        <include name="be/beta9/libretto/util/Bean.class"/>
+        <include name="be/beta9/libretto/util/LibrettoSaxReader.class"/>
+        <include name="be/beta9/libretto/util/Preferences.class"/>
+        <include name="be/beta9/libretto/util/Utilities.class"/>
+        <include name="org/apache/log4j/**"/>
+      </fileset>
+    </jar>
+  </target>
+  
+  <target name="background-jar" depends="compile">
+    <!-- Put everything in ${build} into the a jar file including all dependecies -->
+    <jar jarfile="${basedir}/background.jar" manifest="${rsrc}/manifest/background-black-window.mf">
+      <fileset dir="${build}">
+        <include name="be/beta9/libretto/gui/BackgroundBlackWindow.class"/>
+      </fileset>
+    </jar>
+  </target>
+
+  <target name="run" depends="compile">
+    <!-- Execute the main application -->
+    <java
+      classname="be.beta9.libretto.application.Libretto"
+      fork="yes">
+      <classpath>
+        <pathelement location="${build}" />
+        <fileset dir="${lib}">
+          <include name="log4j-core.jar" />
+          <include name="jaxp.jar" />
+          <include name="crimson.jar" />
+          <include name="jdom.jar" />
+        </fileset>
+      </classpath>
+    </java>
+  </target>
+
+  <target name="debug" depends="compile">
+    <!-- Execute the main application in debug mode -->
+    <java
+      classname="be.beta9.libretto.application.LibrettoDebug"
+      fork="yes">
+      <classpath>
+        <pathelement location="${build}" />
+        <fileset dir="${lib}">
+          <include name="*.jar" />
+        </fileset>
+      </classpath>
+    </java>
+  </target>
+
+  <target name="junit" depends="compile-junit">
+    <!-- Execute all junit tests -->
+    <java
+      classname="be.beta9.libretto.AllTests"
+      fork="yes">
+      <classpath>
+        <pathelement location="${build}" />
+        <fileset dir="${lib}">
+          <include name="*.jar" />
+        </fileset>
+      </classpath>
+    </java>
+  </target>
+
+  <target name="clean">
+    <!-- Delete the ${build} directory trees -->
+    <delete dir="${build}" />
+    <delete dir="${api}" />
+  </target>
+  
+  <target name="api" depends="prepare">
+    <!-- Generate javadoc -->
+    <javadoc
+      packagenames="be.beta9.libretto.*"
+      sourcepath="${src}"
+      destdir="${api}"
+      windowtitle="Libretto"
+      author="true"
+      version="true"
+      use="true"/>
+  </target>
+  
+  <target name="zip-all" depends="jar, client-jar">
+    <zip zipfile="libretto.zip">
+    <fileset dir="${basedir}">
+      <include name="libretto.jar"/>
+      <include name="libretto-client.jar"/>
+        </fileset>
+    </zip>
+  </target>
+
+  <target name="upload" depends="clean, zip-all">
+    <ftp
+      server="users.pandora.be"
+      userid="a002458"
+      password="bast0s"
+      remotedir="libretto"
+      verbose="true"
+      passive="true">
+        <fileset dir="${basedir}">
+        <include name="libretto.jar" />
+        <include name="libretto-client.jar" />
+        <include name="libretto.zip" />
+    </fileset>
+    </ftp>
+  </target>
+
+</project>
+
+
+
+
diff --git a/third_party/lisp/s-xml/test/plist.xml b/third_party/lisp/s-xml/test/plist.xml
new file mode 100644
index 000000000000..910e6326ea63
--- /dev/null
+++ b/third_party/lisp/s-xml/test/plist.xml
@@ -0,0 +1,38 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple Computer//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+	<key>AppleDockIconEnabled</key>
+	<true/>
+	<key>AppleNavServices:GetFile:0:Path</key>
+	<string>file://localhost/Users/sven/Pictures/</string>
+	<key>AppleNavServices:GetFile:0:Position</key>
+	<data>
+	AOUBXw==
+	</data>
+	<key>AppleNavServices:GetFile:0:Size</key>
+	<data>
+	AAAAAAFeAcI=
+	</data>
+	<key>AppleNavServices:PutFile:0:Disclosure</key>
+	<data>
+	AQ==
+	</data>
+	<key>AppleNavServices:PutFile:0:Path</key>
+	<string>file://localhost/Users/sven/Desktop/</string>
+	<key>AppleNavServices:PutFile:0:Position</key>
+	<data>
+	AUIBVQ==
+	</data>
+	<key>AppleNavServices:PutFile:0:Size</key>
+	<data>
+	AAAAAACkAdY=
+	</data>
+	<key>AppleSavePanelExpanded</key>
+	<string>YES</string>
+	<key>NSDefaultOpenDirectory</key>
+	<string>~/Desktop</string>
+	<key>NSNoBigString</key>
+	<true/>
+</dict>
+</plist>
diff --git a/third_party/lisp/s-xml/test/simple.xml b/third_party/lisp/s-xml/test/simple.xml
new file mode 100644
index 000000000000..08ad9424e3ae
--- /dev/null
+++ b/third_party/lisp/s-xml/test/simple.xml
@@ -0,0 +1,5 @@
+<?xml version="1.0"?>
+<!-- This is a very simple XML document -->
+<root id="123">
+  <text>Hello World!</text>
+</root>
diff --git a/third_party/lisp/s-xml/test/test-lxml-dom.lisp b/third_party/lisp/s-xml/test/test-lxml-dom.lisp
new file mode 100644
index 000000000000..248e1e4b907f
--- /dev/null
+++ b/third_party/lisp/s-xml/test/test-lxml-dom.lisp
@@ -0,0 +1,86 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: test-lxml-dom.lisp,v 1.2 2005/11/06 12:44:48 scaekenberghe Exp $
+;;;;
+;;;; Unit and functional tests for lxml-dom.lisp
+;;;;
+;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :s-xml)
+
+(assert
+ (equal (with-input-from-string (stream " <foo/>")
+	  (parse-xml stream :output-type :lxml))
+	:|foo|))
+
+(assert
+ (equal (parse-xml-string "<tag1><tag2 att1='one'/>this is some text</tag1>"
+			  :output-type :lxml)
+	'(:|tag1|
+	   ((:|tag2| :|att1| "one"))
+	   "this is some text")))
+
+(assert
+ (equal (parse-xml-string "<TAG>&lt;foo&gt;</TAG>"
+			  :output-type :lxml)
+	'(:TAG "<foo>")))
+
+(assert
+ (equal (parse-xml-string
+	 "<P><INDEX ITEM='one'/> This is some <B>bold</B> text, with a leading &amp; trailing space </P>"
+	 :output-type :lxml)
+	'(:p
+	  ((:index :item "one"))
+	  " This is some "
+	  (:b "bold")
+	  " text, with a leading & trailing space ")))
+
+(assert
+ (consp (parse-xml-file (merge-pathnames "test/xhtml-page.xml"
+					 (asdf:component-pathname
+					  (asdf:find-system :s-xml.test)))
+			:output-type :lxml)))
+
+(assert
+ (consp (parse-xml-file (merge-pathnames "test/ant-build-file.xml"
+					 (asdf:component-pathname
+					  (asdf:find-system :s-xml.test)))
+			:output-type :lxml)))
+
+(assert
+ (consp (parse-xml-file (merge-pathnames "test/plist.xml"
+					 (asdf:component-pathname
+					  (asdf:find-system :s-xml.test)))
+			:output-type :lxml)))
+
+(assert
+ (string-equal (print-xml-string :|foo| :input-type :lxml)
+	       "<foo/>"))
+
+(assert
+ (string-equal (print-xml-string '((:|foo| :|bar| "1")) :input-type :lxml)
+	       "<foo bar=\"1\"/>"))
+
+(assert
+ (string-equal (print-xml-string '(:foo "some text") :input-type :lxml)
+	       "<FOO>some text</FOO>"))
+
+(assert
+ (string-equal (print-xml-string '(:|foo| :|bar|) :input-type :lxml)
+	       "<foo><bar/></foo>"))
+
+(assert (string-equal (second
+                       (with-input-from-string (stream "<foo><![CDATA[<greeting>Hello, world!</greeting>]]></foo>")
+                         (parse-xml stream :output-type :lxml)))
+                      "<greeting>Hello, world!</greeting>"))
+	   
+(assert (string-equal (second
+                       (with-input-from-string (stream "<foo><![CDATA[<greeting>Hello, < world!</greeting>]]></foo>")
+                         (parse-xml stream :output-type :lxml)))
+                      "<greeting>Hello, < world!</greeting>"))
+
+;;;; eof
diff --git a/third_party/lisp/s-xml/test/test-sxml-dom.lisp b/third_party/lisp/s-xml/test/test-sxml-dom.lisp
new file mode 100644
index 000000000000..7164d5ef0d66
--- /dev/null
+++ b/third_party/lisp/s-xml/test/test-sxml-dom.lisp
@@ -0,0 +1,76 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: test-sxml-dom.lisp,v 1.1.1.1 2004/06/07 18:49:59 scaekenberghe Exp $
+;;;;
+;;;; Unit and functional tests for sxml-dom.lisp
+;;;;
+;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :s-xml)
+
+(assert
+ (equal (with-input-from-string (stream " <foo/>")
+	  (parse-xml stream :output-type :sxml))
+	'(:|foo|)))
+
+(assert
+ (equal (parse-xml-string "<tag1><tag2 att1='one'/>this is some text</tag1>"
+			  :output-type :sxml)
+	'(:|tag1|
+	   (:|tag2| (:@ (:|att1| "one")))
+	   "this is some text")))
+
+(assert
+ (equal (parse-xml-string "<TAG>&lt;foo&gt;</TAG>"
+			  :output-type :sxml)
+	'(:TAG "<foo>")))
+
+(assert
+ (equal (parse-xml-string
+	 "<P><INDEX ITEM='one'/> This is some <B>bold</B> text, with a leading &amp; trailing space </P>"
+	 :output-type :sxml)
+	'(:p
+	  (:index (:@ (:item "one")))
+	  " This is some "
+	  (:b "bold")
+	  " text, with a leading & trailing space ")))
+
+(assert
+ (consp (parse-xml-file (merge-pathnames "test/xhtml-page.xml"
+					 (asdf:component-pathname
+					  (asdf:find-system :s-xml.test)))
+			:output-type :sxml)))
+
+(assert
+ (consp (parse-xml-file (merge-pathnames "test/ant-build-file.xml"
+					 (asdf:component-pathname
+					  (asdf:find-system :s-xml.test)))
+			:output-type :sxml)))
+
+(assert
+ (consp (parse-xml-file (merge-pathnames "test/plist.xml"
+					 (asdf:component-pathname
+					  (asdf:find-system :s-xml.test)))
+			:output-type :sxml)))
+
+(assert
+ (string-equal (print-xml-string '(:|foo|) :input-type :sxml)
+	       "<foo/>"))
+
+(assert
+ (string-equal (print-xml-string '(:|foo| (:@ (:|bar| "1"))) :input-type :sxml)
+	       "<foo bar=\"1\"/>"))
+
+(assert
+ (string-equal (print-xml-string '(:foo "some text") :input-type :sxml)
+	       "<FOO>some text</FOO>"))
+
+(assert
+ (string-equal (print-xml-string '(:|foo| (:|bar|)) :input-type :sxml)
+	       "<foo><bar/></foo>"))
+
+;;;; eof
\ No newline at end of file
diff --git a/third_party/lisp/s-xml/test/test-xml-struct-dom.lisp b/third_party/lisp/s-xml/test/test-xml-struct-dom.lisp
new file mode 100644
index 000000000000..f5ee1cc92583
--- /dev/null
+++ b/third_party/lisp/s-xml/test/test-xml-struct-dom.lisp
@@ -0,0 +1,84 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: test-xml-struct-dom.lisp,v 1.2 2005/08/29 15:01:49 scaekenberghe Exp $
+;;;;
+;;;; Unit and functional tests for xml-struct-dom.lisp
+;;;;
+;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :s-xml)
+
+(assert
+ (xml-equal (with-input-from-string (stream " <foo/>")
+	      (parse-xml stream :output-type :xml-struct))
+	    (make-xml-element :name :|foo|)))
+
+(assert
+ (xml-equal (parse-xml-string "<tag1><tag2 att1='one'/>this is some text</tag1>"
+			      :output-type :xml-struct)
+	    (make-xml-element :name :|tag1|
+			      :children (list (make-xml-element :name :|tag2|
+								:attributes '((:|att1| . "one")))
+					      "this is some text"))))
+
+(assert
+ (xml-equal (parse-xml-string "<tag>&lt;foo&gt;</tag>"
+			      :output-type :xml-struct)
+	    (make-xml-element :name :|tag|
+			      :children (list "<foo>"))))
+
+(assert
+ (xml-equal (parse-xml-string
+	     "<P><INDEX ITEM='one'/> This is some <B>bold</B> text, with a leading &amp; trailing space </P>"
+	     :output-type :xml-struct)
+	    (make-xml-element :name :p
+			      :children (list (make-xml-element :name :index
+								:attributes '((:item . "one")))
+					      " This is some "
+					      (make-xml-element :name :b
+								:children (list "bold"))
+					      " text, with a leading & trailing space "))))
+
+(assert
+ (xml-element-p (parse-xml-file (merge-pathnames "test/xhtml-page.xml"
+						 (asdf:component-pathname
+						  (asdf:find-system :s-xml.test)))
+				:output-type :xml-struct)))
+
+(assert
+ (xml-element-p (parse-xml-file (merge-pathnames "test/ant-build-file.xml"
+						 (asdf:component-pathname
+						  (asdf:find-system :s-xml.test)))
+				:output-type :xml-struct)))
+
+(assert
+ (xml-element-p (parse-xml-file (merge-pathnames "test/plist.xml"
+						 (asdf:component-pathname
+						  (asdf:find-system :s-xml.test)))
+				:output-type :xml-struct)))
+
+(assert
+ (string-equal (print-xml-string (make-xml-element :name "foo")
+				 :input-type :xml-struct)
+	       "<foo/>"))
+
+(assert
+ (string-equal (print-xml-string (make-xml-element :name "foo" :attributes '((:|bar| . "1")))
+				 :input-type :xml-struct)
+	       "<foo bar=\"1\"/>"))
+
+(assert
+ (string-equal (print-xml-string (make-xml-element :name "foo" :children (list "some text"))
+				 :input-type :xml-struct)
+	       "<foo>some text</foo>"))
+
+(assert
+ (string-equal (print-xml-string (make-xml-element :name "foo" :children (list (make-xml-element :name "bar")))
+				 :input-type :xml-struct)
+	       "<foo><bar/></foo>"))
+
+;;;; eof
\ No newline at end of file
diff --git a/third_party/lisp/s-xml/test/test-xml.lisp b/third_party/lisp/s-xml/test/test-xml.lisp
new file mode 100644
index 000000000000..daef58ea4639
--- /dev/null
+++ b/third_party/lisp/s-xml/test/test-xml.lisp
@@ -0,0 +1,86 @@
+;;;; -*- mode: lisp -*-
+;;;;
+;;;; $Id: test-xml.lisp,v 1.3 2005/11/06 12:44:48 scaekenberghe Exp $
+;;;;
+;;;; Unit and functional tests for xml.lisp
+;;;;
+;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :s-xml)
+
+(assert
+ (whitespace-char-p (character " ")))
+
+(assert
+ (whitespace-char-p (character "	")))
+
+(assert
+ (whitespace-char-p (code-char 10)))
+
+(assert
+ (whitespace-char-p (code-char 13)))
+
+(assert
+ (not (whitespace-char-p #\A)))
+
+(assert
+ (char= (with-input-from-string (stream "  ABC")
+	  (skip-whitespace stream))
+	#\A))
+
+(assert
+ (char= (with-input-from-string (stream "ABC")
+	  (skip-whitespace stream))
+	#\A))
+
+(assert
+ (string-equal (with-output-to-string (stream) (print-string-xml "<foo>" stream))
+	       "&lt;foo&gt;"))
+
+(assert
+ (string-equal (with-output-to-string (stream) (print-string-xml "' '" stream))
+               "' '"))
+
+(assert
+ (let ((string (map 'string #'identity '(#\return #\tab #\newline))))
+   (string-equal (with-output-to-string (stream) (print-string-xml string stream))
+                 string)))
+
+(defun simple-echo-xml (in out)
+  (start-parse-xml
+   in
+   (make-instance 'xml-parser-state
+		  :new-element-hook #'(lambda (name attributes seed)
+					(declare (ignore seed))
+					(format out "<~a~:{ ~a='~a'~}>"
+						name
+						(mapcar #'(lambda (p) (list (car p) (cdr p)))
+							(reverse attributes))))
+		  :finish-element-hook #'(lambda (name attributes parent-seed seed)
+					   (declare (ignore attributes parent-seed seed))
+					   (format out "</~a>" name))
+		  :text-hook #'(lambda (string seed)
+				 (declare (ignore seed))
+				 (princ string out)))))
+
+(defun simple-echo-xml-string (string)
+  (with-input-from-string (in string)
+      (with-output-to-string (out)
+	(simple-echo-xml in out))))
+
+(dolist (*ignore-namespaces* '(nil t)) 
+  (assert
+ (let ((xml "<FOO ATT1='1' ATT2='2'><B>Text</B><EMPTY></EMPTY>More text!<SUB><SUB></SUB></SUB></FOO>"))
+   (equal (simple-echo-xml-string xml)
+            xml))))
+
+(assert 
+  (let ((xml "<p> </p>"))
+    (equal (simple-echo-xml-string xml)
+           xml)))
+
+;;;; eof
\ No newline at end of file
diff --git a/third_party/lisp/s-xml/test/xhtml-page.xml b/third_party/lisp/s-xml/test/xhtml-page.xml
new file mode 100644
index 000000000000..79f3ae3bade6
--- /dev/null
+++ b/third_party/lisp/s-xml/test/xhtml-page.xml
@@ -0,0 +1,271 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">

+

+<html>

+<head>

+

+<title>XHTML Tutorial</title>

+<meta http-equiv="Content-Type" content="text/html; charset=windows-1252" />

+<meta name="Keywords" content="XML,tutorial,HTML,DHTML,CSS,XSL,XHTML,JavaScript,ASP,ADO,VBScript,DOM,authoring,programming,learning,beginner's guide,primer,lessons,school,howto,reference,examples,samples,source code,demos,tips,links,FAQ,tag list,forms,frames,color table,W3C,Cascading Style Sheets,Active Server Pages,Dynamic HTML,Internet database development,Webbuilder,Sitebuilder,Webmaster,HTMLGuide,SiteExpert" />

+<meta name="Description" content="HTML,CSS,JavaScript,DHTML,XML,XHTML,ASP,ADO and VBScript tutorial from W3Schools." />

+<meta http-equiv="pragma" content="no-cache" />

+<meta http-equiv="cache-control" content="no-cache" />

+

+<link rel="stylesheet" type="text/css" href="../stdtheme.css" />

+

+</head>

+<body>

+

+<table border="0" cellpadding="0" cellspacing="0" width="775">

+<tr>

+<td width="140" class="content" valign="top">

+<br />

+<a class="left" href="../default.asp" target="_top"><b>HOME</b></a><br />

+<br />

+<b>XHTML Tutorial</b><br />

+<a class="left" target="_top" href="default.asp" style='font-weight:bold;color:#000000;background-color:transparent;'>XHTML HOME</a><br />

+<a class="left" target="_top" href="xhtml_intro.asp" >XHTML Introduction</a><br />

+<a class="left" target="_top" href="xhtml_why.asp" >XHTML Why</a><br />

+<a class="left" target="_top" href="xhtml_html.asp" >XHTML v HTML</a><br />

+<a class="left" target="_top" href="xhtml_syntax.asp" >XHTML Syntax</a><br />

+<a class="left" target="_top" href="xhtml_dtd.asp" >XHTML DTD</a><br />

+<a class="left" target="_top" href="xhtml_howto.asp" >XHTML HowTo</a><br />

+<a class="left" target="_top" href="xhtml_validate.asp" >XHTML Validation</a><br />

+<br />

+<b>Quiz</b>

+<br />

+<a class="left" target="_top" href="xhtml_quiz.asp" >XHTML Quiz</a><br />

+<br />

+<b>References</b>

+<br />

+<a class="left" target="_top" href="xhtml_reference.asp" >XHTML Tag List</a><br />

+<a class="left" target="_top" href="xhtml_standardattributes.asp" >XHTML Attributes</a><br />

+<a class="left" target="_top" href="xhtml_eventattributes.asp" >XHTML Events</a><br />

+</td>

+<td width="490" valign="top">

+<table width="100%" bgcolor="#FFFFFF" border="1" cellpadding="7" cellspacing="0">

+<tr>

+<td>

+<center>

+<a href="http://ad.doubleclick.net/jump/N1951.w3schools/B1097963;sz=468x60;ord=[timestamp]?" target="_new">

+<img src="http://ad.doubleclick.net/ad/N1951.w3schools/B1097963;sz=468x60;ord=[timestamp]?" 

+border="0" width="468" height="60" alt="Corel XMetal 3" /></a>

+

+

+<br />Please Visit Our Sponsors !

+</center>

+<h1>XHTML Tutorial</h1>

+<a href="../default.asp"><img border="0" src="../images/btn_previous.gif" alt="Previous" /></a>

+<a href="xhtml_intro.asp"><img border="0" src="../images/btn_next.gif" width="100" height="20" alt="Next" /></a>

+

+<hr />

+

+<h2>XHTML Tutorial</h2>

+<p>XHTML is the next generation of HTML! In our XHTML tutorial you will learn the difference between HTML and XHTML, and how to use XHTML in your future

+applications. You will also see how we converted this Web site into XHTML. <a href="xhtml_intro.asp">Start&nbsp;Learning

+XHTML!</a></p>

+

+<h2>XHTML Quiz Test</h2>

+<p>Test your XHTML skills at W3Schools! <a href="xhtml_quiz.asp">Start XHTML

+Quiz!</a>&nbsp;</p>

+

+<h2>XHTML References</h2>

+<p>At W3Schools you will find complete XHTML references about tags, attributes

+and events. <a href="xhtml_reference.asp">XHTML 1.0 References</a>.</p>

+<hr />

+<h2>Table of Contents</h2>

+<p><a href="xhtml_intro.asp">Introduction to XHTML</a><br />

+This chapter gives a brief introduction to XHTML and explains what XHTML is.</p>

+<p><a href="xhtml_why.asp">XHTML - Why?</a><br />

+This chapter explains why we needed a new language like XHTML.</p>

+<p><a href="xhtml_html.asp">Differences between XHTML and HTML</a><br />

+This chapter explains the main differences in syntax between XHTML and HTML.</p>

+<p><a href="xhtml_syntax.asp">XHTML Syntax</a>&nbsp;<br />

+This chapter explains the basic syntax of XHTML.</p>

+<p><a href="xhtml_dtd.asp">XHTML DTD</a>&nbsp;<br />

+This chapter explains the three different XHTML Document Type Definitions.</p>

+<p><a href="xhtml_howto.asp">XHTML HowTo</a><br />

+This chapter explains how this web site was converted from HTML to XHTML.</p>

+<p><a href="xhtml_validate.asp">XHTML Validation</a><br />

+This chapter explains how to validate XHTML documents.</p>

+<hr />

+<h2>XHTML References</h2>

+<p><a href="xhtml_reference.asp">XHTML 1.0 Reference<br />

+</a>Our complete XHTML 1.0 reference is an alphabetical list of all XHTML tags

+with lots of&nbsp; examples and tips.</p>

+<p><a href="xhtml_standardattributes.asp">XHTML 1.0 Standard Attributes<br />

+</a>All the tags have attributes. The attributes for each tag are listed in the

+examples in the &quot;XHTML 1.0 Reference&quot; page. The attributes listed here

+are the core and language attributes all the tags has as standard (with

+few exceptions). This reference describes the attributes, and shows possible

+values for each.</p>

+<p><a href="xhtml_eventattributes.asp">XHTML 1.0 Event Attributes<br />

+</a>All the standard event attributes of the tags. This reference describes the attributes, and shows possible

+values for each.</p>

+<hr />

+<a href="../default.asp"><img border="0" src="../images/btn_previous.gif" width="100" height="20" alt="Previous" /></a>

+<a href="xhtml_intro.asp"><img border="0" src="../images/btn_next.gif" width="100" height="20" alt="Next" /></a>

+

+

+<hr />

+<p>

+Jump to: <a href="#top" target="_top"><b>Top of Page</b></a>

+or <a href="/" target="_top"><b>HOME</b></a> or

+<a href='/xhtml/default.asp?output=print' target="_blank">

+<img src="../images/print.gif" alt="Printer Friendly" border="0" />

+<b>Printer friendly page</b></a>

+</p>

+<hr />

+

+<h2>Search W3Schools:</h2>

+<form method="get" name="searchform" action="http://www.google.com/search" target="_blank">

+<input type="hidden" name="as_sitesearch" value="www.w3schools.com" />

+<input type="text" size="30" name="as_q" />

+<input type="submit" value=" Go! " />

+</form>

+

+<hr />

+<h2>What Others Say About Us</h2>

+<p>Does the world know about us? Check out these places:</p>

+<p>

+<a href="http://search.dogpile.com/texis/search?q=W3schools" target="_blank">Dogpile</a>

+<a href="http://www.altavista.com/cgi-bin/query?q=W3Schools" target="_blank">Alta Vista</a>

+<a href="http://search.msn.com/results.asp?q=W3Schools" target="_blank">MSN</a>

+<a href="http://www.google.com/search?q=W3Schools" target="_blank">Google</a>

+<a href="http://search.excite.com/search.gw?search=W3Schools" target="_blank">Excite</a>

+<a href="http://search.lycos.com/main/?query=W3Schools" target="_blank">Lycos</a>

+<a href="http://search.yahoo.com/search?p=w3schools" target="_blank">Yahoo</a>

+<a href="http://www.ask.com/main/askJeeves.asp?ask=W3Schools" target="_blank">Ask Jeeves</a>

+</p>

+<hr />

+<h2>We Help You For Free. You Can Help Us!</h2>

+<ul>

+<li><a href="../tellyourgroup.htm" target="blank">Tell your newsgroup or mailing list</a></li>

+<li><a href="../about/about_linking.asp">Link to us from your pages</a></li>

+<li><a href="../about/about_helpers.asp">Help us correct errors and broken links</a></li>

+<li><a href="../about/about_helpers.asp">Help us with spelling and grammar</a></li>

+<li><a href="http://validator.w3.org/check/referer" target="_blank">Validate the XHTML code of this page</a></li>

+</ul>

+

+<hr />

+<p>

+W3Schools is for training only. We do not warrant its correctness or its fitness for use.

+The risk of using it remains entirely with the user. While using this site, you agree to have read and accepted our

+<a href="../about/about_copyright.asp">terms of use</a> and 

+<a href="../about/about_privacy.asp">privacy policy</a>.</p>

+<p>

+<a href="../about/about_copyright.asp">Copyright 1999-2002</a> by Refsnes Data. All Rights Reserved</p>

+<hr />

+<table border="0" width="100%" cellspacing="0" cellpadding="0"><tr>

+<td width="25%" align="left">

+<a href="http://validator.w3.org/check/referer" target="_blank">

+<img src="../images/vxhtml.gif" alt="Validate" width="88" height="31" border="0" /></a>

+</td>

+<td width="50%" align="center">

+<a href="../xhtml/" target="_top">How we converted to XHTML</a>

+</td>

+<td width="25%" align="right">

+<a href="http://jigsaw.w3.org/css-validator/check/referer" target="_blank">

+<img src="../images/vcss.gif" alt="Validate" width="88" height="31" border="0" /></a>

+</td>

+</tr></table>

+</td>

+</tr>

+</table>

+</td>

+

+

+ 

+<td width="144" align="center" valign="top">

+

+<table border="1" width="100%" bgcolor="#ffffff" cellpadding="0" cellspacing="0"><tr>

+<td align="center" class="right"><br />

+

+<a href="http://www.dotnetcharting.com" target="_blank"><img src="../images/dnc-icon.gif" alt="Web charting" border="0" /></a>

+<br />

+<a class="right" href="http://www.dotnetcharting.com" target="_blank">Web based charting<br />for ASP.NET</a>

+

+<br /><br />

+</td></tr></table>

+

+<table border="1" width="100%" bgcolor="#ffffff" cellpadding="0" cellspacing="0"><tr>

+<td align="center" class="right">

+<br />

+<a href="../hosting/default.asp">

+Your own Web Site?<br />

+<br />Read W3Schools

+<br />Hosting Tutorial</a>

+<br />

+<br />

+</td></tr></table>

+

+<table border="1" width="100%" bgcolor="#ffffff" cellpadding="0" cellspacing="0"><tr>

+<td align="center" class="right">

+<br />

+<a class="red" href="http://www.dotdnr.com" target="_blank">$15 Domain Name<br />Registration<br />Save $20 / year!</a>

+<br />

+<br />

+</td></tr></table>

+

+

+

+<table border="1" width="100%" bgcolor="#ffffff" cellpadding="0" cellspacing="0">

+<tr><td align="center" class="right">

+<br />

+<b>SELECTED LINKS</b>

+<br /><br />

+<a class="right" href="http://opogee.com/clk/dangtingcentiaonie" target="_blank">University Online<br />

+Master Degree<br />Bachelor Degree</a>

+<br /><br />

+<a class="right" href="../software/default.asp" target="_top">Web Software</a>

+<br /><br />

+<a class="right" href="../appml/default.asp" target="_top">The Future of<br />Web Development</a>

+<br /><br />

+<a class="right" href="../careers/default.asp" target="_top">Jobs and Careers</a>

+<br /><br />

+<a class="right" href="../site/site_security.asp" target="_top">Web Security</a>

+<br />

+<a class="right" href="../browsers/browsers_stats.asp" target="_top">Web Statistics</a>

+<br />

+<a class="right" href="../w3c" target="_top">Web Standards</a>

+<br /><br />

+</td></tr></table>

+

+

+<table border="1" width="100%" bgcolor="#ffffff" cellpadding="0" cellspacing="0"><tr>

+<td align="center" class="right">

+<br />

+

+<b>Recommended<br />

+Reading:</b><br /><br />

+

+<a class="right" target="_blank"

+href="http://www.amazon.com/exec/obidos/ASIN/059600026X/w3schools03">

+<img src="../images/book_amazon_xhtml.jpg" border="0" alt="HTML XHTML" /></a>

+

+

+<br /><br /></td>

+</tr></table>

+

+<table border="1" width="100%" bgcolor="#ffffff" cellpadding="0" cellspacing="0"><tr>

+<td align="center" class="right">

+<br />

+<b>PARTNERS</b><br />

+<br />

+<a class="right" href="http://www.W3Schools.com" target="_blank">W3Schools</a><br />

+<a class="right" href="http://www.topxml.com" target="_blank">TopXML</a><br />

+<a class="right" href="http://www.visualbuilder.com" target="_blank">VisualBuilder</a><br />

+<a class="right" href="http://www.xmlpitstop.com" target="_blank">XMLPitstop</a><br />

+<a class="right" href="http://www.developersdex.com" target="_blank">DevelopersDex</a><br />

+<a class="right" href="http://www.devguru.com" target="_blank">DevGuru</a><br />

+<a class="right" href="http://www.programmersheaven.com/" target="_blank">Programmers Heaven</a><br />

+<a class="right" href="http://www.codeproject.com" target="_blank">The Code Project</a><br />

+<a class="right" href="http://www.tek-tips.com" target="_blank">Tek Tips Forum</a><br />

+<a class="right" href="http://www.zvon.ORG/" target="_blank">ZVON.ORG</a><br />

+<a class="right" href="http://www.topxml.com/search.asp" target="_blank">TopXML Search</a><br />

+<br />

+</td>

+</tr></table>

+</td></tr></table>

+

+</body>

+</html>

diff --git a/third_party/lisp/split-sequence.nix b/third_party/lisp/split-sequence.nix
new file mode 100644
index 000000000000..105646386fd3
--- /dev/null
+++ b/third_party/lisp/split-sequence.nix
@@ -0,0 +1,18 @@
+# split-sequence is a library for, well, splitting sequences apparently.
+{ depot, ... }:
+
+let src = builtins.fetchGit {
+  url = "https://github.com/sharplispers/split-sequence.git";
+  rev = "41c0fc79a5a2871d16e5727969a8f699ef44d791";
+};
+in depot.nix.buildLisp.library {
+  name = "split-sequence";
+  srcs = map (f: src + ("/" + f)) [
+    "package.lisp"
+    "vector.lisp"
+    "list.lisp"
+    "extended-sequence.lisp"
+    "api.lisp"
+    "documentation.lisp"
+  ];
+}
diff --git a/third_party/lisp/trivial-backtrace/.gitignore b/third_party/lisp/trivial-backtrace/.gitignore
new file mode 100644
index 000000000000..391b10e5db65
--- /dev/null
+++ b/third_party/lisp/trivial-backtrace/.gitignore
@@ -0,0 +1,15 @@
+# really this is private to my build process
+make/
+common-lisp.net
+.vcs
+GNUmakefile
+init-lisp.lisp
+website/changelog.xml
+
+
+trivial-backtrace.tar.gz
+website/output/
+test-results/
+lift-local.config
+*.dribble
+*.fasl
diff --git a/third_party/lisp/trivial-backtrace/COPYING b/third_party/lisp/trivial-backtrace/COPYING
new file mode 100644
index 000000000000..3798a6664a3d
--- /dev/null
+++ b/third_party/lisp/trivial-backtrace/COPYING
@@ -0,0 +1,25 @@
+Copyright (c) 2008-2008 Gary Warren King (gwking@metabang.com) 
+
+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. 
+
+
+
+Copyright (c) 2005-2007 Dr. Edi Weitz 
+
+BSD style license: http://www.opensource.org/licenses/bsd-license.php
diff --git a/third_party/lisp/trivial-backtrace/default.nix b/third_party/lisp/trivial-backtrace/default.nix
new file mode 100644
index 000000000000..bdd057cade27
--- /dev/null
+++ b/third_party/lisp/trivial-backtrace/default.nix
@@ -0,0 +1,14 @@
+# Imported from http://common-lisp.net/project/trivial-backtrace/trivial-backtrace.git
+{ depot, ... }:
+
+depot.nix.buildLisp.library {
+  name = "trivial-backtrace";
+
+  srcs = [
+    ./dev/packages.lisp
+    ./dev/utilities.lisp
+    ./dev/backtrace.lisp
+    ./dev/map-backtrace.lisp
+    ./dev/fallback.lisp
+  ];
+}
diff --git a/third_party/lisp/trivial-backtrace/dev/backtrace.lisp b/third_party/lisp/trivial-backtrace/dev/backtrace.lisp
new file mode 100644
index 000000000000..aa3951e30f9f
--- /dev/null
+++ b/third_party/lisp/trivial-backtrace/dev/backtrace.lisp
@@ -0,0 +1,127 @@
+(in-package #:trivial-backtrace)
+
+(defun print-condition (condition stream)
+  "Print `condition` to `stream` using the pretty printer."
+  (format
+   stream
+   "~@<An unhandled error condition has been signalled:~3I ~a~I~:@>~%~%"
+   condition))
+  
+(defun print-backtrace (error &key (output *debug-io*)
+			(if-exists :append)
+			(verbose nil))
+  "Send a backtrace for the error `error` to `output`. 
+
+The keywords arguments are:
+
+ * :output - where to send the output. This can be:
+
+     * a string (which is assumed to designate a pathname)
+     * an open stream
+     * nil to indicate that the backtrace information should be 
+       returned as a string
+
+ * if-exists - what to do if output designates a pathname and 
+   the pathname already exists. Defaults to :append.
+
+ * verbose - if true, then a message about the backtrace is sent
+   to \\*terminal-io\\*. Defaults to `nil`.
+
+If the `output` is nil, the returns the backtrace output as a
+string. Otherwise, returns nil.
+"
+  (when verbose
+    (print-condition error *terminal-io*))
+  (multiple-value-bind (stream close?)
+      (typecase output
+	(null (values (make-string-output-stream) nil))
+	(string (values (open output :if-exists if-exists
+			      :if-does-not-exist :create
+			      :direction :output) t))
+	(stream (values output nil)))
+    (unwind-protect
+	 (progn
+	   (format stream "~&Date/time: ~a" (date-time-string))
+	   (print-condition error stream)
+	   (terpri stream)
+	   (print-backtrace-to-stream stream)
+	   (terpri stream)
+	   (when (typep stream 'string-stream)
+	     (get-output-stream-string stream)))
+	 ;; cleanup
+	 (when close?
+	   (close stream)))))
+
+#+(or mcl ccl)
+(defun print-backtrace-to-stream (stream)
+  (let ((*debug-io* stream))
+    (ccl:print-call-history :detailed-p nil)))
+
+#+allegro
+(defun print-backtrace-to-stream (stream)
+  (with-standard-io-syntax
+    (let ((*print-readably* nil)
+	  (*print-miser-width* 40)
+	  (*print-pretty* t)
+	  (tpl:*zoom-print-circle* t)
+	  (tpl:*zoom-print-level* nil)
+	  (tpl:*zoom-print-length* nil))
+      (cl:ignore-errors
+       (let ((*terminal-io* stream)
+	     (*standard-output* stream))
+	 (tpl:do-command "zoom"
+	   :from-read-eval-print-loop nil
+	   :count t
+	   :all t))))))
+
+#+lispworks
+(defun print-backtrace-to-stream (stream)
+  (let ((dbg::*debugger-stack*
+	 (dbg::grab-stack nil :how-many most-positive-fixnum))
+	(*debug-io* stream)
+	(dbg:*debug-print-level* nil)
+	(dbg:*debug-print-length* nil))
+    (dbg:bug-backtrace nil)))
+
+#+sbcl
+;; determine how we're going to access the backtrace in the next
+;; function
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (when (find-symbol "*DEBUG-PRINT-VARIABLE-ALIST*" :sb-debug)
+    (pushnew :sbcl-debug-print-variable-alist *features*)))
+
+#+sbcl
+(defun print-backtrace-to-stream (stream)
+  (let (#+:sbcl-debug-print-variable-alist
+	(sb-debug:*debug-print-variable-alist*
+	 (list* '(*print-level* . nil)
+		'(*print-length* . nil)
+		sb-debug:*debug-print-variable-alist*))
+	#-:sbcl-debug-print-variable-alist
+	(sb-debug:*debug-print-level* nil)
+	#-:sbcl-debug-print-variable-alist
+	(sb-debug:*debug-print-length* nil))
+    (sb-debug:backtrace most-positive-fixnum stream)))
+
+#+clisp
+(defun print-backtrace-to-stream (stream)
+  (system::print-backtrace :out stream))
+
+#+(or cmucl scl)
+(defun print-backtrace-to-stream (stream)
+  (let ((debug:*debug-print-level* nil)
+	(debug:*debug-print-length* nil))
+    (debug:backtrace most-positive-fixnum stream)))
+
+
+;; must be after the defun above or the docstring may be wiped out
+(setf (documentation 'print-backtrace-to-stream 'function)
+  "Send a backtrace of the current error to stream. 
+
+Stream is assumed to be an open writable file stream or a
+string-output-stream. Note that `print-backtrace-to-stream`
+will print a backtrace for whatever the Lisp deems to be the 
+*current* error.
+")
+
+
diff --git a/third_party/lisp/trivial-backtrace/dev/fallback.lisp b/third_party/lisp/trivial-backtrace/dev/fallback.lisp
new file mode 100644
index 000000000000..40a5219824e5
--- /dev/null
+++ b/third_party/lisp/trivial-backtrace/dev/fallback.lisp
@@ -0,0 +1,10 @@
+(in-package #:trivial-backtrace)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (unless (fboundp 'map-backtrace)
+    (defun map-backtrace (func)
+      (declare (ignore func))))
+
+  (unless (fboundp 'print-backtrace-to-stream)
+    (defun print-backtrace-to-stream (stream)
+      (format stream "~&backtrace output unavailable.~%"))))
diff --git a/third_party/lisp/trivial-backtrace/dev/map-backtrace.lisp b/third_party/lisp/trivial-backtrace/dev/map-backtrace.lisp
new file mode 100644
index 000000000000..43eddda47579
--- /dev/null
+++ b/third_party/lisp/trivial-backtrace/dev/map-backtrace.lisp
@@ -0,0 +1,105 @@
+(in-package #:trivial-backtrace)
+
+(defstruct frame
+  func
+  source-filename
+  source-pos
+  vars)
+
+(defstruct var
+  name
+  value)
+
+(defstruct pos-form-number
+  number)
+
+(defmethod print-object ((pos-form-number pos-form-number) stream)
+  (cond 
+    (*print-readably* (call-next-method))
+    (t
+     (format stream "f~A" (pos-form-number-number pos-form-number)))))
+
+
+(defvar *trivial-backtrace-frame-print-specials*
+  '((*print-length* . 100)
+    (*print-level* . 20)
+    (*print-lines* . 5)
+    (*print-pretty* . t)
+    (*print-readably* . nil)))
+
+(defun print-frame (frame stream)
+  (format stream "~A:~@[~A:~] ~A: ~%" 
+	  (or (ignore-errors (translate-logical-pathname (frame-source-filename frame))) (frame-source-filename frame) "<unknown>")
+	  (frame-source-pos frame)
+	  (frame-func frame))
+  (loop for var in (frame-vars frame)
+	do 
+	(format stream " ~A = ~A~%" (var-name var) 
+		(or (ignore-errors 	
+			(progv 
+			    (mapcar #'car *trivial-backtrace-frame-print-specials*)
+			    (mapcar #'cdr *trivial-backtrace-frame-print-specials*)
+			  (prin1-to-string 
+			   (var-value var))))
+		    "<error>"))))
+
+(defun map-backtrace (function)
+  (impl-map-backtrace function))
+
+(defun print-map-backtrace (&optional (stream *debug-io*) &rest args)
+  (apply 'map-backtrace 
+	 (lambda (frame)
+	   (print-frame frame stream)) args))
+
+(defun backtrace-string (&rest args)
+  (with-output-to-string (stream)
+    (apply 'print-map-backtrace stream args)))
+
+
+#+ccl
+(defun impl-map-backtrace (func)
+  (ccl::map-call-frames (lambda (ptr) 
+			  (multiple-value-bind (lfun pc)
+			      (ccl::cfp-lfun ptr)
+			    (let ((source-note (ccl:function-source-note lfun)))
+			      (funcall func 
+				       (make-frame :func (ccl::lfun-name lfun)
+						   :source-filename (ccl:source-note-filename source-note)
+						   :source-pos (let ((form-number (ccl:source-note-start-pos source-note)))
+								 (when form-number (make-pos-form-number :number form-number)))
+						   :vars (loop for (name . value) in (ccl::arguments-and-locals nil ptr lfun pc)
+							       collect (make-var :name name :value value)))))))))
+
+#+sbcl
+(defun impl-map-backtrace (func)
+  (loop for f = (or sb-debug:*stack-top-hint* (sb-di:top-frame)) then (sb-di:frame-down f)
+	while f
+	do (funcall func 
+		    (make-frame :func 
+				(ignore-errors
+				  (sb-di:debug-fun-name 			    
+				   (sb-di:frame-debug-fun f)))
+				:source-filename 
+				(ignore-errors
+				  (sb-di:debug-source-namestring (sb-di:code-location-debug-source (sb-di:frame-code-location f))))
+				:source-pos
+				(ignore-errors ;;; XXX does not work
+				  (let ((cloc (sb-di:frame-code-location f)))
+				    (unless (sb-di:code-location-unknown-p cloc)
+				      (format nil "tlf~Dfn~D"
+					      (sb-di:code-location-toplevel-form-offset cloc)
+					      (sb-di:code-location-form-number cloc)))))
+				:vars
+				(remove-if 'not 
+					   (map 'list (lambda(v)
+							(ignore-errors
+							  (when (eq :valid
+							     (sb-di:debug-var-validity v (sb-di:frame-code-location f)))
+							    (make-var :name (sb-di:debug-var-symbol v)
+								      :value (sb-di:debug-var-value v f)))))
+						(ignore-errors (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun f)))))))))
+
+#-(or ccl sbcl)
+(defun impl-map-backtrace (func)
+  (declare (ignore func))
+  (warn "unable to map backtrace for ~a" (lisp-implementation-type)))
\ No newline at end of file
diff --git a/third_party/lisp/trivial-backtrace/dev/mucking.lisp b/third_party/lisp/trivial-backtrace/dev/mucking.lisp
new file mode 100644
index 000000000000..2be26a5a870e
--- /dev/null
+++ b/third_party/lisp/trivial-backtrace/dev/mucking.lisp
@@ -0,0 +1,75 @@
+(in-package #:metabang.gsn)
+
+#|
+Need to account for different kinds of links
+  in gsn-nodes-from-json, need to return pairs of node and attributes
+
+hash-table for nodes to prevent duplicates
+queue or stack for nodes to expand
+hash-table for links (triples of A link B?) to handle duplicates
+|#
+
+(defgeneric expand-node (context node)
+  )
+
+(defgeneric find-neighbors (context node)
+  )
+
+(defgeneric expand-node-p (context node)
+  )
+
+(defgeneric add-node (context node)
+  )
+
+(defgeneric add-link (context node neighbor direction)
+  )
+
+(defgeneric update-node-data (context node data)
+  )
+
+(defclass abstract-context ()
+  ())
+
+(defclass gsn-context (abstract-context)
+  ())
+
+(defparameter +gsn-root+ "http://socialgraph.apis.google.com/")
+
+(defmethod expand-node ((context abstract-context) node)
+  (bind (((to from) (find-neighbors context node)))
+    (dolist (neighbor to)
+      (add-node context neighbor)
+      (add-link context node neighbor :to))
+    (dolist (neighbor from)
+      (add-node context neighbor)
+      (add-link context node neighbor :from))))
+
+
+
+(defmethod find-neighbors ((context gsn-context) node)
+  (bind (((result headers stream)
+	  (http-get 
+	   (format nil "~alookup?edo=1&edi=1&pretty=1&q=~a" 
+		   +gsn-root+ node)))
+	 json)
+    (unwind-protect 
+	 (setf json (json:decode-json stream))
+      (close strea))
+    (update-node-data context node json)		      
+    (list (gsn-nodes-from-json json :to)
+	  (gsn-nodes-from-json json :from))))
+  
+(gsn-nodes-from-json x :from)  
+
+(defun gsn-test (who)
+  (destructuring-bind (result headers stream)
+      (http-get 
+       (format nil "http://socialgraph.apis.google.com/lookup?edo=1&edi=1&pretty=1&q=~a" who))
+    (declare (ignore result headers))
+    (json:decode-json stream)))
+
+(assoc :nodes_referenced 
+       (assoc :nodes (gsn-test "TWITTER.COM/GWKING") :key #'first))
+
+
+(setf x (gsn-test "TWITTER.COM/GWKING")) 
diff --git a/third_party/lisp/trivial-backtrace/dev/packages.lisp b/third_party/lisp/trivial-backtrace/dev/packages.lisp
new file mode 100644
index 000000000000..2da49d3d9ba5
--- /dev/null
+++ b/third_party/lisp/trivial-backtrace/dev/packages.lisp
@@ -0,0 +1,13 @@
+(in-package #:common-lisp-user)
+
+(defpackage #:trivial-backtrace
+  (:use #:common-lisp)
+  (:export #:print-backtrace
+	   #:print-backtrace-to-stream
+	   #:print-condition
+	   #:*date-time-format*
+
+
+	   #:backtrace-string
+	   #:map-backtrace))
+
diff --git a/third_party/lisp/trivial-backtrace/dev/utilities.lisp b/third_party/lisp/trivial-backtrace/dev/utilities.lisp
new file mode 100644
index 000000000000..b0a249867aa9
--- /dev/null
+++ b/third_party/lisp/trivial-backtrace/dev/utilities.lisp
@@ -0,0 +1,104 @@
+(in-package #:trivial-backtrace)
+
+(defparameter *date-time-format* "%Y-%m-%d-%H:%M"
+  "The default format to use when printing dates and times.
+
+* %% - A '%' character
+* %d - Day of the month as a decimal number [01-31]
+* %e - Same as %d but does not print the leading 0 for days 1 through 9 
+     [unlike strftime[], does not print a leading space]
+* %H - Hour based on a 24-hour clock as a decimal number [00-23]
+*%I - Hour based on a 12-hour clock as a decimal number [01-12]
+* %m - Month as a decimal number [01-12]
+* %M - Minute as a decimal number [00-59]
+* %S - Second as a decimal number [00-59]
+* %w - Weekday as a decimal number [0-6], where Sunday is 0
+* %y - Year without century [00-99]
+* %Y - Year with century [such as 1990]
+
+This code is borrowed from the `format-date` function in 
+[metatilities-base][].")
+
+;; modified from metatilities-base
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defmacro generate-time-part-function (part-name position)
+    (let ((function-name 
+	   (intern 
+	    (concatenate 'string
+			 (symbol-name 'time) "-" (symbol-name part-name))
+	    :trivial-backtrace)))
+      `(eval-when (:compile-toplevel :load-toplevel :execute)
+         (defun ,function-name
+                (&optional (universal-time (get-universal-time))
+                           (time-zone nil))
+           ,(format nil "Returns the ~(~A~) part of the given time." part-name)
+           (nth-value ,position 
+		      (apply #'decode-universal-time
+			     universal-time time-zone))))))
+
+  (generate-time-part-function second 0)
+  (generate-time-part-function minute 1)
+  (generate-time-part-function hour 2)
+  (generate-time-part-function date 3)
+  (generate-time-part-function month 4)
+  (generate-time-part-function year 5)
+  (generate-time-part-function day-of-week 6)
+  (generate-time-part-function daylight-savings-time-p 7))
+
+(defun date-time-string (&key (date/time (get-universal-time))
+			 (format *date-time-format*))
+  (format-date format date/time nil))
+
+(defun format-date (format date &optional stream time-zone)
+  (declare (ignore time-zone))
+  (let ((format-length (length format)))
+    (format 
+     stream "~{~A~}"
+     (loop for index = 0 then (1+ index) 
+	while (< index format-length) collect 
+	(let ((char (aref format index)))
+	  (cond 
+	    ((char= #\% char)
+	     (setf char (aref format (incf index)))
+	     (cond 
+	       ;; %% - A '%' character
+	       ((char= char #\%) #\%)
+                            
+	       ;; %d - Day of the month as a decimal number [01-31]
+	       ((char= char #\d) (format nil "~2,'0D" (time-date date)))
+                            
+	       ;; %e - Same as %d but does not print the leading 0 for 
+	       ;; days 1 through 9. Unlike strftime, does not print a 
+	       ;; leading space
+	       ((char= char #\e) (format nil "~D" (time-date date)))
+                            
+	       ;; %H - Hour based on a 24-hour clock as a decimal number [00-23]
+	       ((char= char #\H) (format nil "~2,'0D" (time-hour date)))
+                            
+	       ;; %I - Hour based on a 12-hour clock as a decimal number [01-12]
+	       ((char= char #\I) (format nil "~2,'0D" 
+					 (1+ (mod (time-hour date) 12))))
+                            
+	       ;; %m - Month as a decimal number [01-12]
+	       ((char= char #\m) (format nil "~2,'0D" (time-month date)))
+                            
+	       ;; %M - Minute as a decimal number [00-59]
+	       ((char= char #\M) (format nil "~2,'0D" (time-minute date)))
+                            
+	       ;; %S - Second as a decimal number [00-59]
+	       ((char= char #\S) (format nil "~2,'0D" (time-second date)))
+                            
+	       ;; %w - Weekday as a decimal number [0-6], where Sunday is 0
+	       ((char= char #\w) (format nil "~D" (time-day-of-week date)))
+                            
+	       ;; %y - Year without century [00-99]
+	       ((char= char #\y) 
+		(let ((year-string (format nil "~,2A" (time-year date))))
+		  (subseq year-string (- (length year-string) 2))))
+                            
+	       ;; %Y - Year with century [such as 1990]
+	       ((char= char #\Y) (format nil "~D" (time-year date)))
+                            
+	       (t
+		(error "Ouch - unknown formatter '%~c" char))))
+	    (t char)))))))
diff --git a/third_party/lisp/trivial-backtrace/lift-standard.config b/third_party/lisp/trivial-backtrace/lift-standard.config
new file mode 100644
index 000000000000..0f22312080cf
--- /dev/null
+++ b/third_party/lisp/trivial-backtrace/lift-standard.config
@@ -0,0 +1,35 @@
+;;; configuration for LIFT tests
+
+;; settings
+(:if-dribble-exists :supersede)
+(:dribble "lift.dribble")
+(:print-length 10)
+(:print-level 5)
+(:print-test-case-names t)
+
+;; suites to run
+(trivial-backtrace-test)
+
+;; report properties
+(:report-property :title "Trivial-Backtrace | Test results")
+(:report-property :relative-to trivial-backtrace-test)
+
+(:report-property :style-sheet "test-style.css")
+(:report-property :if-exists :supersede)
+(:report-property :format :html)
+(:report-property :full-pathname "test-results/test-report.html")
+(:report-property :unique-name t)
+(:build-report)
+
+(:report-property :unique-name t)
+(:report-property :format :describe)
+(:report-property :full-pathname "test-results/test-report.txt")
+(:build-report)
+
+(:report-property :format :save)
+(:report-property :full-pathname "test-results/test-report.sav")
+(:build-report)
+
+(:report-property :format :describe)
+(:report-property :full-pathname *standard-output*)
+(:build-report)
diff --git a/third_party/lisp/trivial-backtrace/test/packages.lisp b/third_party/lisp/trivial-backtrace/test/packages.lisp
new file mode 100644
index 000000000000..7dc3eae57682
--- /dev/null
+++ b/third_party/lisp/trivial-backtrace/test/packages.lisp
@@ -0,0 +1,5 @@
+(in-package #:common-lisp-user)
+
+(defpackage #:trivial-backtrace-test
+  (:use #:common-lisp #:lift #:trivial-backtrace))
+
diff --git a/third_party/lisp/trivial-backtrace/test/test-setup.lisp b/third_party/lisp/trivial-backtrace/test/test-setup.lisp
new file mode 100644
index 000000000000..a46b3a196649
--- /dev/null
+++ b/third_party/lisp/trivial-backtrace/test/test-setup.lisp
@@ -0,0 +1,4 @@
+(in-package #:trivial-backtrace-test)
+
+(deftestsuite trivial-backtrace-test ()
+  ())
diff --git a/third_party/lisp/trivial-backtrace/test/tests.lisp b/third_party/lisp/trivial-backtrace/test/tests.lisp
new file mode 100644
index 000000000000..9b32090f13e0
--- /dev/null
+++ b/third_party/lisp/trivial-backtrace/test/tests.lisp
@@ -0,0 +1,17 @@
+(in-package #:trivial-backtrace-test)
+
+(deftestsuite generates-backtrace (trivial-backtrace-test)
+  ())
+
+(addtest (generates-backtrace)
+  test-1
+  (let ((output nil))
+    (handler-case 
+	(let ((x 1))
+	  (let ((y (- x (expt 1024 0))))
+	    (declare (optimize (safety 3)))
+	    (/ 2 y)))
+      (error (c)
+	(setf output (print-backtrace c :output nil))))
+    (ensure (stringp output))
+    (ensure (plusp (length output)))))
diff --git a/third_party/lisp/trivial-backtrace/trivial-backtrace-test.asd b/third_party/lisp/trivial-backtrace/trivial-backtrace-test.asd
new file mode 100644
index 000000000000..cb088434a2c1
--- /dev/null
+++ b/third_party/lisp/trivial-backtrace/trivial-backtrace-test.asd
@@ -0,0 +1,22 @@
+(defpackage #:trivial-backtrace-test-system (:use #:asdf #:cl))
+(in-package #:trivial-backtrace-test-system)
+
+(defsystem trivial-backtrace-test
+  :author "Gary Warren King <gwking@metabang.com>"
+  :maintainer "Gary Warren King <gwking@metabang.com>"
+  :licence "MIT Style License; see file COPYING for details"
+  :components ((:module 
+		"setup"
+		:pathname "test/"
+		:components ((:file "packages")
+			     (:file "test-setup"
+				    :depends-on ("packages"))))
+	       (:module 
+		"test"
+		:pathname "test/"
+		:depends-on ("setup")
+		:components ((:file "tests"))))  
+  :depends-on (:lift :trivial-backtrace))
+
+
+
diff --git a/third_party/lisp/trivial-backtrace/trivial-backtrace.asd b/third_party/lisp/trivial-backtrace/trivial-backtrace.asd
new file mode 100644
index 000000000000..843b6cc39a3c
--- /dev/null
+++ b/third_party/lisp/trivial-backtrace/trivial-backtrace.asd
@@ -0,0 +1,35 @@
+(in-package #:common-lisp-user)
+
+(defpackage #:trivial-backtrace-system (:use #:asdf #:cl))
+(in-package #:trivial-backtrace-system)
+
+(defsystem trivial-backtrace
+  :version "1.1.0"
+  :author "Gary Warren King <gwking@metabang.com> and contributors"
+  :maintainer "Gary Warren King <gwking@metabang.com> and contributors"
+  :licence "MIT Style license "
+  :description "trivial-backtrace"
+  :depends-on ()
+  :components
+  ((:static-file "COPYING")
+   (:module 
+    "setup"
+    :pathname "dev/"
+    :components ((:file "packages")))
+   (:module 
+    "dev"
+    :depends-on ("setup")
+    :components ((:file "utilities")
+		 (:file "backtrace")
+		 (:file "map-backtrace")
+		 (:file "fallback" :depends-on ("backtrace" "map-backtrace")))))
+  :in-order-to ((test-op (load-op trivial-backtrace-test)))
+  :perform (test-op :after (op c)
+		    (funcall
+		     (intern (symbol-name '#:run-tests) :lift)
+		     :config :generic)))
+
+(defmethod operation-done-p 
+           ((o test-op)
+            (c (eql (find-system 'trivial-backtrace))))
+  (values nil))
diff --git a/third_party/lisp/trivial-backtrace/website/source/index.md b/third_party/lisp/trivial-backtrace/website/source/index.md
new file mode 100644
index 000000000000..93a5df3b91db
--- /dev/null
+++ b/third_party/lisp/trivial-backtrace/website/source/index.md
@@ -0,0 +1,88 @@
+{include resources/header.md}
+
+<div class="contents">
+<div class="system-links">
+
+  * [Mailing Lists][mailing-list]
+  * [Getting it][downloads]
+  * [Documentation][]
+  * [News][]
+  * [Test results][tr]
+  * [Changelog][]
+
+</div>
+<div class="system-description">
+
+### What it is
+
+On of the many things that didn't quite get into the Common
+Lisp standard was how to get a Lisp to output its call stack
+when something has gone wrong. As such, each Lisp has
+developed its own notion of what to display, how to display
+it, and what sort of arguments can be used to customize it.
+`trivial-backtrace` is a simple solution to generating a
+backtrace portably. As of {today}, it supports Allegro Common
+Lisp, LispWorks, ECL, MCL, SCL, SBCL and CMUCL. Its
+interface consists of three functions and one variable:
+
+ * print-backtrace
+ * print-backtrace-to-stream
+ * print-condition
+ * \*date-time-format\*
+
+You can probably already guess what they do, but they are
+described in more detail below.
+
+{anchor mailing-lists}
+
+### Mailing Lists
+
+  * [trivial-backtrace-devel][devel-list]: A list for
+    announcements, questions, patches, bug reports, and so
+    on; It's for anything and everything
+
+### API
+
+{set-property docs-package trivial-backtrace}
+{docs print-backtrace}
+{docs print-backtrace-to-stream}
+{docs print-condition}
+{docs *date-time-format*}
+
+{anchor downloads}
+
+### Where is it
+
+A [git][] repository is available using
+
+    git clone http://common-lisp.net/project/trivial-backtrace/trivial-backtrace.git
+    
+The [darcs][] repository is still around but is **not** being updated.
+The command to get it is below:
+
+    ;;; WARNING: out of date
+    darcs get http://common-lisp.net/project/trivial-backtrace/
+
+trivial-backtrace is also [ASDF installable][asdf-install].
+Its CLiki home is right [where][cliki-home] you'd expect.
+
+There's also a handy [gzipped tar file][tarball].
+
+{anchor news}
+
+### What is happening
+
+<dl>
+  <dt>14 May 2009</dt>
+  <dd>Moved to [git][]; John Fremlin adds map-backtrace
+      </dd>
+
+<dt>1 June 2008</dt>
+<dd>Release version 1.0
+    </dd>
+    </dl>
+</div>
+</div>
+
+{include resources/footer.md}
+
diff --git a/third_party/lisp/trivial-backtrace/website/source/resources/footer.md b/third_party/lisp/trivial-backtrace/website/source/resources/footer.md
new file mode 100644
index 000000000000..c5bf3c4ec399
--- /dev/null
+++ b/third_party/lisp/trivial-backtrace/website/source/resources/footer.md
@@ -0,0 +1,15 @@
+<div id="footer" class="footer">
+<div id="buttons">
+<a class="nav" href="http://validator.w3.org/check/referer" title="xhtml1.1"><img src="http://common-lisp.net/project/cl-containers/shared/buttons/xhtml.gif" width="80" height="15" title="valid xhtml button" alt="valid xhtml" /></a>
+<a class="nav" href="http://common-lisp.net/project/cl-markdown/" title="Mark with CL-Markdown"><img src="http://common-lisp.net/project/cl-containers/shared/buttons/cl-markdown.png" width="80" height="15" title="Made with CL-Markdown" alt="CL-Markdown" /></a>
+<a class="nav" href="http://www.catb.org/hacker-emblem/" title="hacker"><img src="http://common-lisp.net/project/cl-containers/shared/buttons/hacker.png" width="80" height="15" title="hacker emblem" alt="hacker button" /></a>
+<a class="nav" href="http://www.lisp.org/" title="Association of Lisp Users"><img src="http://common-lisp.net/project/cl-containers/shared/buttons/lambda-lisp.png" width="80" height="15" title="ALU emblem" alt="ALU button" /></a>
+<a class="nav" href="http://common-lisp.net/" title="Common-Lisp.net"><img src="http://common-lisp.net/project/cl-containers/shared/buttons/lisp-lizard.png" width="80" height="15" title="Common-Lisp.net" alt="Common-Lisp.net button" /></a>
+</div>
+
+### Copyright (c) 2009 - 2011 Gary Warren King (gwking@metabang.com) 
+
+trivial-backtrace has an [MIT style][mit-license] license
+
+<div id="timestamp">Last updated {today} at {now}</div>
+</div>
diff --git a/third_party/lisp/trivial-backtrace/website/source/resources/header.md b/third_party/lisp/trivial-backtrace/website/source/resources/header.md
new file mode 100644
index 000000000000..2738c471378c
--- /dev/null
+++ b/third_party/lisp/trivial-backtrace/website/source/resources/header.md
@@ -0,0 +1,19 @@
+{include shared-links.md}
+
+{set-property html yes}
+{set-property style-sheet "styles.css"}
+{set-property author "Gary Warren King"}
+{set-property title "trivial-backtrace | watch where you've been"}
+
+ [devel-list]: http://common-lisp.net/cgi-bin/mailman/listinfo/trivial-backtrace-devel
+ [cliki-home]: http://www.cliki.net//trivial-backtrace
+ [tarball]: http://common-lisp.net/project/trivial-backtrace/trivial-backtrace.tar.gz
+  
+<div id="header">
+	<span class="logo"><a href="http://www.metabang.com/" title="metabang.com"><img src="http://common-lisp.net/project/cl-containers/shared/metabang-2.png" title="metabang.com" width="100" alt="Metabang Logo" /></a></span>
+
+## trivial-backtrace
+
+#### watch where you've been
+
+</div>
diff --git a/third_party/lisp/trivial-backtrace/website/source/resources/navigation.md b/third_party/lisp/trivial-backtrace/website/source/resources/navigation.md
new file mode 100644
index 000000000000..a734edfb8323
--- /dev/null
+++ b/third_party/lisp/trivial-backtrace/website/source/resources/navigation.md
@@ -0,0 +1,2 @@
+<div id="navigation">
+</div>
diff --git a/third_party/lisp/trivial-backtrace/website/website.tmproj b/third_party/lisp/trivial-backtrace/website/website.tmproj
new file mode 100644
index 000000000000..01b745ba44c0
--- /dev/null
+++ b/third_party/lisp/trivial-backtrace/website/website.tmproj
@@ -0,0 +1,93 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+	<key>currentDocument</key>
+	<string>source/resources/header.md</string>
+	<key>documents</key>
+	<array>
+		<dict>
+			<key>expanded</key>
+			<true/>
+			<key>name</key>
+			<string>source</string>
+			<key>regexFolderFilter</key>
+			<string>!.*/(\.[^/]*|CVS|_darcs|_MTN|\{arch\}|blib|.*~\.nib|.*\.(framework|app|pbproj|pbxproj|xcode(proj)?|bundle))$</string>
+			<key>sourceDirectory</key>
+			<string>source</string>
+		</dict>
+	</array>
+	<key>fileHierarchyDrawerWidth</key>
+	<integer>190</integer>
+	<key>metaData</key>
+	<dict>
+		<key>source/index.md</key>
+		<dict>
+			<key>caret</key>
+			<dict>
+				<key>column</key>
+				<integer>0</integer>
+				<key>line</key>
+				<integer>0</integer>
+			</dict>
+			<key>firstVisibleColumn</key>
+			<integer>0</integer>
+			<key>firstVisibleLine</key>
+			<integer>0</integer>
+		</dict>
+		<key>source/resources/footer.md</key>
+		<dict>
+			<key>caret</key>
+			<dict>
+				<key>column</key>
+				<integer>29</integer>
+				<key>line</key>
+				<integer>9</integer>
+			</dict>
+			<key>firstVisibleColumn</key>
+			<integer>0</integer>
+			<key>firstVisibleLine</key>
+			<integer>0</integer>
+		</dict>
+		<key>source/resources/header.md</key>
+		<dict>
+			<key>caret</key>
+			<dict>
+				<key>column</key>
+				<integer>27</integer>
+				<key>line</key>
+				<integer>3</integer>
+			</dict>
+			<key>firstVisibleColumn</key>
+			<integer>0</integer>
+			<key>firstVisibleLine</key>
+			<integer>0</integer>
+		</dict>
+		<key>source/resources/navigation.md</key>
+		<dict>
+			<key>caret</key>
+			<dict>
+				<key>column</key>
+				<integer>0</integer>
+				<key>line</key>
+				<integer>1</integer>
+			</dict>
+			<key>firstVisibleColumn</key>
+			<integer>0</integer>
+			<key>firstVisibleLine</key>
+			<integer>0</integer>
+		</dict>
+	</dict>
+	<key>openDocuments</key>
+	<array>
+		<string>source/resources/header.md</string>
+		<string>source/index.md</string>
+		<string>source/resources/navigation.md</string>
+		<string>source/resources/footer.md</string>
+	</array>
+	<key>showFileHierarchyDrawer</key>
+	<true/>
+	<key>windowFrame</key>
+	<string>{{615, 0}, {578, 778}}</string>
+</dict>
+</plist>
diff --git a/third_party/lisp/trivial-features.nix b/third_party/lisp/trivial-features.nix
new file mode 100644
index 000000000000..b7808a2364aa
--- /dev/null
+++ b/third_party/lisp/trivial-features.nix
@@ -0,0 +1,12 @@
+{ depot, ... }:
+
+let src = builtins.fetchGit {
+  url = "https://github.com/trivial-features/trivial-features.git";
+  rev = "b78b2df5d75bdf8fdfc69f0deec0a187d9664b0b";
+};
+in depot.nix.buildLisp.library {
+  name = "trivial-features";
+  srcs = [
+    (src + "/src/tf-sbcl.lisp")
+  ];
+}
diff --git a/third_party/lisp/trivial-garbage.nix b/third_party/lisp/trivial-garbage.nix
new file mode 100644
index 000000000000..e5b3550de7ba
--- /dev/null
+++ b/third_party/lisp/trivial-garbage.nix
@@ -0,0 +1,12 @@
+# trivial-garbage provides a portable API to finalizers, weak
+# hash-tables and weak pointers
+{ depot, ... }:
+
+let src = builtins.fetchGit {
+  url = "https://github.com/trivial-garbage/trivial-garbage.git";
+  rev = "dbc8e35acb0176b9a14fdc1027f5ebea93435a84";
+};
+in depot.nix.buildLisp.library {
+  name = "trivial-garbage";
+  srcs = [ (src + "/trivial-garbage.lisp") ];
+}
diff --git a/third_party/lisp/trivial-gray-streams.nix b/third_party/lisp/trivial-gray-streams.nix
new file mode 100644
index 000000000000..b5722f9a685a
--- /dev/null
+++ b/third_party/lisp/trivial-gray-streams.nix
@@ -0,0 +1,16 @@
+# Portability library for CL gray streams.
+{ depot, ... }:
+
+let src = builtins.fetchGit {
+  url = "https://github.com/trivial-gray-streams/trivial-gray-streams.git";
+  rev = "ebd59b1afed03b9dc8544320f8f432fdf92ab010";
+};
+in depot.nix.buildLisp.library {
+  name = "trivial-gray-streams";
+  srcs = [
+    (src + "/package.lisp")
+    (src + "/streams.lisp")
+  ];
+}
+
+
diff --git a/third_party/lisp/unix-opts.nix b/third_party/lisp/unix-opts.nix
new file mode 100644
index 000000000000..99117d8beb2a
--- /dev/null
+++ b/third_party/lisp/unix-opts.nix
@@ -0,0 +1,17 @@
+# unix-opts is a portable command line argument parser
+{ depot, ...}:
+
+let
+  src = depot.third_party.fetchFromGitHub {
+    owner = "libre-man";
+    repo = "unix-opts";
+    rev = "b805050b074bd860edd18cfc8776fdec666ec36e";
+    sha256 = "0j93dkc9f77wz1zfspm7q1scx6wwbm6jhk8vl2rm6bfd0n8scxla";
+  };
+in depot.nix.buildLisp.library {
+  name = "unix-opts";
+
+  srcs = [
+    "${src}/unix-opts.lisp"
+  ];
+}
diff --git a/third_party/lisp/usocket.nix b/third_party/lisp/usocket.nix
new file mode 100644
index 000000000000..920c41c58d25
--- /dev/null
+++ b/third_party/lisp/usocket.nix
@@ -0,0 +1,37 @@
+# Usocket is a portable socket library
+{ depot, ... }:
+
+with depot.nix;
+
+let src = depot.third_party.fetchFromGitHub {
+  owner = "usocket";
+  repo = "usocket";
+  rev = "fdf4fd1e0051ce83340ccfbbc8a43a462bb19cf2";
+  sha256 = "0x746wr2324l6bn7skqzgkzcbj5kd0zp2ck0c8rldrw0rzabg826";
+};
+in buildLisp.library {
+  name = "usocket";
+  deps = with depot.third_party.lisp; [
+    (buildLisp.bundled "asdf")
+    (buildLisp.bundled "sb-bsd-sockets")
+    split-sequence
+  ];
+
+  srcs = [
+    # usocket also reads its version from ASDF, but there's further
+    # shenanigans happening there that I don't intend to support right
+    # now. Behold:
+    (builtins.toFile "usocket.asd" ''
+      (in-package :asdf)
+      (defsystem usocket
+        :version "0.8.3")
+    '')
+  ] ++
+  # Now for the regularly scheduled programming:
+  (map (f: src + ("/" + f)) [
+    "package.lisp"
+    "usocket.lisp"
+    "condition.lisp"
+    "backend/sbcl.lisp"
+  ]);
+}