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/OWNERS5
-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/anaphora.nix18
-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.nix34
-rw-r--r--third_party/lisp/bordeaux-threads.nix26
-rw-r--r--third_party/lisp/cffi.nix37
-rw-r--r--third_party/lisp/checkl.nix26
-rw-r--r--third_party/lisp/chipz.nix31
-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.nix32
-rw-r--r--third_party/lisp/cl-json.nix28
-rw-r--r--third_party/lisp/cl-plus-ssl.nix47
-rw-r--r--third_party/lisp/cl-ppcre.nix30
-rw-r--r--third_party/lisp/cl-prevalence.nix30
-rw-r--r--third_party/lisp/cl-smtp.nix32
-rw-r--r--third_party/lisp/cl-unicode.nix80
-rw-r--r--third_party/lisp/cl-who.nix21
-rw-r--r--third_party/lisp/cl-yacc.nix15
-rw-r--r--third_party/lisp/closer-mop.nix24
-rw-r--r--third_party/lisp/closure-common.nix43
-rw-r--r--third_party/lisp/closure-html/default.nix70
-rw-r--r--third_party/lisp/closure-html/dtds-from-store.patch16
-rw-r--r--third_party/lisp/closure-html/no-double-defun.patch78
-rw-r--r--third_party/lisp/data-sift.nix27
-rw-r--r--third_party/lisp/defclass-std.nix21
-rw-r--r--third_party/lisp/drakma.nix39
-rw-r--r--third_party/lisp/easy-routes.nix29
-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/global-vars.nix14
-rw-r--r--third_party/lisp/hunchentoot.nix65
-rw-r--r--third_party/lisp/ironclad.nix155
-rw-r--r--third_party/lisp/iterate.nix15
-rw-r--r--third_party/lisp/lass.nix34
-rw-r--r--third_party/lisp/lisp-binary.nix35
-rw-r--r--third_party/lisp/local-time.nix18
-rw-r--r--third_party/lisp/marshal.nix20
-rw-r--r--third_party/lisp/md5.nix21
-rw-r--r--third_party/lisp/mime4cl/.skip-subtree1
-rw-r--r--third_party/lisp/mime4cl/OWNERS3
-rw-r--r--third_party/lisp/mime4cl/README7
-rw-r--r--third_party/lisp/mime4cl/address.lisp301
-rw-r--r--third_party/lisp/mime4cl/default.nix48
-rw-r--r--third_party/lisp/mime4cl/endec.lisp683
-rw-r--r--third_party/lisp/mime4cl/mime.lisp1061
-rw-r--r--third_party/lisp/mime4cl/mime4cl-tests.asd54
-rw-r--r--third_party/lisp/mime4cl/mime4cl.asd53
-rw-r--r--third_party/lisp/mime4cl/package.lisp108
-rw-r--r--third_party/lisp/mime4cl/streams.lisp368
-rw-r--r--third_party/lisp/mime4cl/test/address.lisp124
-rw-r--r--third_party/lisp/mime4cl/test/endec.lisp167
-rw-r--r--third_party/lisp/mime4cl/test/mime.lisp56
-rw-r--r--third_party/lisp/mime4cl/test/package.lisp28
-rw-r--r--third_party/lisp/mime4cl/test/rt.lisp254
-rw-r--r--third_party/lisp/mime4cl/test/sample1.msg86
-rw-r--r--third_party/lisp/moptilities.nix18
-rw-r--r--third_party/lisp/nibbles.nix32
-rw-r--r--third_party/lisp/npg/.project1
-rw-r--r--third_party/lisp/npg/.skip-subtree1
-rw-r--r--third_party/lisp/npg/COPYING504
-rw-r--r--third_party/lisp/npg/OWNERS3
-rw-r--r--third_party/lisp/npg/README48
-rw-r--r--third_party/lisp/npg/default.nix14
-rw-r--r--third_party/lisp/npg/examples/python.lisp336
-rw-r--r--third_party/lisp/npg/examples/vs-cobol-ii.lisp1901
-rw-r--r--third_party/lisp/npg/npg.asd55
-rw-r--r--third_party/lisp/npg/src/common.lisp79
-rw-r--r--third_party/lisp/npg/src/define.lisp408
-rw-r--r--third_party/lisp/npg/src/package.lisp50
-rw-r--r--third_party/lisp/npg/src/parser.lisp234
-rw-r--r--third_party/lisp/parse-float.nix22
-rw-r--r--third_party/lisp/parse-number.nix17
-rw-r--r--third_party/lisp/parseq.nix20
-rw-r--r--third_party/lisp/physical-quantities.nix31
-rw-r--r--third_party/lisp/postmodern.nix94
-rw-r--r--third_party/lisp/puri.nix14
-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/restas.nix41
-rw-r--r--third_party/lisp/rfc2388.nix17
-rw-r--r--third_party/lisp/routes.nix38
-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/sclf/.skip-subtree1
-rw-r--r--third_party/lisp/sclf/OWNERS3
-rw-r--r--third_party/lisp/sclf/README6
-rw-r--r--third_party/lisp/sclf/default.nix28
-rw-r--r--third_party/lisp/sclf/directory.lisp404
-rw-r--r--third_party/lisp/sclf/lazy.lisp134
-rw-r--r--third_party/lisp/sclf/mp/README6
-rw-r--r--third_party/lisp/sclf/mp/cmu.lisp115
-rw-r--r--third_party/lisp/sclf/mp/sbcl.lisp235
-rw-r--r--third_party/lisp/sclf/package.lisp258
-rw-r--r--third_party/lisp/sclf/sclf.asd58
-rw-r--r--third_party/lisp/sclf/sclf.lisp1717
-rw-r--r--third_party/lisp/sclf/serial.lisp62
-rw-r--r--third_party/lisp/sclf/sysproc.lisp295
-rw-r--r--third_party/lisp/sclf/time.lisp311
-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.nix16
-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/trivial-indent.nix17
-rw-r--r--third_party/lisp/trivial-ldap.nix26
-rw-r--r--third_party/lisp/trivial-mimes.nix30
-rw-r--r--third_party/lisp/uax-15.nix45
-rw-r--r--third_party/lisp/unix-opts.nix17
-rw-r--r--third_party/lisp/usocket.nix51
217 files changed, 25877 insertions, 0 deletions
diff --git a/third_party/lisp/OWNERS b/third_party/lisp/OWNERS
new file mode 100644
index 000000000000..2d7f7e237b76
--- /dev/null
+++ b/third_party/lisp/OWNERS
@@ -0,0 +1,5 @@
+# -*- mode: yaml; -*-
+inherited: true
+owners:
+  - eta
+  - grfn
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/anaphora.nix b/third_party/lisp/anaphora.nix
new file mode 100644
index 000000000000..d2356f7b05ea
--- /dev/null
+++ b/third_party/lisp/anaphora.nix
@@ -0,0 +1,18 @@
+{ depot, pkgs, ... }:
+
+let src = pkgs.fetchFromGitHub {
+    owner = "tokenrove";
+    repo = "anaphora";
+    rev = "018590df36ffb30ece561fb28ea6521363efc6e2";
+    sha256 = "0pq6y5swvrjd0kjs2dl2648s13s0pzxin0chrq35jam8jrci3kd1";
+  };
+in depot.nix.buildLisp.library {
+  name = "anaphora";
+
+  srcs = map (f: src + ("/" + f)) [
+    "packages.lisp"
+    "early.lisp"
+    "symbolic.lisp"
+    "anaphora.lisp"
+  ];
+}
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..c4a49e833f76
--- /dev/null
+++ b/third_party/lisp/babel.nix
@@ -0,0 +1,34 @@
+# Babel is an encoding conversion library for Common Lisp.
+{ depot, ... }:
+
+let src = builtins.fetchGit {
+  url = "https://github.com/cl-babel/babel.git";
+  rev = "f892d0587c7f3a1e6c0899425921b48008c29ee3"; # 2020-07-19
+};
+in depot.nix.buildLisp.library {
+  name = "babel";
+  deps = [
+    depot.third_party.lisp.alexandria
+    depot.third_party.lisp.trivial-features
+  ];
+
+  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..92bc1f2629c4
--- /dev/null
+++ b/third_party/lisp/bordeaux-threads.nix
@@ -0,0 +1,26 @@
+# 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";
+  };
+  getSrc = f: "${src}/src/${f}";
+in depot.nix.buildLisp.library {
+  name = "bordeaux-threads";
+  deps = [ depot.third_party.lisp.alexandria ];
+
+  srcs = map getSrc [
+    "pkgdcl.lisp"
+    "bordeaux-threads.lisp"
+  ] ++ [
+    {
+      sbcl = getSrc "impl-sbcl.lisp";
+      ecl = getSrc "impl-ecl.lisp";
+    }
+  ] ++ map getSrc [
+    "default-implementations.lisp"
+  ];
+}
diff --git a/third_party/lisp/cffi.nix b/third_party/lisp/cffi.nix
new file mode 100644
index 000000000000..c8d240c8cd0e
--- /dev/null
+++ b/third_party/lisp/cffi.nix
@@ -0,0 +1,37 @@
+# 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 = "a49ff36a95cb62ffa6cb069d98378d665769926b";
+};
+in buildLisp.library {
+  name = "cffi";
+  deps = with depot.third_party.lisp; [
+    alexandria
+    babel
+    trivial-features
+    (buildLisp.bundled "asdf")
+  ];
+
+  srcs = [
+    {
+      ecl = src + "/src/cffi-ecl.lisp";
+      sbcl = src + "/src/cffi-sbcl.lisp";
+      ccl = src + "/src/cffi-openmcl.lisp";
+    }
+  ] ++ map (f: src + ("/src/" + f)) [
+    "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/checkl.nix b/third_party/lisp/checkl.nix
new file mode 100644
index 000000000000..4fb92cb37937
--- /dev/null
+++ b/third_party/lisp/checkl.nix
@@ -0,0 +1,26 @@
+{ depot, pkgs, ... }:
+
+let
+  inherit (depot.nix.buildLisp) bundled;
+
+  src = pkgs.fetchFromGitHub {
+    owner = "rpav";
+    repo = "CheckL";
+    rev = "80328800d047fef9b6e32dfe6bdc98396aee3cc9";
+    sha256 = "0bpisihx1gay44xmyr1dmhlwh00j0zzi04rp9fy35i95l2r4xdlx";
+  };
+
+in depot.nix.buildLisp.library {
+  name = "checkl";
+  deps = with depot.third_party.lisp; [
+    (bundled "asdf")
+    marshal
+    fiveam
+  ];
+
+  srcs = map (f: src + ("/" + f)) [
+    "package.lisp"
+    "checkl.lisp"
+    "formalize.lisp"
+  ];
+}
diff --git a/third_party/lisp/chipz.nix b/third_party/lisp/chipz.nix
new file mode 100644
index 000000000000..2a68d3b1f8e9
--- /dev/null
+++ b/third_party/lisp/chipz.nix
@@ -0,0 +1,31 @@
+# Common Lisp library for decompressing deflate, zlib, gzip, and bzip2 data
+{ depot, pkgs, ... }:
+
+let src = pkgs.fetchFromGitHub {
+  owner = "froydnj";
+  repo = "chipz";
+  rev = "75dfbc660a5a28161c57f115adf74c8a926bfc4d";
+  sha256 = "0plx4rs39zbs4gjk77h4a2q11zpy75fh9v8hnxrvsf8fnakajhwg";
+};
+in depot.nix.buildLisp.library {
+  name = "chipz";
+  deps = [ (depot.nix.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..d40208063372
--- /dev/null
+++ b/third_party/lisp/chunga.nix
@@ -0,0 +1,27 @@
+# Portable chunked streams for Common Lisp
+{ depot, pkgs, ... }:
+
+let src = pkgs.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..905e0821cac7
--- /dev/null
+++ b/third_party/lisp/cl-fad.nix
@@ -0,0 +1,32 @@
+# Portable pathname library
+{ depot, pkgs, ...}:
+
+with depot.nix;
+
+let src = pkgs.fetchFromGitHub {
+  owner = "edicl";
+  repo = "cl-fad";
+  rev = "13cbffe08fc660041359302f4057f8fc20d09402"; # 2021-01-10
+  sha256 = "049laj8an6g9bh0m0cn0bxhq313p8qq1h37cil15l66147ad8slc";
+};
+in buildLisp.library {
+  name = "cl-fad";
+
+  deps = with depot.third_party.lisp; [
+    alexandria
+    bordeaux-threads
+    {
+      sbcl = buildLisp.bundled "sb-posix";
+    }
+  ];
+
+  srcs = map (f: src + ("/" + f)) [
+    "packages.lisp"
+  ] ++ [
+    { ccl =  "${src}/openmcl.lisp"; }
+  ] ++ map (f: src + ("/" + f)) [
+    "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..5d1450a3e9a1
--- /dev/null
+++ b/third_party/lisp/cl-json.nix
@@ -0,0 +1,28 @@
+# JSON encoder & decoder
+{ depot, pkgs, ... }:
+
+let
+  inherit (depot.nix) buildLisp;
+
+  src = pkgs.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..e6a616b95e46
--- /dev/null
+++ b/third_party/lisp/cl-plus-ssl.nix
@@ -0,0 +1,47 @@
+# Common Lisp bindings to OpenSSL
+{ depot, pkgs, ... }:
+
+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
+    {
+      scbl = buildLisp.bundled "uiop";
+      default = buildLisp.bundled "asdf";
+    }
+    { sbcl = buildLisp.bundled "sb-posix"; }
+  ];
+
+  native = [ pkgs.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"
+  ];
+
+  brokenOn = [
+    "ecl" # dynamic cffi
+  ];
+}
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..f793136194cb
--- /dev/null
+++ b/third_party/lisp/cl-prevalence.nix
@@ -0,0 +1,30 @@
+# cl-prevalence is an implementation of object prevalence for CL (i.e.
+# an in-memory database)
+{ depot, pkgs, ... }:
+
+let src = pkgs.fetchFromGitHub {
+  owner = "40ants";
+  repo = "cl-prevalence";
+  rev = "b1f90a525f37be0335a8761051fa5661aa74b696";
+  sha256 = "1svw58pp7jxb9l08cgnqxf0cf8qa9qsb0z2fnv86a51z7pfz4c0g";
+};
+in depot.nix.buildLisp.library {
+  name = "cl-prevalence";
+
+  deps = with depot.third_party.lisp; [
+    bordeaux-threads
+    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/cl-smtp.nix b/third_party/lisp/cl-smtp.nix
new file mode 100644
index 000000000000..a9905b5ef6f5
--- /dev/null
+++ b/third_party/lisp/cl-smtp.nix
@@ -0,0 +1,32 @@
+{ depot, pkgs, ... }:
+
+let
+  src = pkgs.fetchFromGitLab {
+    domain = "gitlab.common-lisp.net";
+    owner = "cl-smtp";
+    repo = "cl-smtp";
+    rev = "ed47d326fad867ee11323fa3a0f307b5d40e8f2b";
+    sha256 = "0vjjfapcrdc5671jz2d24h8zvpz7skq1x6pi9fvw6ls5sgms6fr0";
+  };
+
+in depot.nix.buildLisp.library {
+  name = "cl-smtp";
+  deps = with depot.third_party.lisp; [
+    usocket
+    trivial-gray-streams
+    flexi-streams
+    cl-base64
+    cl-plus-ssl
+  ];
+
+  srcs = map (f: src + ("/" + f)) [
+    "package.lisp"
+    "attachments.lisp"
+    "cl-smtp.lisp"
+    "mime-types.lisp"
+  ];
+
+  brokenOn = [
+    "ecl" # dynamic cffi
+  ];
+}
diff --git a/third_party/lisp/cl-unicode.nix b/third_party/lisp/cl-unicode.nix
new file mode 100644
index 000000000000..5fff1fbe6bb2
--- /dev/null
+++ b/third_party/lisp/cl-unicode.nix
@@ -0,0 +1,80 @@
+{ depot, pkgs, ... }:
+
+let
+  inherit (pkgs) sbcl runCommand writeText;
+  inherit (depot.nix.buildLisp) bundled;
+
+  src = pkgs.fetchFromGitHub {
+    owner = "edicl";
+    repo = "cl-unicode";
+    rev = "8073fc5634c9d4802888ac03abf11dfe383e16fa";
+    sha256 = "0ykx2s9lqfl74p1px0ik3l2izd1fc9jd1b4ra68s5x34rvjy0hza";
+  };
+
+  cl-unicode-base = depot.nix.buildLisp.library {
+    name = "cl-unicode-base";
+    deps = with depot.third_party.lisp; [
+      cl-ppcre
+    ];
+
+    srcs = map (f: src + ("/" + f)) [
+      "packages.lisp"
+      "specials.lisp"
+      "util.lisp"
+    ];
+  };
+
+  cl-unicode-build = depot.nix.buildLisp.program {
+    name = "cl-unicode-build";
+    deps = with depot.third_party.lisp; [
+      cl-unicode-base
+      flexi-streams
+      {
+        ecl = bundled "asdf";
+        default = bundled "uiop";
+      }
+    ];
+
+    srcs = (map (f: src + ("/build/" + f)) [
+      "util.lisp"
+      "char-info.lisp"
+      "read.lisp"
+    ]) ++ [
+      (runCommand "dump.lisp" {} ''
+        substitute ${src}/build/dump.lisp $out \
+          --replace ':defaults *this-file*' ":defaults (uiop:getcwd)"
+      '')
+
+      (writeText "export-create-source-files.lisp" ''
+        (in-package :cl-unicode)
+        (export 'create-source-files)
+      '')
+    ];
+
+    main = "cl-unicode:create-source-files";
+  };
+
+
+  generated = runCommand "cl-unicode-generated" {} ''
+    mkdir -p $out/build
+    mkdir -p $out/test
+    cd $out/build
+    pwd
+    ${cl-unicode-build}/bin/cl-unicode-build
+  '';
+
+in
+depot.nix.buildLisp.library {
+  name = "cl-unicode";
+  deps = [cl-unicode-base];
+  srcs = [
+    "${src}/conditions.lisp"
+    "${generated}/lists.lisp"
+    "${generated}/hash-tables.lisp"
+    "${src}/api.lisp"
+    "${generated}/methods.lisp"
+    "${src}/test-functions.lisp"
+    "${src}/derived.lisp"
+    "${src}/alias.lisp"
+  ];
+}
diff --git a/third_party/lisp/cl-who.nix b/third_party/lisp/cl-who.nix
new file mode 100644
index 000000000000..50e4e68c0348
--- /dev/null
+++ b/third_party/lisp/cl-who.nix
@@ -0,0 +1,21 @@
+{ depot, pkgs, ... }:
+
+let
+
+  src = pkgs.fetchFromGitHub {
+    owner = "edicl";
+    repo = "cl-who";
+    rev = "0d3826475133271ee8c590937136c1bc41b8cbe0";
+    sha256 = "0sc8nji9q1df04lhsiwsjy1a35996bibl31w5hp5sh8q6sa122dy";
+  };
+
+in depot.nix.buildLisp.library {
+  name = "cl-who";
+
+  srcs = map (f: src + ("/" + f)) [
+    "packages.lisp"
+    "specials.lisp"
+    "util.lisp"
+    "who.lisp"
+  ];
+}
diff --git a/third_party/lisp/cl-yacc.nix b/third_party/lisp/cl-yacc.nix
new file mode 100644
index 000000000000..d2ceb81103e2
--- /dev/null
+++ b/third_party/lisp/cl-yacc.nix
@@ -0,0 +1,15 @@
+{ depot, pkgs, ... }:
+
+let src = pkgs.fetchFromGitHub {
+    owner = "jech";
+    repo = "cl-yacc";
+    rev = "1334f5469251ffb3f8738a682dc8ee646cb26635";
+    sha256 = "16946pzf8vvadnyfayvj8rbh4zjzw90h0azz2qk1mxrvhh5wklib";
+  };
+in depot.nix.buildLisp.library {
+  name = "cl-yacc";
+
+  srcs = map (f: src + ("/" + f)) [
+    "yacc.lisp"
+  ];
+}
diff --git a/third_party/lisp/closer-mop.nix b/third_party/lisp/closer-mop.nix
new file mode 100644
index 000000000000..21fb3ba14bef
--- /dev/null
+++ b/third_party/lisp/closer-mop.nix
@@ -0,0 +1,24 @@
+# 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, pkgs, ... }:
+
+let src = pkgs.fetchFromGitHub {
+  owner = "pcostanza";
+  repo = "closer-mop";
+  rev = "8ec9577029b08ade5978236121c9ac276f78d8be"; # 2021-07-30
+  sha256 = "0dm8xsa3hzpxjd7x248pbzd8blw01a8ls7spalzgbg1g7vbn6zg5";
+};
+in depot.nix.buildLisp.library {
+  name = "closer-mop";
+
+  srcs = [
+    "${src}/closer-mop-packages.lisp"
+    "${src}/closer-mop-shared.lisp"
+    {
+      sbcl = "${src}/closer-sbcl.lisp";
+      ecl = "${src}/closer-ecl.lisp";
+      ccl = "${src}/closer-clozure.lisp";
+    }
+  ];
+}
diff --git a/third_party/lisp/closure-common.nix b/third_party/lisp/closure-common.nix
new file mode 100644
index 000000000000..591620e48705
--- /dev/null
+++ b/third_party/lisp/closure-common.nix
@@ -0,0 +1,43 @@
+{ depot, pkgs, ... }:
+
+let
+  src = pkgs.fetchFromGitHub {
+    owner = "sharplispers";
+    repo = "closure-common";
+    rev = "e3c5f5f454b72b01b89115e581c3c52a7e201e5c"; # 2018-09-09
+    sha256 = "0k5r2qxn122pxi301ijir3nayi9sg4d7yiy276l36qmzwhp4mg5n";
+  };
+
+  getSrcs = builtins.map (p: "${src}/${p}");
+in
+
+depot.nix.buildLisp.library {
+  name = "closure-common";
+
+  # closure-common.asd surpresses some warnings otherwise breaking
+  # compilation. Feature macros across implementations:
+  #
+  # ECL  #+rune-is-character #-rune-is-integer #-x&y-streams-are-stream
+  # CCL  #+rune-is-character #-rune-is-integer #-x&y-streams-are-stream
+  # SBCL #+rune-is-character #-rune-is-integer #-x&y-streams-are-stream
+  #
+  # Since all implementations agree, the alternative files aren't encoded here.
+  srcs = getSrcs [
+    "closure-common.asd"
+    "package.lisp"
+    "definline.lisp"
+    "characters.lisp"     #+rune-is-character
+    "syntax.lisp"
+    "encodings.lisp"      #-x&y-streams-are-stream
+    "encodings-data.lisp" #-x&y-streams-are-stream
+    "xstream.lisp"        #-x&y-streams-are-stream
+    "ystream.lisp"        #-x&y-streams-are-stream
+    "hax.lisp"
+  ];
+
+  deps = [
+    (depot.nix.buildLisp.bundled "asdf")
+    depot.third_party.lisp.trivial-gray-streams
+    depot.third_party.lisp.babel #+rune-is-character
+  ];
+}
diff --git a/third_party/lisp/closure-html/default.nix b/third_party/lisp/closure-html/default.nix
new file mode 100644
index 000000000000..32ab49f8d479
--- /dev/null
+++ b/third_party/lisp/closure-html/default.nix
@@ -0,0 +1,70 @@
+{ depot, pkgs, ... }:
+
+let
+  src = pkgs.applyPatches {
+    name = "closure-html-source";
+    src = pkgs.fetchFromGitHub {
+      owner = "bluelisp";
+      repo = "closure-html";
+      rev = "fee42604ae36884d2f7c5e8ffc3441fdb8ec77b7"; # 2017-04-19
+      sha256 = "105vm29qnxh6zj3rh4jwpm8dyp3b9bsva64c8a78cr270p28d032";
+    };
+
+    patches = [
+      # delete unexported and unused double defun in sgml-dtd.lisp
+      # which reference undefined CL-USER:*HTML-DTD* (!) which
+      # unlike CLOSURE-HTML:*HTML-DTD* is not involved in the
+      # packages operation.
+      ./no-double-defun.patch
+      # Patches html-parser.lisp to look for the distributed
+      # dtd files and catalog in this source derivations out
+      # path in the nix store instead of the same directory
+      # relatively to the (built) system.
+      ./dtds-from-store.patch
+    ];
+
+    postPatch = ''
+      # Inject file which defines CLOSURE-HTML:*HTML-DTD*
+      # early in the package's build since SBCL otherwise
+      # fails due to the undefined variable. Need to inject
+      # this via postPatch since using a nix file results
+      # in failure to look up the file's true name which
+      # is done for … reasons, apparently.
+      cat > src/define-html-dtd.lisp << EOF
+      (in-package :closure-html)
+      (defvar *html-dtd*)
+      EOF
+
+      # Substitute reference to @out@ of this source
+      # directory in this patched file.
+      substituteAllInPlace src/parse/html-parser.lisp
+    '';
+  };
+
+  getSrcs = builtins.map (p: "${src}/${p}");
+in
+
+depot.nix.buildLisp.library {
+  name = "closure-html";
+
+  srcs = getSrcs [
+    "src/defpack.lisp"
+    "src/define-html-dtd.lisp"
+    "src/glisp/util.lisp"
+    "src/util/clex.lisp"
+    "src/util/lalr.lisp"
+    "src/net/mime.lisp"
+    "src/parse/pt.lisp"
+    "src/parse/sgml-dtd.lisp"
+    "src/parse/sgml-parse.lisp"
+    "src/parse/html-parser.lisp"
+    "src/parse/lhtml.lisp"
+    "src/parse/unparse.lisp"
+    "src/parse/documentation.lisp"
+  ];
+
+  deps = [
+    depot.third_party.lisp.flexi-streams
+    depot.third_party.lisp.closure-common
+  ];
+}
diff --git a/third_party/lisp/closure-html/dtds-from-store.patch b/third_party/lisp/closure-html/dtds-from-store.patch
new file mode 100644
index 000000000000..a9ffd8085e89
--- /dev/null
+++ b/third_party/lisp/closure-html/dtds-from-store.patch
@@ -0,0 +1,16 @@
+diff --git a/src/parse/html-parser.lisp b/src/parse/html-parser.lisp
+index 4e45b81..5025a26 100644
+--- a/src/parse/html-parser.lisp
++++ b/src/parse/html-parser.lisp
+@@ -36,10 +36,7 @@
+         (make-pathname
+ 	 :name nil
+ 	 :type nil
+-	 :defaults (merge-pathnames
+-		    "resources/"
+-		    (asdf:component-relative-pathname
+-		     (asdf:find-system :closure-html))))))
++	 :defaults "@out@/resources/")))
+     (loop
+        :for (name . filename)
+        :in '(("-//W3O//DTD W3 HTML 3.0//EN" . "dtd/HTML-3.0")
diff --git a/third_party/lisp/closure-html/no-double-defun.patch b/third_party/lisp/closure-html/no-double-defun.patch
new file mode 100644
index 000000000000..ce7fb33abff1
--- /dev/null
+++ b/third_party/lisp/closure-html/no-double-defun.patch
@@ -0,0 +1,78 @@
+diff --git a/src/parse/sgml-dtd.lisp b/src/parse/sgml-dtd.lisp
+index de774c0..dbee852 100644
+--- a/src/parse/sgml-dtd.lisp
++++ b/src/parse/sgml-dtd.lisp
+@@ -624,73 +624,6 @@
+           (return))))
+     classes))
+ 
+-;;;; ----------------------------------------------------------------------------------------------------
+-;;;;  Compiled DTDs
+-;;;;
+-
+-;; Since parsing and 'compiling' DTDs is slow, I'll provide for a way
+-;; to (un)dump compiled DTD to stream.
+-
+-(defun dump-dtd (dtd sink)
+-  (let ((*print-pretty* nil)
+-        (*print-readably* t)
+-        (*print-circle* t))
+-    (princ "#." sink)
+-    (prin1
+-     `(MAKE-DTD :NAME ',(dtd-name dtd)
+-                :ELEMENTS (LET ((R (MAKE-HASH-TABLE :TEST #'EQ)))
+-                               (SETF ,@(let ((q nil))
+-                                         (maphash (lambda (key value)
+-                                                    (push `',value q)
+-                                                    (push `(GETHASH ',key R) q))
+-                                                  (dtd-elements dtd))
+-                                         q))
+-                               R)
+-                :ENTITIES ',(dtd-entities dtd)
+-                :RESOLVE-INFO (LET ((R (MAKE-HASH-TABLE :TEST #'EQUAL))) 
+-                                   (SETF ,@(let ((q nil))
+-                                             (maphash (lambda (key value)
+-                                                        (push `',value q)
+-                                                        (push `(GETHASH ',key R) q))
+-                                                      (dtd-resolve-info dtd))
+-                                             q))
+-                                   R)
+-                ;; XXX surclusion-cache fehlt
+-                )
+-     sink)))
+-
+-;;XXX
+-(defun save-html-dtd ()
+-  (with-open-file (sink "html-dtd.lisp" :direction :output :if-exists :new-version)
+-    (print `(in-package :sgml) sink)
+-    (let ((*package* (find-package :sgml)))
+-      (princ "(SETQ " sink)
+-      (prin1 'cl-user::*html-dtd* sink)
+-      (princ " '" sink)
+-      (dump-dtd cl-user::*html-dtd* sink)
+-      (princ ")" sink))))
+-
+-;;; --------------------------------------------------------------------------------
+-;;;  dumping DTDs
+-
+-
+-(defun dump-dtd (dtd filename)
+-  (let ((*foo* dtd))
+-    (declare (special *foo*))
+-    (with-open-file (sink (merge-pathnames filename "*.lisp")
+-                     :direction :output
+-                     :if-exists :new-version)
+-      (format sink "(in-package :sgml)(locally (declare (special *foo*))(setq *foo* '#.*foo*))"))
+-    (compile-file (merge-pathnames filename "*.lisp"))))
+-
+-(defun undump-dtd (filename)
+-  (let (*foo*)
+-    (declare (special *foo*))
+-    (load (compile-file-pathname (merge-pathnames filename "*.lisp"))
+-          :verbose nil
+-          :print nil)
+-    *foo*))
+-
+ (defmethod make-load-form ((self dtd) &optional env)
+   (declare (ignore env))
+   `(make-dtd :name                  ',(dtd-name self)
diff --git a/third_party/lisp/data-sift.nix b/third_party/lisp/data-sift.nix
new file mode 100644
index 000000000000..18593421e8ed
--- /dev/null
+++ b/third_party/lisp/data-sift.nix
@@ -0,0 +1,27 @@
+{ depot, pkgs, ... }:
+
+let
+
+  src = pkgs.fetchFromGitHub {
+    owner = "archimag";
+    repo = "data-sift";
+    rev = "fd617d8200cdcc1b87ecf45ab59bb38e8b16ef7e";
+    sha256 = "1v7gf0x4ibjzp0c56n9m77hxdgwcm9356zlk5n4l3fx4i0hj6146";
+  };
+
+in depot.nix.buildLisp.library {
+  name = "data-sift";
+  deps = with depot.third_party.lisp; [
+    cl-ppcre
+    parse-number
+    alexandria
+    puri
+  ];
+
+  srcs = map (f: src + ("/src/" + f)) [
+    "packages.lisp"
+    "conditions.lisp"
+    "sift.lisp"
+  ];
+
+}
diff --git a/third_party/lisp/defclass-std.nix b/third_party/lisp/defclass-std.nix
new file mode 100644
index 000000000000..781fd107f59d
--- /dev/null
+++ b/third_party/lisp/defclass-std.nix
@@ -0,0 +1,21 @@
+# A shortcut macro to write DEFCLASS forms quickly
+# Seems to be unmaintained (since early 2021)
+{ depot, pkgs, ... }:
+
+let src = pkgs.fetchFromGitHub {
+    owner = "EuAndreh";
+    repo = "defclass-std";
+    rev = "a4d32260a619eddf3a3e49df3af304f3c07ccec6";
+    sha256 = "1c0ymb49wd205lzxmnmsrpqyv0pn61snn2xvsbk5iis135r4fr18";
+  };
+in depot.nix.buildLisp.library {
+  name = "defclass-std";
+  deps = with depot.third_party.lisp; [
+    alexandria
+    anaphora
+  ];
+
+  srcs = map (f: src + ("/src/" + f)) [
+    "defclass-std.lisp"
+  ];
+}
diff --git a/third_party/lisp/drakma.nix b/third_party/lisp/drakma.nix
new file mode 100644
index 000000000000..3757aad7b144
--- /dev/null
+++ b/third_party/lisp/drakma.nix
@@ -0,0 +1,39 @@
+# Drakma is an HTTP client for Common Lisp.
+{ depot, pkgs, ... }:
+
+let src = pkgs.fetchFromGitHub {
+  owner = "edicl";
+  repo = "drakma";
+  rev = "87feb02bef00b11a753d5fb21a5fec526b0d0bbb";
+  sha256 = "01b80am2vrw94xmdj7f21qm7p5ys08mmpzv4nc4icql81hqr1w2m";
+};
+in depot.nix.buildLisp.library {
+  name = "drakma";
+  deps = with depot.third_party.lisp; [
+    chipz
+    chunga
+    cl-base64
+    cl-plus-ssl
+    cl-ppcre
+    flexi-streams
+    puri
+    usocket
+    (depot.nix.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"
+  ];
+
+  brokenOn = [
+    "ecl" # dynamic cffi
+  ];
+}
diff --git a/third_party/lisp/easy-routes.nix b/third_party/lisp/easy-routes.nix
new file mode 100644
index 000000000000..93aed8a66765
--- /dev/null
+++ b/third_party/lisp/easy-routes.nix
@@ -0,0 +1,29 @@
+{ depot, pkgs, ... }:
+
+let
+
+  src = pkgs.fetchFromGitHub {
+    owner = "mmontone";
+    repo = "easy-routes";
+    rev = "dab613ff419a655036a00beecee026ab6e0ba430";
+    sha256 = "06lnipwc6mmg0v5gybcnr7wn5xmn5xfd1gs19vbima777245bfka";
+  };
+
+in depot.nix.buildLisp.library {
+  name = "easy-routes";
+  deps = with depot.third_party.lisp; [
+    hunchentoot
+    routes
+  ];
+
+  srcs = map (f: src + ("/" + f)) [
+    "package.lisp"
+    "util.lisp"
+    "easy-routes.lisp"
+    "routes-map-printer.lisp"
+  ];
+
+  brokenOn = [
+    "ecl" # dynamic cffi
+  ];
+}
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/global-vars.nix b/third_party/lisp/global-vars.nix
new file mode 100644
index 000000000000..2b4078f588cd
--- /dev/null
+++ b/third_party/lisp/global-vars.nix
@@ -0,0 +1,14 @@
+{ depot, pkgs, ... }:
+
+let
+  src = pkgs.fetchFromGitHub {
+    owner = "lmj";
+    repo = "global-vars";
+    rev = "c749f32c9b606a1457daa47d59630708ac0c266e";
+    sha256 = "06m3xc8l3pgsapl8fvsi9wf6y46zs75cp9zn7zh6dc65v4s5wz3d";
+  };
+
+in depot.nix.buildLisp.library {
+  name = "global-vars";
+  srcs = [ "${src}/global-vars.lisp" ] ;
+}
diff --git a/third_party/lisp/hunchentoot.nix b/third_party/lisp/hunchentoot.nix
new file mode 100644
index 000000000000..24eae6a348cf
--- /dev/null
+++ b/third_party/lisp/hunchentoot.nix
@@ -0,0 +1,65 @@
+# Hunchentoot is a web framework for Common Lisp.
+{ depot, pkgs, ...}:
+
+let
+  src = pkgs.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"
+  ];
+
+  brokenOn = [
+    "ecl" # dynamic cffi
+  ];
+}
diff --git a/third_party/lisp/ironclad.nix b/third_party/lisp/ironclad.nix
new file mode 100644
index 000000000000..cdd829924ee5
--- /dev/null
+++ b/third_party/lisp/ironclad.nix
@@ -0,0 +1,155 @@
+{ depot, pkgs, ...}:
+
+let
+  inherit (pkgs) runCommand;
+  inherit (depot.nix.buildLisp) bundled;
+  src = pkgs.fetchFromGitHub {
+    owner = "sharplispers";
+    repo = "ironclad";
+    rev = "c3aa33080621abc10fdb0f34acc4655cc4e982a6";
+    sha256 = "0k4bib9mbrzalbl9ivkw4a7g4c7bbad1l5jw4pzkifqszy2swkr5";
+  };
+
+  getSrc = f: "${src}/src/${f}";
+
+in depot.nix.buildLisp.library {
+  name = "ironclad";
+
+  deps = with depot.third_party.lisp; [
+    (bundled "asdf")
+    { sbcl = bundled "sb-rotate-byte"; }
+    { sbcl = bundled "sb-posix"; }
+    alexandria
+    bordeaux-threads
+    nibbles
+  ];
+
+  srcs = [
+    {
+      # TODO(grfn): Figure out how to get this compiling with the assembly
+      # optimization eventually - see https://cl.tvl.fyi/c/depot/+/1333
+      sbcl = runCommand "package.lisp" {} ''
+        substitute ${src}/src/package.lisp $out \
+          --replace \#-ecl-bytecmp "" \
+          --replace '(pushnew :ironclad-assembly *features*)' ""
+      '';
+      default = getSrc "package.lisp";
+    }
+  ] ++ map getSrc [
+    "macro-utils.lisp"
+  ] ++ [
+    { sbcl = getSrc "opt/sbcl/fndb.lisp"; }
+    { sbcl = getSrc "opt/sbcl/cpu-features.lisp"; }
+    { sbcl = getSrc "opt/sbcl/x86oid-vm.lisp"; }
+
+    { ecl = getSrc "opt/ecl/c-functions.lisp"; }
+
+    { ccl = getSrc "opt/ccl/x86oid-vm.lisp"; }
+  ] ++ map getSrc [
+
+    "common.lisp"
+    "conditions.lisp"
+    "generic.lisp"
+    "util.lisp"
+
+    "ciphers/padding.lisp"
+    "ciphers/cipher.lisp"
+    "ciphers/chacha.lisp"
+    "ciphers/modes.lisp"
+    "ciphers/salsa20.lisp"
+    "ciphers/xchacha.lisp"
+    "ciphers/xsalsa20.lisp"
+    "ciphers/aes.lisp"
+    "ciphers/arcfour.lisp"
+    "ciphers/arcfour.lisp"
+    "ciphers/aria.lisp"
+    "ciphers/blowfish.lisp"
+    "ciphers/camellia.lisp"
+    "ciphers/cast5.lisp"
+    "ciphers/des.lisp"
+    "ciphers/idea.lisp"
+    "ciphers/keystream.lisp"
+    "ciphers/kalyna.lisp"
+    "ciphers/kuznyechik.lisp"
+    "ciphers/make-cipher.lisp"
+    "ciphers/misty1.lisp"
+    "ciphers/rc2.lisp"
+    "ciphers/rc5.lisp"
+    "ciphers/rc6.lisp"
+    "ciphers/seed.lisp"
+    "ciphers/serpent.lisp"
+    "ciphers/sm4.lisp"
+    "ciphers/sosemanuk.lisp"
+    "ciphers/square.lisp"
+    "ciphers/tea.lisp"
+    "ciphers/threefish.lisp"
+    "ciphers/twofish.lisp"
+    "ciphers/xor.lisp"
+    "ciphers/xtea.lisp"
+
+    "digests/digest.lisp"
+    "digests/adler32.lisp"
+    "digests/blake2.lisp"
+    "digests/blake2s.lisp"
+    "digests/crc24.lisp"
+    "digests/crc32.lisp"
+    "digests/groestl.lisp"
+    "digests/jh.lisp"
+    "digests/kupyna.lisp"
+    "digests/md2.lisp"
+    "digests/md4.lisp"
+    "digests/md5.lisp"
+    "digests/md5-lispworks-int32.lisp"
+    "digests/ripemd-128.lisp"
+    "digests/ripemd-160.lisp"
+    "digests/sha1.lisp"
+    "digests/sha256.lisp"
+    "digests/sha3.lisp"
+    "digests/sha512.lisp"
+    "digests/skein.lisp"
+    "digests/sm3.lisp"
+    "digests/streebog.lisp"
+    "digests/tiger.lisp"
+    "digests/tree-hash.lisp"
+    "digests/whirlpool.lisp"
+
+    "prng/prng.lisp"
+    "prng/generator.lisp"
+    "prng/fortuna.lisp"
+    "prng/os-prng.lisp"
+
+    "math.lisp"
+
+    "macs/mac.lisp"
+    "macs/blake2-mac.lisp"
+    "macs/blake2s-mac.lisp"
+    "macs/cmac.lisp"
+    "macs/hmac.lisp"
+    "macs/gmac.lisp"
+    "macs/poly1305.lisp"
+    "macs/siphash.lisp"
+    "macs/skein-mac.lisp"
+
+    "kdf/kdf-common.lisp"
+    "kdf/argon2.lisp"
+    "kdf/password-hash.lisp"
+    "kdf/pkcs5.lisp"
+    "kdf/scrypt.lisp"
+    "kdf/hmac.lisp"
+
+    "aead/aead.lisp"
+    "aead/eax.lisp"
+    "aead/etm.lisp"
+    "aead/gcm.lisp"
+
+    "public-key/public-key.lisp"
+    "public-key/curve25519.lisp"
+    "public-key/curve448.lisp"
+    "public-key/dsa.lisp"
+    "public-key/ed25519.lisp"
+    "public-key/ed448.lisp"
+    "public-key/elgamal.lisp"
+    "public-key/pkcs1.lisp"
+    "public-key/rsa.lisp"
+  ];
+}
diff --git a/third_party/lisp/iterate.nix b/third_party/lisp/iterate.nix
new file mode 100644
index 000000000000..5875be8d5c88
--- /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 = "c24f6715bb3b962499bb4643636baaac2df4a957"; # 2021-05-23, 1.5.3
+};
+in depot.nix.buildLisp.library {
+  name = "iterate";
+  srcs = [
+    "${src}/package.lisp"
+    "${src}/iterate.lisp"
+  ];
+}
diff --git a/third_party/lisp/lass.nix b/third_party/lisp/lass.nix
new file mode 100644
index 000000000000..457e25c7e532
--- /dev/null
+++ b/third_party/lisp/lass.nix
@@ -0,0 +1,34 @@
+{ depot, pkgs, ... }:
+
+let
+  src = pkgs.fetchFromGitHub {
+    owner = "Shinmera";
+    repo = "LASS";
+    rev = "f51b9e941ee0a2a1f76ba814dcef22f9fb5f69bf";
+    sha256 = "11mxzyx34ynsfsrs8pgrarqi9s442vkpmh7kdpzvarhj7i97g8yx";
+  };
+
+in depot.nix.buildLisp.library {
+  name = "lass";
+
+  deps = with depot.third_party.lisp; [
+    trivial-indent
+    trivial-mimes
+    physical-quantities
+    parse-float
+    cl-base64
+    (depot.nix.buildLisp.bundled "asdf")
+  ];
+
+  srcs = map (f: src + ("/" + f)) [
+    "package.lisp"
+    "readable-list.lisp"
+    "compiler.lisp"
+    "property-funcs.lisp"
+    "writer.lisp"
+    "lass.lisp"
+    "special.lisp"
+    "units.lisp"
+    "asdf.lisp"
+  ];
+}
diff --git a/third_party/lisp/lisp-binary.nix b/third_party/lisp/lisp-binary.nix
new file mode 100644
index 000000000000..3e7a43b8ac67
--- /dev/null
+++ b/third_party/lisp/lisp-binary.nix
@@ -0,0 +1,35 @@
+# A library to easily read and write complex binary formats.
+{ depot, pkgs, ... }:
+
+let src = pkgs.fetchFromGitHub {
+  owner = "j3pic";
+  repo = "lisp-binary";
+  rev = "052df578900dea59bf951e0a6749281fa73432e4";
+  sha256 = "1i1s5g01aimfq6lndcl1pnw7ly5hdh0wmjp2dj9cjjwbkz9lnwcf";
+};
+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"
+    "types.lisp"
+  ];
+
+  brokenOn = [
+    "ecl" # dynamic cffi
+  ];
+}
diff --git a/third_party/lisp/local-time.nix b/third_party/lisp/local-time.nix
new file mode 100644
index 000000000000..65fb9c37fbf2
--- /dev/null
+++ b/third_party/lisp/local-time.nix
@@ -0,0 +1,18 @@
+# Library for manipulating dates & times
+{ depot, pkgs, ... }:
+
+let src = pkgs.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/marshal.nix b/third_party/lisp/marshal.nix
new file mode 100644
index 000000000000..711e6e082d61
--- /dev/null
+++ b/third_party/lisp/marshal.nix
@@ -0,0 +1,20 @@
+{ depot, pkgs, ... }:
+
+let
+  src = pkgs.fetchFromGitHub {
+    owner = "wlbr";
+    repo = "cl-marshal";
+    rev = "eff1b15f2b0af2f26f71ad6a4dd5c4beab9299ec";
+    sha256 = "08qs6fhk38xpkkjkpcj92mxx0lgy4ygrbbzrmnivdx281syr0gwh";
+  };
+
+in depot.nix.buildLisp.library {
+  name = "marshal";
+  srcs = map (f: src + ("/" + f)) [
+    "package.lisp"
+    "serialization-format.lisp"
+    "coding-idiom.lisp"
+    "marshal.lisp"
+    "unmarshal.lisp"
+  ];
+}
diff --git a/third_party/lisp/md5.nix b/third_party/lisp/md5.nix
new file mode 100644
index 000000000000..ef265d5b6e8f
--- /dev/null
+++ b/third_party/lisp/md5.nix
@@ -0,0 +1,21 @@
+# MD5 hash implementation
+{ depot, pkgs, ... }:
+
+with depot.nix;
+
+let src = pkgs.fetchFromGitHub {
+  owner = "pmai";
+  repo = "md5";
+  rev = "b1412600f60d526ee34a7ba1596ec483da7894ab";
+  sha256 = "0lzip6b6xg7gd70xl1xmqp24fvxqj6ywjnz9lmx7988zpj20nhl2";
+};
+in buildLisp.library {
+  name = "md5";
+  deps = [
+    {
+      sbcl = buildLisp.bundled "sb-rotate-byte";
+      default = depot.third_party.lisp.flexi-streams;
+    }
+  ];
+  srcs = [ (src + "/md5.lisp") ];
+}
diff --git a/third_party/lisp/mime4cl/.skip-subtree b/third_party/lisp/mime4cl/.skip-subtree
new file mode 100644
index 000000000000..5051f60d6b86
--- /dev/null
+++ b/third_party/lisp/mime4cl/.skip-subtree
@@ -0,0 +1 @@
+prevent readTree from creating entries for subdirs that don't contain an .nix files
diff --git a/third_party/lisp/mime4cl/OWNERS b/third_party/lisp/mime4cl/OWNERS
new file mode 100644
index 000000000000..f16dd105d761
--- /dev/null
+++ b/third_party/lisp/mime4cl/OWNERS
@@ -0,0 +1,3 @@
+inherited: true
+owners:
+  - sterni
diff --git a/third_party/lisp/mime4cl/README b/third_party/lisp/mime4cl/README
new file mode 100644
index 000000000000..73f0efbda9d5
--- /dev/null
+++ b/third_party/lisp/mime4cl/README
@@ -0,0 +1,7 @@
+MIME4CL is a Common Lisp library for dealing with MIME messages.
+It has originally been written by Walter C. Pelissero and vendored
+into depot as upstream has become inactive and provides no repo
+of any kind. Upstream and depot version may diverge.
+
+Upstream Website: http://wcp.sdf-eu.org/software/#mime4cl
+Vendored Tarball: http://wcp.sdf-eu.org/software/mime4cl-20150207T211851.tbz
diff --git a/third_party/lisp/mime4cl/address.lisp b/third_party/lisp/mime4cl/address.lisp
new file mode 100644
index 000000000000..9a3bec9b2078
--- /dev/null
+++ b/third_party/lisp/mime4cl/address.lisp
@@ -0,0 +1,301 @@
+;;;  address.lisp --- e-mail address parser
+
+;;;  Copyright (C) 2007, 2008, 2009 by Walter C. Pelissero
+
+;;;  Author: Walter C. Pelissero <walter@pelissero.de>
+;;;  Project: mime4cl
+
+#+cmu (ext:file-comment "$Module: address.lisp $")
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public License
+;;; as published by the Free Software Foundation; either version 2.1
+;;; of the License, or (at your option) any later version.
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free
+;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+;;; 02111-1307 USA
+
+;;;  Although not MIME specific, this parser is often useful together
+;;;  with the MIME primitives.  It should be able to parse the address
+;;;  syntax described in RFC2822 excluding the obsolete syntax (see
+;;;  RFC822).  Have a look at the test suite to get an idea of what
+;;;  kind of addresses it can parse.
+
+(in-package :mime4cl)
+
+(defstruct (mailbox (:conc-name mbx-))
+  description
+  user
+  host
+  domain)
+
+(defstruct (mailbox-group (:conc-name mbxg-))
+  name
+  mailboxes)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun write-mailbox-domain-name (addr &optional (stream *standard-output*))
+  (when (eq :internet (mbx-domain addr))
+    (write-char #\[ stream))
+  (write-string (mbx-host addr) stream)
+  (when (eq :internet (mbx-domain addr))
+    (write-char #\] stream))
+  (when (stringp (mbx-domain addr))
+    (write-char #\. stream)
+    (write-string (mbx-domain addr) stream)))
+
+(defun write-mailbox-address (addr &optional (stream *standard-output*))
+  (write-string (mbx-user addr) stream)
+  (when (mbx-host addr)
+    (write-char #\@ stream)
+    (write-mailbox-domain-name addr stream)))
+
+(defmethod mbx-domain-name ((MBX mailbox))
+  "Return the complete domain name string of MBX, in the form
+\"host.domain\"."
+  (with-output-to-string (out)
+    (write-mailbox-domain-name mbx out)))
+
+(defmethod mbx-address ((mbx mailbox))
+  "Return the e-mail address string of MBX, in the form
+\"user@host.domain\"."
+  (with-output-to-string (out)
+    (write-mailbox-address mbx out)))
+
+(defun write-mailbox (addr &optional (stream *standard-output*))
+  (awhen (mbx-description addr)
+    (write it :stream stream :readably t)
+    (write-string " <" stream))
+  (write-mailbox-address addr stream)
+  (awhen (mbx-description addr)
+    (write-char #\> stream)))
+
+(defun write-mailbox-group (grp &optional (stream *standard-output*))
+  (write-string (mbxg-name grp) stream)
+  (write-string ": " stream)
+  (loop
+     for mailboxes on (mbxg-mailboxes grp)
+     for mailbox = (car mailboxes)
+     do (write-mailbox mailbox stream)
+     unless (endp (cdr mailboxes))
+     do (write-string ", " stream))
+  (write-char #\; stream))
+
+(defmethod print-object ((mbx mailbox) stream)
+  (if (or *print-readably* *print-escape*)
+      (call-next-method)
+      (write-mailbox mbx stream)))
+
+(defmethod print-object ((grp mailbox-group) stream)
+  (if (or *print-readably* *print-escape*)
+      (call-next-method)
+      (write-mailbox-group grp stream)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun parser-make-mailbox (description address-list)
+  (make-mailbox :description description
+		:user (car address-list)
+		:host (cadr address-list)
+		:domain (when (cddr address-list)
+			  (string-concat (cddr address-list) "."))))
+
+
+(defun populate-grammar ()
+  (defrule address-list
+      := (+ address ","))
+
+  (defrule address
+      := mailbox
+      := group)
+
+  (defrule mailbox
+      := display-name? angle-addr comment?
+      :reduce (parser-make-mailbox (or display-name comment) angle-addr)
+      := addr-spec comment?
+      :reduce (parser-make-mailbox comment addr-spec))
+
+  (defrule angle-addr
+      := "<" addr-spec ">")
+
+  (defrule group
+      := display-name ":" mailbox-list ";"
+      :reduce (make-mailbox-group :name display-name :mailboxes mailbox-list))
+
+  (defrule display-name
+      := phrase
+      :reduce (string-concat phrase " "))
+
+  (defrule phrase
+      := word+)
+
+  (defrule word
+      := atext
+      := string)
+
+  (defrule mailbox-list
+      := (+ mailbox ","))
+
+  (defrule addr-spec
+      := local-part "@" domain :reduce (cons local-part domain))
+
+  (defrule local-part
+      := dot-atom :reduce (string-concat dot-atom ".")
+      := string)
+
+  (defrule domain
+      := dot-atom
+      := domain-literal :reduce (list domain-literal :internet))
+
+  ;; actually, according to the RFC, dot-atoms don't allow spaces in
+  ;; between but these rules do
+  (defrule dot-atom
+      := (+ atom "."))
+
+  (defrule atom
+      := atext+
+      :reduce (apply #'concatenate 'string atext)))
+
+(deflazy define-grammar
+  (let ((*package* #.*package*)
+	(*compile-print* (when npg::*debug* t)))
+    (reset-grammar)
+    (format t "~&creating e-mail address grammar...~%")
+    (populate-grammar)
+    (let ((grammar (npg:generate-grammar #'string=)))
+      (reset-grammar)
+      (npg:print-grammar-figures grammar)
+      grammar)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; The lexical analyser
+
+(defstruct cursor
+  stream
+  (position 0))
+
+(defun read-delimited-string (stream end-char &key nesting-start-char (escape-char #\\))
+  (labels ((collect ()
+	     (with-output-to-string (out)
+	       (loop
+		  for c = (read-char stream nil)
+		  while (and c (not (char= c end-char)))
+		  do (cond ((char= c escape-char)
+			    (awhen (read-char stream nil)
+			      (write-char it out)))
+			   ((and nesting-start-char
+				 (char= c nesting-start-char))
+			    (write-char nesting-start-char out)
+			    (write-string (collect) out)
+			    (write-char end-char out))
+			   (t (write-char c out)))))))
+    (collect)))
+
+
+(defun read-string (cursor)
+  (make-token :type 'string
+	      :value (read-delimited-string (cursor-stream cursor) #\")
+	      :position (incf (cursor-position cursor))))
+
+(defun read-domain-literal (cursor)
+  (make-token :type 'domain-literal
+	      :value (read-delimited-string (cursor-stream cursor) #\])
+	      :position (incf (cursor-position cursor))))
+
+(defun read-comment (cursor)
+  (make-token :type 'comment
+	      :value (read-delimited-string (cursor-stream cursor) #\) :nesting-start-char #\()
+	      :position (incf (cursor-position cursor))))
+
+(declaim (inline atom-component-p))
+(defun atom-component-p (c)
+  (declare (type character c))
+  (not (find c " ()\"[]@.<>:;,")))
+
+(defun read-atext (first-character cursor)
+  (be string (with-output-to-string (out)
+	       (write-char first-character out)
+	       (loop
+		  for c = (read-char (cursor-stream cursor) nil)
+		  while (and c (atom-component-p c))
+		  do (write-char c out)
+		  finally (when c
+			    (unread-char c (cursor-stream cursor)))))
+    (make-token :type 'atext
+		:value string
+		:position (incf (cursor-position cursor)))))
+
+(defmethod read-next-tokens ((cursor cursor))
+  (flet ((make-keyword (c)
+	   (make-token :type 'keyword
+		       :value (string c)
+		       :position (incf (cursor-position cursor)))))
+    (be in (cursor-stream cursor)
+      (loop
+	 for c = (read-char in nil)
+	 while c
+	 unless (whitespace-p c)
+	 return (list
+		 (cond ((char= #\( c)
+			(read-comment cursor))
+		       ((char= #\" c)
+			(read-string cursor))
+		       ((char= #\[ c)
+			(read-domain-literal cursor))
+		       ((find c "@.<>:;,")
+			(make-keyword c))
+		       (t
+			;; anything else is considered a text atom even
+			;; though it's just a single character
+			(read-atext c cursor))))))))
+
+(defun analyse-string (string)
+  "Return the list of tokens produced by a lexical analysis of
+STRING.  These are the tokens that would be seen by the parser."
+  (with-input-from-string (stream string)
+    (be cursor (make-cursor :stream stream)
+      (loop
+	 for tokens = (read-next-tokens cursor)
+	 until (endp tokens)
+	 append tokens))))
+
+(defun mailboxes-only (list-of-mailboxes-and-groups)
+  "Return a flat list of MAILBOX-ADDRESSes from
+LIST-OF-MAILBOXES-AND-GROUPS, which is the kind of list returned
+by PARSE-ADDRESSES.  This turns out to be useful when your
+program is not interested in mailbox groups and expects the user
+addresses only."
+  (mapcan #'(lambda (mbx)
+	      (if (typep mbx 'mailbox-group)
+		  (mbxg-mailboxes mbx)
+		  (list mbx)))
+	  list-of-mailboxes-and-groups))
+
+(defun parse-addresses (string &key no-groups)
+  "Parse STRING and return a list of MAILBOX-ADDRESSes or
+MAILBOX-GROUPs.  If STRING is unparsable return NIL.  If
+NO-GROUPS is true, return a flat list of mailboxes throwing away
+the group containers, if any."
+  (be grammar (force define-grammar)
+    (with-input-from-string (stream string)
+      (be* cursor (make-cursor :stream stream)
+	   mailboxes (ignore-errors	; ignore parsing errors
+		       (parse grammar 'address-list cursor))
+	(if no-groups
+	    (mailboxes-only mailboxes)
+	    mailboxes)))))
+
+(defun debug-addresses (string)
+  "More or less like PARSE-ADDRESSES, but don't ignore parsing errors."
+  (be grammar (force define-grammar)
+    (with-input-from-string (stream string)
+      (be cursor (make-cursor :stream stream)
+	(parse grammar 'address-list cursor)))))
+
diff --git a/third_party/lisp/mime4cl/default.nix b/third_party/lisp/mime4cl/default.nix
new file mode 100644
index 000000000000..5165774074c1
--- /dev/null
+++ b/third_party/lisp/mime4cl/default.nix
@@ -0,0 +1,48 @@
+# Copyright (C) 2021 by the TVL Authors
+# SPDX-License-Identifier: LGPL-2.1-or-later
+{ depot, pkgs, ... }:
+
+depot.nix.buildLisp.library {
+  name = "mime4cl";
+
+  deps = [
+    depot.third_party.lisp.sclf
+    depot.third_party.lisp.npg
+  ];
+
+  srcs = [
+    ./package.lisp
+    ./endec.lisp
+    ./streams.lisp
+    ./mime.lisp
+    ./address.lisp
+  ];
+
+  tests = {
+    name = "mime4cl-tests";
+
+    srcs = [
+      ./test/rt.lisp
+      ./test/package.lisp
+      (pkgs.writeText "nix-samples.lisp" ''
+        (in-package :mime4cl-tests)
+
+        ;; missing from the tarball completely
+        (defvar *samples-directory* (pathname "/this/does/not/exist"))
+        ;; override auto discovery which doesn't work in store
+        (defvar *sample1-file* (pathname "${./test/sample1.msg}"))
+      '')
+      ./test/endec.lisp
+      ./test/address.lisp
+      ./test/mime.lisp
+    ];
+
+    expression = "(rtest:do-tests)";
+  };
+
+  # limited by sclf
+  brokenOn = [
+    "ccl"
+    "ecl"
+  ];
+}
diff --git a/third_party/lisp/mime4cl/endec.lisp b/third_party/lisp/mime4cl/endec.lisp
new file mode 100644
index 000000000000..f63eb3c22e1d
--- /dev/null
+++ b/third_party/lisp/mime4cl/endec.lisp
@@ -0,0 +1,683 @@
+;;;  endec.lisp --- encoder/decoder functions
+
+;;;  Copyright (C) 2005-2008, 2010 by Walter C. Pelissero
+
+;;;  Author: Walter C. Pelissero <walter@pelissero.de>
+;;;  Project: mime4cl
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public License
+;;; as published by the Free Software Foundation; either version 2.1
+;;; of the License, or (at your option) any later version.
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free
+;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+;;; 02111-1307 USA
+
+
+(in-package :mime4cl)
+
+
+;; Thank you SBCL for rendering constants totally useless!
+(defparameter +base64-encode-table+
+  "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=")
+
+(defparameter +base64-decode-table+
+  (let ((da (make-array 256 :element-type '(unsigned-byte 8) :initial-element 65)))
+    (dotimes (i 64)
+      (setf (aref da (char-code (char +base64-encode-table+ i))) i))
+    da))
+
+(declaim (type (simple-array (unsigned-byte 8)) +base64-decode-table+)
+	 (type simple-string +base64-encode-table+))
+
+(defvar *base64-line-length* 76
+  "Maximum length of the encoded base64 line.  NIL means it can
+be of unlimited length \(no line breaks will be done by the
+encoding function).")
+
+(defvar *quoted-printable-line-length* 72
+  "Maximum length of the encoded quoted printable line.  NIL
+means it can be of unlimited length \(no line breaks will be done
+by the encoding function).")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defclass decoder ()
+  ((input-function :initarg :input-function
+		   :reader decoder-input-function
+		   :type function
+		   :documentation
+		   "Function is called repeatedly by the decoder methods to get the next character.
+It should return a character os NIL (indicating EOF)."))
+  (:documentation
+   "Abstract base class for decoders."))
+
+(defclass parsing-decoder (decoder)
+  ((parser-errors :initform nil
+		  :initarg :parser-errors
+		  :reader decoder-parser-errors
+		  :type boolean))
+  (:documentation
+   "Abstract base class for decoders that do parsing."))
+
+(defclass encoder ()
+  ((output-function :initarg :output-function
+		    :reader encoder-output-function
+		    :type function
+		    :documentation
+		    "Function is called repeatedly by the encoder methods to output a character.
+It should expect a character as its only argument."))
+  (:documentation
+   "Abstract base class for encoders."))
+
+(defclass line-encoder (encoder)
+  ((column :initform 0
+	   :type fixnum)
+   (line-length :initarg :line-length
+		:initform nil
+		:reader encoder-line-length
+		:type (or fixnum null)))
+  (:documentation
+   "Abstract base class for line encoders."))
+
+(defclass 8bit-decoder (decoder)
+  ()
+  (:documentation
+   "Class for decoders that do nothing."))
+
+(defclass 8bit-encoder (encoder)
+  ()
+  (:documentation
+   "Class for encoders that do nothing."))
+
+(defclass 7bit-decoder (decoder)
+  ()
+  (:documentation
+   "Class for decoders that do nothing."))
+
+(defclass 7bit-encoder (encoder)
+  ()
+  (:documentation
+   "Class for encoders that do nothing."))
+
+(defclass byte-decoder (decoder)
+  ()
+  (:documentation
+   "Class for decoders that turns chars to bytes."))
+
+(defclass byte-encoder (encoder)
+  ()
+  (:documentation
+   "Class for encoders that turns bytes to chars."))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defgeneric encoder-write-byte (encoder byte))
+(defgeneric encoder-finish-output (encoder))
+(defgeneric decoder-read-byte (decoder))
+
+(defmethod encoder-finish-output ((encoder encoder))
+  (values))
+
+(defmethod encoder-write-byte ((encoder 8bit-encoder) byte)
+  (funcall (slot-value encoder 'output-function)
+	   (code-char byte))
+  (values))
+
+(defmethod decoder-read-byte ((decoder 8bit-decoder))
+  (awhen (funcall (slot-value decoder 'input-function))
+    (char-code it)))
+
+(defmethod encoder-write-byte ((encoder 7bit-encoder) byte)
+  (funcall (slot-value encoder 'output-function)
+	   (code-char (logand #x7F byte)))
+  (values))
+
+(defmethod decoder-read-byte ((decoder 7bit-decoder))
+  (awhen (funcall (slot-value decoder 'input-function))
+    (logand #x7F (char-code it))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun decoder-read-sequence (sequence decoder &key (start 0) (end (length sequence)))
+  (declare (optimize (speed 3) (safety 0) (debug 0))
+	   (type fixnum start end)
+	   (type vector sequence))
+  (loop
+     for i fixnum from start below end
+     for byte = (decoder-read-byte decoder)
+     while byte
+     do (setf (aref sequence i) byte)
+     finally (return i)))
+
+(defun decoder-read-line (decoder)
+  (with-output-to-string (str)
+    (loop
+       for byte = (decoder-read-byte decoder)
+       unless byte
+       do (return-from decoder-read-line nil)
+       do (be c (code-char byte)
+	    (cond ((char= c #\return)
+		   ;; skip the newline
+		   (decoder-read-byte decoder)
+		   (return nil))
+		  ((char= c #\newline)
+		   ;; the #\return was missing
+		   (return nil))
+		  (t (write-char c str)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(declaim (inline parse-hex))
+(defun parse-hex (c1 c2)
+  "Parse two characters as hexadecimal and return their combined
+value."
+  (declare (optimize (speed 3) (safety 0) (debug 0))
+	   (type character c1 c2))
+  (flet ((digit-value (char)
+	   (or (position char "0123456789ABCDEF")
+	       (return-from parse-hex nil))))
+    (+ (* 16 (digit-value c1))
+       (digit-value c2))))
+
+(defclass quoted-printable-decoder (parsing-decoder)
+  ((saved-bytes :initform (make-queue))))
+
+(defmethod decoder-read-byte ((decoder quoted-printable-decoder))
+  (declare (optimize (speed 3) (safety 0) (debug 0)))
+  (with-slots (input-function saved-bytes parser-errors) decoder
+    (declare (type function input-function))
+    (labels ((saveb (b)
+	       (queue-append saved-bytes b)
+	       (values))
+	     (save (c)
+	       (saveb (char-code c)))
+	     (push-next ()
+	       (be c (funcall input-function)
+		 (declare (type (or null character) c))
+		 (cond ((not c))
+		       ((or (char= c #\space)
+			    (char= c #\tab))
+			(save c)
+			(push-next))
+		       ((char= c #\=)
+			(be c1 (funcall input-function)
+			  (cond ((not c1)
+				 (save #\=))
+				((char= c1 #\return)
+				 ;; soft line break: skip the next
+				 ;; character which we assume to be a
+				 ;; newline (pity if it isn't)
+				 (funcall input-function)
+				 (push-next))
+				((char= c1 #\newline)
+				 ;; soft line break: the #\return is
+				 ;; missing, but we are tolerant
+				 (push-next))
+				(t
+				 ;; hexadecimal sequence: get the 2nd digit
+				 (be c2 (funcall input-function)
+				   (if c2
+				       (aif (parse-hex c1 c2)
+					    (saveb it)
+					    (if parser-errors
+						(error "invalid hex sequence ~A~A" c1 c2)
+						(progn
+						  (save #\=)
+						  (save c1)
+						  (save c2))))
+				       (progn
+					 (save c)
+					 (save c1))))))))
+		       (t
+			(save c))))))
+      (or (queue-pop saved-bytes)
+	  (progn
+	    (push-next)
+	    (queue-pop saved-bytes))))))
+
+(defmacro make-encoder-loop (encoder-class input-form output-form)
+  (with-gensyms (encoder byte)
+    `(loop
+	with ,encoder = (make-instance ',encoder-class
+				       :output-function #'(lambda (char) ,output-form))
+	for ,byte = ,input-form
+	while ,byte
+	do (encoder-write-byte ,encoder ,byte)
+	finally (encoder-finish-output ,encoder))))
+
+(defmacro make-decoder-loop (decoder-class input-form output-form &key parser-errors)
+  (with-gensyms (decoder)
+    `(loop
+	with ,decoder = (make-instance ',decoder-class
+				       :input-function #'(lambda () ,input-form)
+				       :parser-errors ,parser-errors)
+	for byte = (decoder-read-byte ,decoder)
+	while byte
+	do ,output-form)))
+
+(defun decode-quoted-printable-stream (in out &key parser-errors)
+  "Read from stream IN a quoted printable text and write to
+binary output OUT the decoded stream of bytes."
+  (make-decoder-loop quoted-printable-decoder
+		     (read-byte in nil) (write-byte byte out)
+		     :parser-errors parser-errors))
+
+(defmacro make-stream-to-sequence-decoder (decoder-class input-form &key parser-errors)
+  "Decode the character stream STREAM and return a sequence of bytes."
+  (with-gensyms (output-sequence)
+    `(be ,output-sequence (make-array 0
+				      :element-type '(unsigned-byte 8)
+				      :fill-pointer 0
+				      :adjustable t)
+       (make-decoder-loop ,decoder-class ,input-form
+			  (vector-push-extend byte ,output-sequence)
+			  :parser-errors ,parser-errors)
+       ,output-sequence)))
+
+(defun decode-quoted-printable-stream-to-sequence (stream &key parser-errors)
+  "Read from STREAM a quoted printable text and return a vector of
+bytes."
+  (make-stream-to-sequence-decoder quoted-printable-decoder
+    (read-char stream nil)
+    :parser-errors parser-errors))
+
+(defun decode-quoted-printable-string (string &key (start 0) (end (length string)) parser-errors)
+  "Decode STRING as quoted printable sequence of characters and
+return a decoded sequence of bytes."
+  (with-input-from-string (in string :start start :end end)
+    (decode-quoted-printable-stream-to-sequence in :parser-errors parser-errors)))
+
+(defclass quoted-printable-encoder (line-encoder)
+  ((line-length :initform *quoted-printable-line-length*
+		:type (or fixnum null))
+   (pending-space :initform nil
+		  :type boolean)))
+
+(defmethod encoder-write-byte ((encoder quoted-printable-encoder) byte)
+  (declare (optimize (speed 3) (safety 0) (debug 0))
+	   (type (unsigned-byte 8) byte))
+  (with-slots (output-function column pending-space line-length) encoder
+    (declare (type function output-function)
+	     (type fixnum column)
+	     (type (or fixnum null) line-length)
+	     (type boolean pending-space))
+    (labels ((out (c)
+	       (funcall output-function c)
+	       (values))
+	     (outs (str)
+	       (declare (type simple-string str))
+	       (loop
+		  for c across str
+		  do (out c))
+	       (values))
+	     (out2hex (x)
+	       (declare (type fixnum x))
+	       (multiple-value-bind (a b) (truncate x 16)
+		 (out (digit-char a 16))
+		 (out (digit-char b 16)))))
+      (cond ((= byte #.(char-code #\newline))
+	     (when pending-space
+	       (outs "=20")
+	       (setf pending-space nil))
+	     (out #\newline)
+	     (setf column 0))
+	    ((= byte #.(char-code #\space))
+	     (if pending-space
+		 (progn
+		   (out #\space)
+		   (f++ column))
+		 (setf pending-space t)))
+	    (t
+	     (when pending-space
+	       (out #\space)
+	       (f++ column)
+	       (setf pending-space nil))
+	     (cond ((or (< byte 32)
+			(= byte #.(char-code #\=))
+			(> byte 126))
+		    (out #\=)
+		    (out2hex byte)
+		    (f++ column 3))
+		   (t
+		    (out (code-char byte))
+		    (f++ column)))))
+      (when (and line-length
+		 (>= column line-length))
+	;; soft line break
+	(outs #.(coerce '(#\= #\newline) 'string))
+	(setf column 0)))))
+
+(defmethod encoder-finish-output ((encoder quoted-printable-encoder))
+  (declare (optimize (speed 3) (safety 0) (debug 0)))
+  (with-slots (pending-space output-function) encoder
+    (declare (type boolean pending-space)
+	     (type function output-function))
+    (when pending-space
+      (flet ((outs (s)
+	       (declare (type simple-string s))
+	       (loop
+		  for c across s
+		  do (funcall output-function c))))
+	(setf pending-space nil)
+	(outs "=20")))))
+
+(defun encode-quoted-printable-stream (in out)
+  "Read from IN a stream of bytes and write to OUT a stream of
+characters quoted printables encoded."
+  (make-encoder-loop quoted-printable-encoder
+		     (read-byte in nil)
+		     (write-char char out)))
+
+(defun encode-quoted-printable-sequence-to-stream (sequence stream &key (start 0) (end (length sequence)))
+  "Encode the sequence of bytes SEQUENCE and write to STREAM a
+quoted printable sequence of characters."
+  (be i start
+    (make-encoder-loop quoted-printable-encoder
+     (when (< i end)
+       (prog1 (elt sequence i)
+	 (f++ i)))
+     (write-char char stream))))
+
+(defun encode-quoted-printable-sequence (sequence &key (start 0) (end (length sequence)))
+  "Encode the sequence of bytes SEQUENCE into a quoted printable
+string and return it."
+  (with-output-to-string (out)
+    (encode-quoted-printable-sequence-to-stream sequence out :start start :end end)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defclass base64-encoder (line-encoder)
+  ((line-length :initform *base64-line-length*)
+   (bitstore :initform 0
+	     :type fixnum)
+   (bytecount :initform 0
+	      :type fixnum))
+  (:documentation
+   "Class for Base64 encoder output streams."))
+
+
+(eval-when (:load-toplevel :compile-toplevel)
+  (unless (> most-positive-fixnum (expt 2 (* 8 3)))))
+
+(macrolet ((with-encoder (encoder &body forms)
+	     `(with-slots (bitstore line-length column bytecount output-function) ,encoder
+		(declare (type fixnum column)
+			 (type fixnum bitstore bytecount)
+			 (type (or fixnum null) line-length)
+			 (type function output-function))
+		(labels ((emitr (i b)
+			   (declare (type fixnum i b))
+			   (unless (zerop i)
+			     (emitr (1- i) (ash b -6)))
+			   (emitc
+			    (char +base64-encode-table+ (logand b #x3F)))
+			   (values))
+			 (out (c)
+			   (funcall output-function c))
+			 (eol ()
+			   (progn
+			     (out #\return)
+			     (out #\newline)))
+			 (emitc (char)
+			   (out char)
+			   (f++ column)
+			   (when (and line-length
+				      (>= column line-length))
+			     (setf column 0)
+			     (eol))))
+		  (declare (inline out eol emitc)
+			   (ignorable (function emitr) (function out) (function eol) (function emitc)))
+		  ,@forms))))
+  ;; For this function to work correctly, the FIXNUM must be at least
+  ;; 24 bits.
+  (defmethod encoder-write-byte ((encoder base64-encoder) byte)
+    (declare (optimize (speed 3) (safety 0) (debug 0))
+	     (type (unsigned-byte 8) byte))
+    (with-encoder encoder
+      (setf bitstore (logior byte (the fixnum (ash bitstore 8))))
+      (f++ bytecount)
+      (when (= 3 bytecount)
+	(emitr 3 bitstore)
+	(setf bitstore 0
+	      bytecount 0)))
+    (values))
+
+  (defmethod encoder-finish-output ((encoder base64-encoder))
+    (with-encoder encoder
+      (unless (zerop bytecount)
+	(multiple-value-bind (saved6 rest) (truncate (* bytecount 8) 6)
+	  (setf bitstore (ash bitstore (- 6 rest)))
+	  (emitr saved6 bitstore)
+	  (dotimes (x (- 3 saved6))
+	    (emitc #\=))))
+      (when (and line-length
+		 (not (zerop column)))
+	(eol)))
+    (values)))
+
+(defun encode-base64-stream (in out)
+  "Read a byte stream from IN and write to OUT the encoded Base64
+character stream."
+  (make-encoder-loop base64-encoder (read-byte in nil)
+		     (write-char char out)))
+
+(defun encode-base64-sequence-to-stream (sequence stream &key (start 0) (end (length sequence)))
+  "Encode the sequence of bytes SEQUENCE and write to STREAM the
+Base64 character sequence."
+  (be i start
+    (make-encoder-loop base64-encoder
+		       (when (< i end)
+			 (prog1 (elt sequence i)
+			   (incf i)))
+		       (write-char char stream))))
+
+(defun encode-base64-sequence (sequence &key (start 0) (end (length sequence)))
+  "Encode the sequence of bytes SEQUENCE into a Base64 string and
+return it."
+  (with-output-to-string (out)
+    (encode-base64-sequence-to-stream sequence out :start start :end end)))
+
+(defclass base64-decoder (parsing-decoder)
+  ((bitstore :initform 0
+	     :type fixnum)
+   (bytecount :initform 0 :type fixnum))
+  (:documentation
+   "Class for Base64 decoder input streams."))
+
+(defmethod decoder-read-byte ((decoder base64-decoder))
+  (declare (optimize (speed 3) (safety 0) (debug 0)))
+  (with-slots (bitstore bytecount input-function) decoder
+    (declare (type fixnum bitstore bytecount)
+	     (type function input-function))
+    (labels ((in6 ()
+	       (loop
+		  for c = (funcall input-function)
+		  when (or (not c) (char= #\= c))
+		  do (return-from decoder-read-byte nil)
+		  do (be sextet (aref +base64-decode-table+ (char-code c))
+		       (unless (= sextet 65) ; ignore unrecognised characters
+			 (return sextet)))))
+	     (push6 (sextet)
+	       (declare (type fixnum sextet))
+	       (setf bitstore
+		     (logior sextet (the fixnum (ash bitstore 6))))))
+      (case bytecount
+	(0
+	 (setf bitstore (in6))
+	 (push6 (in6))
+	 (setf bytecount 1)
+	 (ash bitstore -4))
+	(1
+	 (push6 (in6))
+	 (setf bytecount 2)
+	 (logand #xFF (ash bitstore -2)))
+	(2
+	 (push6 (in6))
+	 (setf bytecount 0)
+	 (logand #xFF bitstore))))))
+
+(defun decode-base64-stream (in out &key parser-errors)
+  "Read from IN a stream of characters Base64 encoded and write
+to OUT a stream of decoded bytes."
+  (make-decoder-loop base64-decoder
+		     (read-byte in nil) (write-byte byte out)
+		     :parser-errors parser-errors))
+
+(defun decode-base64-stream-to-sequence (stream &key parser-errors)
+  (make-stream-to-sequence-decoder base64-decoder
+				   (read-char stream nil)
+				   :parser-errors parser-errors))
+
+(defun decode-base64-string (string &key (start 0) (end (length string)) parser-errors)
+  (with-input-from-string (in string :start start :end end)
+    (decode-base64-stream-to-sequence in :parser-errors parser-errors)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun dump-stream-binary (in out)
+  "Write content of IN character stream to OUT binary stream."
+  (loop
+     for c = (read-char in nil)
+     while c
+     do (write-byte (char-code c) out)))
+
+(defun decode-stream (in out encoding &key parser-errors-p)
+  (gcase (encoding string-equal)
+    (:quoted-printable
+     (decode-quoted-printable-stream in out
+				     :parser-errors parser-errors-p))
+    (:base64
+     (decode-base64-stream in out
+			   :parser-errors parser-errors-p))
+    (otherwise
+     (dump-stream-binary in out))))
+
+(defun decode-string (string encoding &key parser-errors-p)
+  (gcase (encoding string-equal)
+    (:quoted-printable
+     (decode-quoted-printable-string string
+				     :parser-errors parser-errors-p))
+    (:base64
+     (decode-base64-string string
+			   :parser-errors parser-errors-p))
+    (otherwise
+     (map '(vector (unsigned-byte 8)) #'char-code string))))
+
+(defun decode-stream-to-sequence (stream encoding &key parser-errors-p)
+  (gcase (encoding string-equal)
+    (:quoted-printable
+     (decode-quoted-printable-stream-to-sequence stream
+						 :parser-errors parser-errors-p))
+    (:base64
+     (decode-base64-stream-to-sequence stream
+				       :parser-errors parser-errors-p))
+    (otherwise
+     (loop
+	with output-sequence = (make-array 0 :fill-pointer 0
+					   :element-type '(unsigned-byte 8)
+					   :adjustable t)
+	for c = (read-char stream nil)
+	while c
+	do (vector-push-extend (char-code c) output-sequence)
+	finally (return output-sequence)))))
+
+(defun encode-stream (in out encoding)
+  (gcase (encoding string-equal)
+    (:quoted-printable
+     (encode-quoted-printable-stream in out))
+    (:base64
+     (encode-base64-stream in out))
+    (otherwise
+     (loop
+	for byte = (read-byte in nil)
+	while byte
+	do (write-char (code-char byte) out)))))
+
+(defun encode-sequence-to-stream (sequence out encoding)
+  (gcase (encoding string-equal)
+    (:quoted-printable
+     (encode-quoted-printable-sequence-to-stream sequence out))
+    (:base64
+     (encode-base64-sequence-to-stream sequence out))
+    (otherwise
+     (loop
+	for byte across sequence
+	do (write-char (code-char byte) out)))))
+
+(defun encode-sequence (sequence encoding)
+  (gcase (encoding string-equal)
+    (:quoted-printable
+     (encode-quoted-printable-sequence sequence))
+    (:base64
+     (encode-base64-sequence sequence))
+    (otherwise
+     (map 'string #'code-char sequence))))
+
+;; This is similar to decode-quoted-printable-string but #\_ is used
+;; instead of space
+(defun decode-quoted-printable-RFC2047-string (string &key (start 0) (end (length string)))
+  "Decode a string encoded according to the quoted printable
+method of RFC2047 and return a sequence of bytes."
+  (declare (optimize (speed 3) (debug 0) (safety 0))
+	   (type simple-string string))
+  (loop
+     with output-sequence = (make-array (length string)
+					:element-type '(unsigned-byte 8)
+					:fill-pointer 0)
+     for i fixnum from start by 1 below end
+     for c = (char string i)
+     do (case c
+	  (#\=
+	   (vector-push-extend (or (parse-hex (char string (1+ i)) (char string (+ 2 i)))
+				   ;; the char code was malformed
+				   #.(char-code #\?))
+			       output-sequence)
+	   (f++ i 2))
+	  (#\_ (vector-push-extend #.(char-code #\space) output-sequence))
+	  (otherwise
+	   (vector-push-extend (char-code c) output-sequence)))
+       finally (return output-sequence)))
+
+(defun decode-RFC2047-string (encoding string &key (start 0) (end (length string)))
+  "Decode STRING according to RFC2047 and return a sequence of
+bytes."
+  (gcase (encoding string-equal)
+    ("Q" (decode-quoted-printable-RFC2047-string string :start start :end end))
+    ("B" (decode-base64-string string :start start :end end))
+    (t string)))
+
+(defun parse-RFC2047-text (text)
+  "Parse the string TEXT according to RFC2047 rules and return a list
+of pairs and strings.  The strings are the bits interposed between the
+actually encoded text.  The pairs are composed of: a decoded byte
+sequence, a charset string indicating the original coding."
+  (loop
+     with result = '()
+     with previous-end = 0
+     for start = (search "=?" text :start2 previous-end)
+     while start
+     for first-? = (position #\? text :start (+ 2 start))
+     while first-?
+     for second-? = (position #\? text :start (1+ first-?))
+     while second-?
+     for end = (search "?=" text :start2 (1+ second-?))
+     while end
+     do (let ((charset (string-upcase (subseq text (+ 2 start) first-?)))
+	      (encoding (subseq text (1+ first-?) second-?)))
+	  (unless (= previous-end start)
+	    (push (subseq text previous-end start)
+		  result))
+	  (setf previous-end (+ end 2))
+	  (push (cons (decode-RFC2047-string encoding text :start (1+ second-?) :end end)
+		      charset)
+		result))
+     finally (unless (= previous-end (length text))
+	       (push (subseq text previous-end (length text))
+		     result))
+       (return (nreverse result))))
diff --git a/third_party/lisp/mime4cl/mime.lisp b/third_party/lisp/mime4cl/mime.lisp
new file mode 100644
index 000000000000..e35ae6bea547
--- /dev/null
+++ b/third_party/lisp/mime4cl/mime.lisp
@@ -0,0 +1,1061 @@
+;;;  mime4cl.lisp --- MIME primitives for Common Lisp
+
+;;;  Copyright (C) 2005-2008, 2010 by Walter C. Pelissero
+;;;  Copyright (C) 2021 by the TVL Authors
+
+;;;  Author: Walter C. Pelissero <walter@pelissero.de>
+;;;  Project: mime4cl
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public License
+;;; as published by the Free Software Foundation; either version 2.1
+;;; of the License, or (at your option) any later version.
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free
+;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+;;; 02111-1307 USA
+
+(in-package :mime4cl)
+
+(defclass mime-part ()
+  ((subtype
+    :type (or string null)
+    :initarg :subtype
+    :accessor mime-subtype
+    ;; some mime types don't require a subtype
+    :initform nil)
+   (type-parameters
+    :type list
+    :initarg :type-parameters
+    :initform '()
+    :accessor mime-type-parameters)
+   (version
+    :type (or string null)
+    :initarg :mime-version
+    :initform "1.0"
+    :accessor mime-version)
+   (id
+    :initform nil
+    :initarg :id
+    :reader mime-id)
+   (description
+    :initform nil
+    :initarg :description
+    :accessor mime-description)
+   (encoding
+    :initform :7bit
+    :initarg :encoding
+    :reader mime-encoding
+    :documentation
+    "It's supposed to be either:
+  :7BIT, :8BIT, :BINARY, :QUOTED-PRINTABLE, :BASE64, a
+  X-token or an ietf-token (whatever that means).")
+   (disposition
+    :type (or string null)
+    :initarg :disposition
+    :initform nil
+    :accessor mime-disposition)
+   (disposition-parameters
+    :type list
+    :initarg :disposition-parameters
+    :initform '()
+    :accessor mime-disposition-parameters))
+  (:documentation
+   "Abstract base class for all types of MIME parts."))
+
+(defclass mime-bodily-part (mime-part)
+  ((body
+    :initarg :body
+    :accessor mime-body))
+  (:documentation
+   "Abstract base class for MIME parts with a body."))
+
+(defclass mime-unknown-part (mime-bodily-part)
+  ((type
+    :initarg :type
+    :reader mime-type
+    :documentation
+    "The original type string from the MIME header."))
+  (:documentation
+   "MIME part unknown to this library.  Accepted but not handled."))
+
+(defclass mime-text (mime-bodily-part) ())
+
+;; This turns out to be handy when making methods specialised
+;; non-textual attachments.
+(defclass mime-binary (mime-bodily-part) ())
+
+(defclass mime-image (mime-binary) ())
+
+(defclass mime-audio (mime-binary) ())
+
+(defclass mime-video (mime-binary) ())
+
+(defclass mime-application (mime-binary) ())
+
+(defclass mime-multipart (mime-part)
+  ((parts :initarg :parts
+	  :accessor mime-parts)))
+
+(defclass mime-message (mime-part)
+  ((headers :initarg :headers
+	    :initform '()
+	    :type list
+	    :accessor mime-message-headers)
+   (real-message :initarg :body
+		 :accessor mime-body)))
+
+(defun mime-part-p (object)
+  (typep object 'mime-part))
+
+(defmethod initialize-instance ((part mime-multipart) &key &allow-other-keys)
+  (call-next-method)
+  ;; The initialization argument of the PARTS slot of a mime-multipart
+  ;; is expected to be a list of mime-parts.  Thus, we implicitly
+  ;; create the mime parts using the arguments found in this list.
+  (with-slots (parts) part
+    (when (slot-boundp part 'parts)
+      (setf parts
+	    (mapcar #'(lambda (subpart)
+			(if (mime-part-p subpart)
+			    subpart
+			    (apply #'make-instance subpart)))
+		    parts)))))
+
+(defmethod initialize-instance ((part mime-message) &key &allow-other-keys)
+  (call-next-method)
+  ;; Allow a list of mime parts to be specified as body of a
+  ;; mime-message.  In that case we implicitly create a mime-multipart
+  ;; and assign to the body slot.
+  (with-slots (real-message) part
+    (when (and (slot-boundp part 'real-message)
+	       (consp real-message))
+      (setf real-message
+	    (make-instance 'mime-multipart :parts real-message)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun alist= (alist1 alist2 &key (test #'eql))
+  (null
+   (set-difference alist1 alist2
+		   :test #'(lambda (x y)
+			     (and (funcall test (car x) (car y))
+				  (funcall test (cdr x) (cdr y)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defgeneric mime= (mime1 mime2)
+  (:documentation
+   "Return true if MIME1 and MIME2 have equivalent structure and identical bodies (as for EQ)."))
+
+(defmethod mime= ((part1 mime-part) (part2 mime-part))
+  (macrolet ((null-or (compare x y)
+	       `(or (and (not ,x)
+			 (not ,y))
+		    (and ,x ,y
+			 (,compare ,x ,y))))
+	     (cmp-slot (compare reader)
+	       `(null-or ,compare (,reader part1) (,reader part2))))
+    (and (eq (class-of part1) (class-of part2))
+	 (cmp-slot string-equal mime-subtype)
+	 (alist= (mime-type-parameters part1)
+		 (mime-type-parameters part2)
+		 :test #'string-equal)
+	 (cmp-slot string= mime-id)
+	 (cmp-slot string= mime-description)
+	 (cmp-slot eq mime-encoding)
+	 (cmp-slot equal mime-disposition)
+	 (alist= (mime-disposition-parameters part1)
+		 (mime-disposition-parameters part2)
+		 :test #'string-equal))))
+
+(defmethod mime= ((part1 mime-multipart) (part2 mime-multipart))
+  (and (call-next-method)
+       (every #'mime= (mime-parts part1) (mime-parts part2))))
+
+(defmethod mime= ((part1 mime-message) (part2 mime-message))
+  (and (call-next-method)
+       (alist= (mime-message-headers part1) (mime-message-headers part2)
+	       :test #'string=)
+       (mime= (mime-body part1) (mime-body part2))))
+
+(defun mime-body-stream (mime-part &key (binary t))
+  (make-instance (if binary
+		     'binary-input-adapter-stream
+		     'character-input-adapter-stream)
+		 :source (mime-body mime-part)))
+
+(defun mime-body-length (mime-part)
+  (be body (mime-body mime-part)
+    ;; here the stream type is missing on purpose, because we may not
+    ;; be able to size the length of a stream
+    (etypecase body
+      (string
+       (length body))
+      (vector
+       (length body))
+      (pathname
+       (file-size body))
+      (file-portion
+       (with-open-stream (in (open-decoded-file-portion body))
+	 (loop
+	    for byte = (read-byte in nil)
+	    while byte
+	    count byte))))))
+
+(defmacro with-input-from-mime-body-stream ((stream part &key (binary t)) &body forms)
+  `(with-open-stream (,stream (mime-body-stream ,part :binary ,binary))
+     ,@forms))
+
+(defmethod mime= ((part1 mime-bodily-part) (part2 mime-bodily-part))
+  (and (call-next-method)
+       (with-input-from-mime-body-stream (in1 part1)
+	 (with-input-from-mime-body-stream (in2 part2)
+	   (loop
+	      for b1 = (read-byte in1 nil)
+	      for b2 = (read-byte in2 nil)
+	      always (eq b1 b2)
+	      while (and b1 b2))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defgeneric get-mime-type-parameter (part name)
+  (:documentation
+   "Return the MIME type parameter associated to NAME of PART."))
+
+(defgeneric (setf get-mime-type-parameter) (value part name)
+  (:documentation
+   "Set the MIME type parameter associated to NAME of PART."))
+
+(defmethod get-mime-type-parameter ((part mime-part) name)
+  (cdr (assoc name (mime-type-parameters part) :test #'string-equal)))
+
+(defmethod (setf get-mime-type-parameter) (value part name)
+  (aif (assoc name (mime-type-parameters part) :test #'string-equal)
+       (setf (cdr it) value)
+       (push (cons name value)
+	     (mime-type-parameters part)))
+  value)
+
+(defgeneric get-mime-disposition-parameter (part name)
+  (:documentation
+   "Return the MIME disposition parameter associated to NAME of PART."))
+
+(defmethod get-mime-disposition-parameter ((part mime-part) name)
+  (cdr (assoc name (mime-disposition-parameters part) :test #'string-equal)))
+
+(defmethod (setf get-mime-disposition-parameter) (value part name)
+  (aif (assoc name (mime-disposition-parameters part) :test #'string-equal)
+       (setf (cdr it) value)
+       (push (cons name value)
+	     (mime-disposition-parameters part))))
+
+(defmethod mime-part-file-name ((part mime-part))
+  "Return the filename associated to mime PART or NIL if the mime
+part doesn't have a file name."
+  (or (get-mime-disposition-parameter part :filename)
+      (get-mime-type-parameter part :name)))
+
+(defmethod (setf mime-part-file-name) (value (part mime-part))
+  "Set the filename associated to mime PART."
+  (setf (get-mime-disposition-parameter part :filename) value
+	(get-mime-type-parameter part :name) value))
+
+(defun mime-text-charset (part)
+  (get-mime-type-parameter part :charset))
+
+(defun split-header-parts (string)
+  "Split parts of a MIME headers.  These are divided by
+semi-colons not within strings or comments."
+  (labels ((skip-comment (pos)
+	     (loop
+		while (< pos (length string))
+		do (case (elt string pos)
+		     (#\( (setf pos (skip-comment (1+ pos))))
+		     (#\\ (incf pos 2))
+		     (#\) (return (1+ pos)))
+		     (otherwise (incf pos)))
+		finally (return pos)))
+	   (skip-string (pos)
+	     (loop
+		while (< pos (length string))
+		do (case (elt string pos)
+		     (#\\ (incf pos 2))
+		     (#\" (return (1+ pos)))
+		     (otherwise (incf pos)))
+		finally (return pos))))
+    (loop
+       with start = 0 and i = 0 and parts = '()
+       while (< i (length string))
+       do (case (elt string i)
+	    (#\; (push (subseq string start i) parts)
+		 (setf start (incf i)))
+	    (#\" (setf i (skip-string i)))
+	    (#\( (setf i (skip-comment (1+ i))))
+	    (otherwise (incf i)))
+       finally (return (mapcar #'string-trim-whitespace (nreverse (cons (subseq string start) parts)))))))
+
+(defun parse-parameter (string)
+  "Given a string like \"foo=bar\" return a pair (\"foo\" .
+\"bar\").  Return NIL if string is not parsable."
+  (be equal-position (position #\= string)
+    (when equal-position
+      (be key (subseq string  0 equal-position)
+	(if (= equal-position (1- (length string)))
+	    (cons key "")
+	    (be value (string-trim-whitespace (subseq string (1+ equal-position)))
+	      (cons key
+		    (if (and (> (length value) 1)
+			     (char= #\" (elt value 0)))
+			;; the syntax of a RFC822 string is more or
+			;; less the same as the Lisp one: use the Lisp
+			;; reader
+			(or (ignore-errors (read-from-string value))
+			    (subseq value 1))
+			(be end (or (position-if #'whitespace-p value)
+				    (length value))
+			  (subseq value 0 end))))))))))
+
+(defun parse-content-type (string)
+  "Parse string as a Content-Type MIME header and return a list
+of three elements.  The first is the type, the second is the
+subtype and the third is an alist of parameters and their values.
+Example: (\"text\" \"plain\" ((\"charset\" . \"us-ascii\")...))."
+  (let* ((parts (split-header-parts string))
+	 (content-type-string (car parts))
+	 (slash (position #\/ content-type-string)))
+    ;; You'd be amazed to know how many MUA can't produce an RFC
+    ;; compliant message.
+    (when slash
+      (let ((type (subseq content-type-string 0 slash))
+	    (subtype (subseq content-type-string (1+ slash))))
+	(list type subtype (remove nil (mapcar #'parse-parameter (cdr parts))))))))
+
+(defun parse-content-disposition (string)
+  "Parse string as a Content-Disposition MIME header and return a
+list.  The first element is the layout, the other elements are
+the optional parameters alist.
+Example: (\"inline\" (\"filename\" . \"doggy.jpg\"))."
+  (be parts (split-header-parts string)
+    (cons (car parts) (mapcan #'(lambda (parameter-string)
+				  (awhen (parse-parameter parameter-string)
+				    (list it)))
+			      (cdr parts)))))
+
+(defun parse-RFC822-header (string)
+  "Parse STRING which should be a valid RFC822 message header and
+return two values: a string of the header name and a string of
+the header value."
+  (be colon (position #\: string)
+    (when colon
+      (values (string-trim-whitespace (subseq string 0 colon))
+	      (string-trim-whitespace (subseq string (1+ colon)))))))
+
+
+(defvar *default-type* '("text" "plain" (("charset" . "us-ascii")))
+  "Internal special variable that contains the default MIME type at
+any given time of the parsing phase.  There are MIME container parts
+that may change this.")
+
+(defvar *mime-types*
+  '((:text mime-text)
+    (:image mime-image)
+    (:audio mime-audio)
+    (:video mime-video)
+    (:application mime-application)
+    (:multipart mime-multipart)
+    (:message mime-message)))
+
+(defgeneric mime-part-size (part)
+  (:documentation
+   "Return the size in bytes of the body of a MIME part."))
+
+(defgeneric print-mime-part (part stream)
+  (:documentation
+   "Output to STREAM one of the possible human-readable representation
+of mime PART.  Binary parts are omitted.  This function can be used to
+quote messages, for instance."))
+
+(defun do-multipart-parts (body-stream part-boundary contents-function end-part-function)
+  "Read through BODY-STREAM.  Call CONTENTS-FUNCTION at
+each (non-boundary) line or END-PART-FUNCTION at each PART-BOUNDARY."
+  (let* ((boundary (s+ "--" part-boundary))
+	 (boundary-length (length boundary)))
+    (labels ((output-line (line)
+	       (funcall contents-function line))
+	     (end-part ()
+	       (funcall end-part-function))
+	     (last-part ()
+	       (end-part)
+	       (return-from do-multipart-parts))
+	     (process-line (line)
+	       (cond ((not (string-starts-with boundary line))
+		      ;; normal line
+		      (output-line line))
+		     ((and (= (length (string-trim-whitespace line))
+			      (+ 2 boundary-length))
+			   (string= "--" line :start2 boundary-length))
+		      ;; end of the last part
+		      (last-part))
+		     ;; according to RFC2046 "the boundary may be followed
+		     ;; by zero or more characters of linear whitespace"
+		     ((= (length (string-trim-whitespace line)) boundary-length)
+		      ;; beginning of the next part
+		      (end-part))
+		     (t
+		      ;; the line boundary is followed by some
+		      ;; garbage; we treat it as a normal line
+		      (output-line line)))))
+      (loop
+	 for line = (read-line body-stream nil)
+	 ;; we should never reach the end of a proper multipart MIME
+	 ;; stream, but we don't want to be fooled by corrupted ones,
+	 ;; so we check for EOF
+	 unless line
+	 do (last-part)
+	 do (process-line line)))))
+
+;; This awkward handling of newlines is due to RFC2046: "The CRLF
+;; preceding the boundary delimiter line is conceptually attached to
+;; the boundary so that it is possible to have a part that does not
+;; end with a CRLF (line break).  Body parts that must be considered
+;; to end with line breaks, therefore, must have two CRLFs preceding
+;; the boundary delimiter line, the first of which is part of the
+;; preceding body part, and the second of which is part of the
+;; encapsulation boundary".
+(defun split-multipart-parts (body-stream part-boundary)
+  "Read from BODY-STREAM and split MIME parts separated by
+PART-BOUNDARY.  Return a list of strings."
+  (let ((part (make-string-output-stream))
+	(parts '())
+	(beginning-of-part-p t))
+    (flet ((output-line (line)
+	     (if beginning-of-part-p
+		 (setf beginning-of-part-p nil)
+		 (terpri part))
+	     (write-string line part))
+	   (end-part ()
+	     (setf beginning-of-part-p t)
+	     (push (get-output-stream-string part) parts)))
+      (do-multipart-parts body-stream part-boundary #'output-line #'end-part)
+      (close part)
+      ;; the first part is empty or contains all the junk
+      ;; to the first boundary
+      (cdr (nreverse parts)))))
+
+(defun index-multipart-parts (body-stream part-boundary)
+  "Read from BODY-STREAM and return the file offset of the MIME parts
+separated by PART-BOUNDARY."
+  (let ((parts '())
+	(start 0)
+	(len 0)
+	(beginning-of-part-p t))
+    (flet ((sum-chars (line)
+	     (incf len (length line))
+	     ;; account for the #\newline
+	     (if beginning-of-part-p
+		 (setf beginning-of-part-p nil)
+		 (incf len)))
+	   (end-part ()
+	     (setf beginning-of-part-p t)
+	     (push (cons start (+ start len)) parts)
+	     (setf start (file-position body-stream)
+		   len 0)))
+      (do-multipart-parts body-stream part-boundary #'sum-chars #'end-part)
+      ;; the first part is all the stuff up to the first boundary;
+      ;; just junk
+      (cdr (nreverse parts)))))
+
+(defgeneric encode-mime-part (part stream))
+(defgeneric encode-mime-body (part stream))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun write-mime-header (part stream)
+  (when (mime-version part)
+    (format stream "~&MIME-Version: ~A~%" (mime-version part)))
+  (format stream "~&Content-Type: ~A~:{; ~A=~S~}~%" (mime-type-string part)
+	  (mapcar #'(lambda (pair)
+		      (list (car pair) (cdr pair)))
+		  (mime-type-parameters part)))
+  (awhen (mime-encoding part)
+    (format stream "Content-Transfer-Encoding: ~A~%" it))
+  (awhen (mime-description part)
+    (format stream "Content-Description: ~A~%" it))
+  (when (mime-disposition part)
+    (format stream "Content-Disposition: ~A~:{; ~A=~S~}~%"
+	    (mime-disposition part)
+	    (mapcar #'(lambda (pair)
+			(list (car pair) (cdr pair)))
+		    (mime-disposition-parameters part))))
+  (awhen (mime-id part)
+    (format stream "Content-ID: ~A~%" it))
+  (terpri stream))
+
+(defmethod encode-mime-part ((part mime-part) stream)
+  (write-mime-header part stream)
+  (encode-mime-body part stream))
+
+(defmethod encode-mime-part ((part mime-message) stream)
+  ;; tricky: we have to mix the MIME headers with the message headers
+  (dolist (h (mime-message-headers part))
+    (unless (stringp (car h))
+      (setf (car h)
+	    (string-capitalize (car h))))
+    (unless (or (string-starts-with "content-" (car h) #'string-equal)
+		(string-equal "mime-version" (car h)))
+      (format stream "~A: ~A~%"
+	      (car h) (cdr h))))
+  (encode-mime-part (mime-body part) stream))
+
+(defmethod encode-mime-part ((part mime-multipart) stream)
+  ;; choose a boundary if not already set
+  (let* ((original-boundary (get-mime-type-parameter part :boundary))
+	 (boundary (choose-boundary (mime-parts part) original-boundary)))
+    (unless (and original-boundary
+		 (string= boundary original-boundary))
+      (setf (get-mime-type-parameter part :boundary) boundary))
+    (call-next-method)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defmethod encode-mime-body ((part mime-part) stream)
+  (with-input-from-mime-body-stream (in part)
+    (encode-stream in stream (mime-encoding part))))
+
+(defmethod encode-mime-body ((part mime-message) stream)
+  (encode-mime-body (mime-body part) stream))
+
+(defmethod encode-mime-body ((part mime-multipart) stream)
+  (be boundary (or (get-mime-type-parameter part :boundary)
+		   (setf (get-mime-type-parameter part :boundary)
+			 (choose-boundary (mime-parts part))))
+    (dolist (p (mime-parts part))
+      (format stream "~%--~A~%" boundary)
+      (encode-mime-part p stream))
+    (format stream "~%--~A--~%" boundary)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun time-RFC822-string (&optional (epoch (get-universal-time)))
+  "Return a string describing the current time according to
+the RFC822."
+  (multiple-value-bind (ss mm hh day month year week-day dst tz) (decode-universal-time epoch)
+    (declare (ignore dst))
+    (format nil "~A, ~A ~A ~2,'0D ~2,'0D:~2,'0D:~2,'0D ~:[-~;+~]~2,'0D~2,'0D"
+	    (subseq (week-day->string week-day) 0 3)
+	    day (subseq (month->string month) 0 3) (mod year 100) hh mm ss
+	    (plusp tz) (abs (truncate tz)) (mod (* 60 tz) 60))))
+
+(defun parse-RFC822-date (date-string)
+  "Parse a RFC822 compliant date string and return an universal
+time."
+  ;; if we can't parse it, just return NIL
+  (ignore-errors
+    ;; skip the optional DoW
+    (awhen (position #\, date-string)
+      (setf date-string (subseq date-string (1+ it))))
+    (destructuring-bind (day month year time &optional tz &rest rubbish)
+	(split-at '(#\space #\tab) date-string)
+      (declare (ignore rubbish))
+      (destructuring-bind (hh mm &optional ss) (split-string-at-char time #\:)
+	(encode-universal-time
+	 (if ss
+	     (read-from-string ss)
+	     0)
+	 (read-from-string mm)
+	 (read-from-string hh)
+	 (read-from-string day)
+	 (1+ (position month
+		       '("Jan" "Feb" "Mar" "Apr" "May" "Jun"
+			 "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")
+		       :test #'string-equal))
+	 (read-from-string year)
+	 (when (and tz (or (char= #\+ (elt tz 0))
+			   (char= #\- (elt tz 0))))
+	   (/ (read-from-string tz) 100)))))))
+
+(defun read-RFC822-headers (stream &optional required-headers)
+  "Read RFC822 compliant headers from STREAM and return them in a
+alist of keyword and string pairs.  REQUIRED-HEADERS is a list of
+header names we are interested in; if NIL return all headers
+found in STREAM."
+  ;; the skip-header variable is to avoid the mistake of appending a
+  ;; continuation line of a header we don't want to a header we want
+  (loop
+     with headers = '() and skip-header = nil
+     for line = (be line (read-line stream nil)
+		  ;; skip the Unix "From " header if present
+		  (if (string-starts-with "From " line)
+		      (read-line stream nil)
+		      line))
+     then (read-line stream nil)
+     while (and line
+		(not (zerop (length line))))
+     do (if (whitespace-p (elt line 0))
+	    (unless (or skip-header
+			(null headers))
+	      (setf (cdar headers) (s+ (cdar headers) '(#\newline) line)))
+	    (multiple-value-bind (name value) (parse-RFC822-header line)
+	      ;; the line contained rubbish instead of an header: we
+	      ;; play nice and return as we were at the end of the
+	      ;; headers
+	      (unless name
+		(return (nreverse headers)))
+	      (if (or (null required-headers)
+		      (member name required-headers :test #'string-equal))
+		  (progn
+		    (push (cons name value) headers)
+		    (setf skip-header nil))
+		  (setf skip-header t))))
+     finally (return (nreverse headers))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defgeneric mime-message (thing)
+  (:documentation
+   "Convert THING to a MIME-MESSAGE object."))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defvar *lazy-mime-decode* t
+  "If true don't  decode mime bodies in memory.")
+
+(defgeneric decode-mime-body (part input-stream))
+
+(defmethod decode-mime-body ((part mime-part) (stream delimited-input-stream))
+ (be base (base-stream stream)
+   (if *lazy-mime-decode*
+       (setf (mime-body part)
+	     (make-file-portion :data (etypecase base
+					(my-string-input-stream
+					 (stream-string base))
+					(file-stream
+					 (pathname base)))
+				:encoding (mime-encoding part)
+				:start (file-position stream)
+				:end (stream-end stream)))
+       (call-next-method))))
+
+(defmethod decode-mime-body ((part mime-part) (stream file-stream))
+  (if *lazy-mime-decode*
+      (setf (mime-body part)
+	    (make-file-portion :data (pathname stream)
+			       :encoding (mime-encoding part)
+			       :start (file-position stream)))
+      (call-next-method)))
+
+(defmethod decode-mime-body ((part mime-part) (stream my-string-input-stream))
+  (if *lazy-mime-decode*
+      (setf (mime-body part)
+	    (make-file-portion :data (stream-string stream)
+			       :encoding (mime-encoding part)
+			       :start (file-position stream)))
+      (call-next-method)))
+
+(defmethod decode-mime-body ((part mime-part) stream)
+  (setf (mime-body part)
+	(decode-stream-to-sequence stream (mime-encoding part))))
+
+(defmethod decode-mime-body ((part mime-multipart) stream)
+  "Decode STREAM according to PART characteristics and return a
+list of MIME parts."
+  (save-file-excursion (stream)
+    (be offsets (index-multipart-parts stream (get-mime-type-parameter part :boundary))
+      (setf (mime-parts part)
+	    (mapcar #'(lambda (p)
+			(destructuring-bind (start . end) p
+			  (be *default-type* (if (eq :digest (mime-subtype part))
+						 '("message" "rfc822" ())
+						 '("text" "plain" (("charset" . "us-ascii"))))
+			      in (make-instance 'delimited-input-stream
+						:stream stream
+						:dont-close t
+						:start start
+						:end end)
+			      (read-mime-part in))))
+		    offsets)))))
+
+(defmethod decode-mime-body ((part mime-message) stream)
+  "Read from STREAM the body of PART.  Return the decoded MIME
+body."
+  (setf (mime-body part)
+	(read-mime-message stream)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defconst +known-encodings+ '(:7BIT :8BIT :BINARY :QUOTED-PRINTABLE :BASE64)
+  "List of known content encodings.")
+
+(defun keywordify-encoding (string)
+  "Return a keyword for a content transfer encoding string.
+Return STRING itself if STRING is an unkown encoding."
+  (aif (member string +known-encodings+ :test #'string-equal)
+       (car it)
+       string))
+
+(defun header (name headers)
+  (be elt (assoc name headers :test #'string-equal)
+    (values (cdr elt) (car elt))))
+
+(defun (setf header) (value name headers)
+  (be entry (assoc name headers :test #'string-equal)
+    (unless entry
+      (error "missing header ~A can't be set" name))
+    (setf (cdr entry) value)))
+
+(defun make-mime-part (headers stream)
+  "Create a MIME-PART object based on HEADERS and a body which
+has to be read from STREAM.  If the mime part type can't be
+guessed from the headers, use the *DEFAULT-TYPE*."
+  (flet ((hdr (what)
+	   (header what headers)))
+    (destructuring-bind (type subtype parms)
+	(or 
+	 (aand (hdr :content-type)
+	       (parse-content-type it))
+	 *default-type*)
+      (let* ((class (or (cadr (assoc type *mime-types* :test #'string-equal))
+			'mime-unknown-part))
+	     (disp (aif (hdr :content-disposition)
+			(parse-content-disposition it)
+			(values nil nil)))
+	     (part (make-instance class
+				  :type (hdr :content-type)
+				  :subtype subtype
+				  :type-parameters parms
+				  :disposition (car disp)
+				  :disposition-parameters (cdr disp)
+				  :mime-version (hdr :mime-version)
+				  :encoding (keywordify-encoding
+					     (hdr :content-transfer-encoding))
+				  :description (hdr :content-description)
+				  :id (hdr :content-id)
+				  :allow-other-keys t)))
+	(decode-mime-body part stream)
+	part))))
+
+(defun read-mime-part (stream)
+  "Read mime part from STREAM.  Return a MIME-PART object."
+  (be headers (read-rfc822-headers stream
+				   '(:mime-version :content-transfer-encoding :content-type
+				     :content-disposition :content-description :content-id))
+    (make-mime-part headers stream)))
+
+(defun read-mime-message (stream)
+  "Main function to read a MIME message from a stream.  It
+returns a MIME-MESSAGE object."
+  (be headers (read-rfc822-headers stream)
+      *default-type* '("text" "plain" (("charset" . "us-ascii")))
+    (flet ((hdr (what)
+	     (header what headers)))
+      (destructuring-bind (type subtype parms)
+	  (or (aand (hdr :content-type)
+		    (parse-content-type it))
+	      *default-type*)
+	(declare (ignore type subtype))
+	(make-instance 'mime-message
+		       :headers headers
+		       ;; this is just for easy access
+		       :type-parameters parms
+		       :body (make-mime-part headers stream))))))
+
+(defmethod mime-message ((msg mime-message))
+  msg)
+
+(defmethod mime-message ((msg string))
+  (with-open-stream (in (make-instance 'my-string-input-stream :string msg))
+    (read-mime-message in)))
+
+(defmethod mime-message ((msg stream))
+  (read-mime-message msg))
+
+(defmethod mime-message ((msg pathname))
+  (let (#+sbcl(sb-impl::*default-external-format* :latin-1)
+	#+sbcl(sb-alien::*default-c-string-external-format* :latin-1))
+    (with-open-file (in msg)
+      (read-mime-message in))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defgeneric mime-part (object)
+  (:documentation
+   "Promote object, if necessary, to MIME-PART."))
+
+(defmethod mime-part ((object string))
+  (make-instance 'mime-text :subtype "plain" :body object))
+
+(defmethod mime-part ((object pathname))
+  (make-instance 'mime-application
+		 :subtype "octect-stream"
+		 :content-transfer-encoding :base64
+		 :body (read-file object :element-type '(unsigned-byte 8))))
+
+(defmethod mime-part ((object mime-part))
+  object)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defmethod make-encoded-body-stream ((part mime-bodily-part))
+  (be body (mime-body part)
+    (make-instance (case (mime-encoding part)
+		     (:base64
+		      'base64-encoder-input-stream)
+		     (:quoted-printable
+		      'quoted-printable-encoder-input-stream)
+		     (t
+		      '8bit-encoder-input-stream))
+		   :stream (make-instance 'binary-input-adapter-stream :source body))))
+
+(defun choose-boundary (parts &optional default)
+  (labels ((match-in-parts (boundary parts)
+	     (loop
+		for p in parts
+		thereis (typecase p
+			  (mime-multipart
+			   (match-in-parts boundary (mime-parts p)))
+			  (mime-bodily-part
+			   (match-in-body p boundary)))))
+	   (match-in-body (part boundary)
+	     (with-open-stream (in (make-encoded-body-stream part))
+	       (loop
+		  for line = (read-line in nil)
+		  while line
+		  when (string= line boundary)
+		  return t
+		  finally (return nil)))))
+    (do ((boundary (if default
+		       (format nil "--~A" default)
+		       #1=(format nil "--~{~36R~}"
+				  (loop
+				     for i from 0 below 20
+				     collect (random 36))))
+		   #1#))
+	((not (match-in-parts boundary parts)) (subseq boundary 2)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; fall back method
+(defmethod mime-part-size ((part mime-part))
+  (be body (mime-body part)
+    (typecase body
+      (pathname
+       (file-size body))
+      (string
+       (length body))
+      (vector
+       (length body))
+      (t nil))))
+
+(defmethod mime-part-size ((part mime-multipart))
+  (loop
+     for p in (mime-parts part)
+     for size = (mime-part-size p)
+     unless size
+     return nil
+     sum size))
+
+(defmethod mime-part-size ((part mime-message))
+  (mime-part-size (mime-body part)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defmethod print-mime-part ((part mime-multipart) (out stream))
+  (case (mime-subtype part)
+    (:alternative
+     ;; try to choose something simple to print or the first thing
+     (be parts (mime-parts part)
+       (print-mime-part (or (find-if #'(lambda (part)
+					 (and (eq (class-of part) (find-class 'mime-text))
+					      (eq (mime-subtype part) :plain)))
+				     parts)
+			    (car parts)) out)))
+    (otherwise
+     (dolist (subpart (mime-parts part))
+       (print-mime-part subpart out)))))
+
+;; This is WRONG.  Here we don't use any special character encoding
+;; because we don't know which one we should use.  Messages written in
+;; anything but ASCII will likely be unreadable -wcp11/10/07.
+(defmethod print-mime-part ((part mime-text) (out stream))
+  (be body (mime-body part)
+    (etypecase body
+      (string
+       (write-string body out))
+      (vector
+       (loop
+	  for byte across body
+	  do (write-char (code-char byte) out)))
+      (pathname
+       (with-open-file (in body)
+	 (loop
+	    for c = (read-char in nil)
+	    while c
+	    do (write-char c out)))))))
+
+(defmethod print-mime-part ((part mime-message) (out stream))
+  (flet ((hdr (name)
+	   (multiple-value-bind (value tag)
+	       (header name (mime-message-headers part))
+	     (cons tag value))))
+    (dolist (h (mapcar #'hdr '("from" "subject" "to" "date" "x-march-archive-id")))
+      (when h
+	(format out "~&~A: ~A" (car h) (cdr h))))
+    (format out "~2%")
+    (print-mime-part (mime-body part) out)))
+
+(defmethod print-mime-part ((part mime-part) (out stream))
+  (format out "~&[ ~A subtype=~A ~@[description=~S ~]~@[size=~A~] ]~%"
+	  (type-of part) (mime-subtype part) (mime-description part) (mime-part-size part)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defgeneric find-mime-part-by-path (mime path)
+  (:documentation
+   "Return a subpart of MIME identified by PATH, which is a list of
+integers.  For example '(2 3 1) is the first part of the third of the
+second in MIME."))
+
+(defmethod find-mime-part-by-path ((part mime-part) path)
+  (if (null path)
+      part
+      (error "~S doesn't have subparts" part)))
+
+(defmethod find-mime-part-by-path ((part mime-message) path)
+  (if (null path)
+      part
+      (if (= 1 (car path))
+	  (find-mime-part-by-path (mime-body part) (cdr path))
+	  (error "~S may have just one subpart, but part ~D was requested (parts are enumerated base 1)."
+		 part (car path)))))
+
+(defmethod find-mime-part-by-path ((part mime-multipart) path)
+  (if (null path)
+      part
+      (be parts (mime-parts part)
+	  part-number (car path)
+	(if (<= 1 part-number (length parts))
+	    (find-mime-part-by-path (nth (1- (car path)) (mime-parts part)) (cdr path))
+	    (error "~S has just ~D subparts, but part ~D was requested (parts are enumerated base 1)."
+		   part (length parts) part-number)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defgeneric find-mime-part-by-id (part id)
+  (:documentation
+   "Return a subpart of PAR, whose Content-ID is the same as ID, which
+is a string."))
+
+(defmethod find-mime-part-by-id ((part mime-part) id)
+  (when (string= id (mime-id part))
+    part))
+
+(defmethod find-mime-part-by-id ((part mime-message) id)
+  (find-mime-part-by-id (mime-body part) id))
+
+(defmethod find-mime-part-by-id ((part mime-multipart) id)
+  (or (call-next-method)
+      (some #'(lambda (p)
+		(find-mime-part-by-id p id))
+	    (mime-parts part))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defmethod find-mime-text-part (msg)
+  (:documentation
+   "Return message if it is a text message or first text part.
+   If no suitable text part is found, return NIL."))
+
+(defmethod find-mime-text-part ((part mime-text))
+  part) ; found our target
+
+(defmethod find-mime-text-part ((msg mime-message))
+  ;; mime-body is either a mime-part or mime-multipart
+  (find-mime-text-part (mime-body msg)))
+
+(defmethod find-mime-text-part ((parts mime-multipart))
+  ;; multipart messages may have a body, otherwise we
+  ;; search for the first text part
+  (or (call-next-method)
+      (find-if #'find-mime-text-part (mime-parts parts))))
+
+(defmethod find-mime-text-part ((part mime-part))
+  nil) ; default case
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defgeneric mime-type-string (mime-part)
+  (:documentation
+   "Return the string describing the MIME part."))
+
+(defmethod mime-type-string ((part mime-unknown-part))
+  (mime-type part))
+
+(defmethod mime-type-string ((part mime-text))
+  (format nil "text/~A" (mime-subtype part)))
+
+(defmethod mime-type-string ((part mime-image))
+  (format nil "image/~A" (mime-subtype part)))
+
+(defmethod mime-type-string ((part mime-audio))
+  (format nil "audio/~A" (mime-subtype part)))
+
+(defmethod mime-type-string ((part mime-video))
+  (format nil "video/~A" (mime-subtype part)))
+
+(defmethod mime-type-string ((part mime-application))
+  (format nil "application/~A" (mime-subtype part)))
+
+(defmethod mime-type-string ((part mime-multipart))
+  (format nil "multipart/~A" (mime-subtype part)))
+
+(defmethod mime-type-string ((part mime-message))
+  (format nil "message/~A" (mime-subtype part)))
+
+(defmethod mime-type-string ((part mime-unknown-part))
+  (mime-type part))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defgeneric map-parts (function mime-part)
+  (:documentation
+   "Recursively map FUNCTION to MIME-PART or its components."))
+
+;; Here we wrongly assume that we'll never want to replace messages
+;; and multiparts altogether.  If you need to do so you have to write
+;; your own mapping functions.
+
+(defmethod map-parts ((function function) (part mime-part))
+  (funcall function part))
+
+(defmethod map-parts ((function function) (part mime-message))
+  (setf (mime-body part) (map-parts function (mime-body part)))
+  part)
+
+(defmethod map-parts ((function function) (part mime-multipart))
+  (setf (mime-parts part) (mapcar #'(lambda (p)
+				      (map-parts function p))
+				  (mime-parts part)))
+  part)
+
+;; apply-on-parts is like map-parts but doesn't modify the parts (at least
+;; not implicitly)
+
+(defgeneric apply-on-parts (function part))
+
+(defmethod apply-on-parts ((function function) (part mime-part))
+  (funcall function part))
+
+(defmethod apply-on-parts ((function function) (part mime-multipart))
+  (dolist (p (mime-parts part))
+    (apply-on-parts function p)))
+
+(defmethod apply-on-parts ((function function) (part mime-message))
+  (apply-on-parts function (mime-body part)))
+
+(defmacro do-parts ((var mime-part) &body body)
+  `(apply-on-parts #'(lambda (,var) ,@body) ,mime-part))
diff --git a/third_party/lisp/mime4cl/mime4cl-tests.asd b/third_party/lisp/mime4cl/mime4cl-tests.asd
new file mode 100644
index 000000000000..e4d983c05760
--- /dev/null
+++ b/third_party/lisp/mime4cl/mime4cl-tests.asd
@@ -0,0 +1,54 @@
+;;;  mime4cl-tests.asd --- system description for the regression tests
+
+;;;  Copyright (C) 2006, 2007, 2010 by Walter C. Pelissero
+
+;;;  Author: Walter C. Pelissero <walter@pelissero.de>
+;;;  Project: mime4cl
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public License
+;;; as published by the Free Software Foundation; either version 2.1
+;;; of the License, or (at your option) any later version.
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free
+;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+;;; 02111-1307 USA
+
+#-(or sbcl cmu)
+(warn "This code hasn't been tested on your Lisp system.")
+
+(defpackage :mime4cl-tests-system
+  (:use :common-lisp :asdf #+asdfa :asdfa)
+  (:export #:*base-directory*
+	   #:*compilation-epoch*))
+
+(in-package :mime4cl-tests-system)
+
+(defsystem mime4cl-tests
+    :name "MIME4CL-tests"
+    :author "Walter C. Pelissero <walter@pelissero.de>"
+    :maintainer "Walter C. Pelissero <walter@pelissero.de>"
+    :description "Test suite for the MIME4CL library"
+    :long-description
+    "These regression tests require rt.lisp from MIT.  It is included."
+    :licence "LGPL"
+    :depends-on (:mime4cl)
+    :components
+    ((:module test
+	      :components
+	      ((:file "rt")
+	       (:file "package" :depends-on ("rt"))
+	       (:file "endec" :depends-on ("rt" "package"))
+	       (:file "address" :depends-on ("rt" "package"))
+	       (:file "mime" :depends-on ("rt" "package"))))))
+
+;; when loading this form the regression-test, the package is yet to
+;; be loaded so we cannot use rt:do-tests directly or we would get a
+;; reader error (unknown package)
+(defmethod perform ((o test-op) (c (eql (find-system :mime4cl-tests))))
+  (or (funcall (intern "DO-TESTS" "REGRESSION-TEST"))
+      (error "test-op failed")))
diff --git a/third_party/lisp/mime4cl/mime4cl.asd b/third_party/lisp/mime4cl/mime4cl.asd
new file mode 100644
index 000000000000..2761a00d5283
--- /dev/null
+++ b/third_party/lisp/mime4cl/mime4cl.asd
@@ -0,0 +1,53 @@
+;;;  mime4cl.asd --- system definition
+
+;;;  Copyright (C) 2005-2007, 2010 by Walter C. Pelissero
+
+;;;  Author: Walter C. Pelissero <walter@pelissero.de>
+;;;  Project: mime4cl
+
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License as
+;;; published by the Free Software Foundation; either version 2, or (at
+;;; your option) any later version.
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; General Public License for more details.
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; see the file COPYING.  If not, write to
+;;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;;; Boston, MA 02111-1307, USA.
+
+(in-package :cl-user)
+
+#+(and cmu (not gray-streams))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (ext:without-package-locks
+    (load "library:subsystems/gray-streams-library")))
+
+(defpackage :mime4cl-system
+  (:use :common-lisp :asdf))
+
+(in-package :mime4cl-system)
+
+(defsystem mime4cl
+    :name "MIME4CL"
+    :author "Walter C. Pelissero <walter@pelissero.de>"
+    :maintainer "Walter C. Pelissero <walter@pelissero.de>"
+    ;; :version "0.0"
+    :description "MIME primitives for Common Lisp"
+    :long-description
+    "A collection of Common Lisp primitives to forge and handle
+MIME mail contents."
+    :licence "LGPL"
+    :depends-on (:npg :sclf)
+    :components
+    ((:file "package")
+     (:file "mime" :depends-on ("package" "endec" "streams"))
+     (:file "endec" :depends-on ("package"))
+     (:file "streams" :depends-on ("package" "endec"))
+     (:file "address" :depends-on ("package"))))
+
+(defmethod perform ((o test-op) (c (eql (find-system 'mime4cl))))
+  (oos 'load-op 'mime4cl-tests)
+  (oos 'test-op 'mime4cl-tests :force t))
diff --git a/third_party/lisp/mime4cl/package.lisp b/third_party/lisp/mime4cl/package.lisp
new file mode 100644
index 000000000000..a6e7e7d8ef10
--- /dev/null
+++ b/third_party/lisp/mime4cl/package.lisp
@@ -0,0 +1,108 @@
+;;;  package.lisp --- package declaration
+
+;;;  Copyright (C) 2005-2007, 2010 by Walter C. Pelissero
+
+;;;  Author: Walter C. Pelissero <walter@pelissero.de>
+;;;  Project: mime4cl
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public License
+;;; as published by the Free Software Foundation; either version 2.1
+;;; of the License, or (at your option) any later version.
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free
+;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+;;; 02111-1307 USA
+
+(in-package :cl-user)
+
+(defpackage :mime4cl
+  (:nicknames :mime)
+  (:use :common-lisp :npg :sclf
+	;; for Gray streams
+	#+cmu :extensions #+sbcl :sb-gray)
+  ;; this is stuff that comes from SCLF and clashes with CMUCL's EXT
+  ;; package
+  (:shadowing-import-from :sclf
+			  #:process-wait
+			  #:process-alive-p
+			  #:run-program)
+  (:export #:*lazy-mime-decode*
+	   #:print-mime-part
+	   #:read-mime-message
+	   #:mime-part
+	   #:mime-text
+	   #:mime-binary
+	   #:mime-id
+	   #:mime-image
+	   #:mime-message
+	   #:mime-multipart
+	   #:mime-audio
+	   #:mime-unknown-part
+	   #:get-mime-disposition-parameter
+	   #:get-mime-type-parameter
+	   #:mime-disposition
+	   #:mime-disposition-parameters
+	   #:mime-encoding
+	   #:mime-application
+	   #:mime-video
+	   #:mime-description
+	   #:mime-part-size
+	   #:mime-subtype
+	   #:mime-body
+	   #:mime-body-stream
+	   #:mime-body-length
+	   #:mime-parts
+	   #:mime-part-p
+	   #:mime-type
+	   #:mime-type-string
+	   #:mime-type-parameters
+	   #:mime-message-headers
+	   #:mime=
+	   #:find-mime-part-by-path
+	   #:find-mime-part-by-id
+	   #:find-mime-text-part
+	   #:encode-mime-part
+	   #:encode-mime-body
+	   #:decode-quoted-printable-stream
+	   #:decode-quoted-printable-string
+	   #:encode-quoted-printable-stream
+	   #:encode-quoted-printable-sequence
+	   #:decode-base64-stream
+	   #:decode-base64-string
+	   #:encode-base64-stream
+	   #:encode-base64-sequence
+	   #:parse-RFC2047-text
+	   #:parse-RFC822-header
+	   #:read-RFC822-headers
+	   #:time-RFC822-string
+	   #:parse-RFC822-date
+	   #:map-parts
+	   #:do-parts
+	   #:apply-on-parts
+	   #:mime-part-file-name
+	   #:mime-text-charset
+	   #:with-input-from-mime-body-stream
+	   ;; endec.lisp
+	   #:base64-encoder
+	   #:base64-decoder
+	   #:null-encoder
+	   #:null-decoder
+	   #:byte-encoder
+	   #:byte-decoder
+	   #:quoted-printable-encoder
+	   #:quoted-printable-decoder
+	   #:encoder-write-byte
+	   #:encoder-finish-output
+	   #:decoder-read-byte
+	   #:decoder-read-sequence
+	   #:*base64-line-length*
+	   #:*quoted-printable-line-length*
+	   ;; address.lisp
+	   #:parse-addresses #:mailboxes-only
+	   #:mailbox #:mbx-description #:mbx-user #:mbx-host #:mbx-domain #:mbx-domain-name #:mbx-address
+	   #:mailbox-group #:mbxg-name #:mbxg-mailboxes))
diff --git a/third_party/lisp/mime4cl/streams.lisp b/third_party/lisp/mime4cl/streams.lisp
new file mode 100644
index 000000000000..64c7adeec571
--- /dev/null
+++ b/third_party/lisp/mime4cl/streams.lisp
@@ -0,0 +1,368 @@
+ ;;; eds.lisp --- En/De-coding Streams
+
+ ;;; Copyright (C) 2012 by Walter C. Pelissero
+ ;;; Copyright (C) 2021 by the TVL Authors
+
+ ;;; Author: Walter C. Pelissero <walter@pelissero.de>
+ ;;; Project: mime4cl
+
+#+cmu (ext:file-comment "$Module: eds.lisp")
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public License
+;;; as published by the Free Software Foundation; either version 2.1
+;;; of the License, or (at your option) any later version.
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free
+;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+;;; 02111-1307 USA
+
+(in-package :mime4cl)
+
+#+cmu
+(eval-when (:load-toplevel :compile-toplevel :execute)
+  ;; CMUCL doesn't provide the STREAM-FILE-POSITION method in its
+  ;; implementation of Gray streams.  We patch it in ourselves.
+  (defgeneric stream-file-position (stream &optional position))
+  (defun my-file-position (stream &optional position)
+    (stream-file-position stream position))
+  (defvar *original-file-position-function*
+    (prog1
+	(symbol-function 'file-position)
+      (setf (symbol-function 'file-position) (symbol-function 'my-file-position))))
+  (defmethod stream-file-position (stream &optional position)
+    (if position
+	(funcall *original-file-position-function* stream position)
+	(funcall *original-file-position-function* stream)))
+
+  ;; oddly CMUCL doesn't seem to provide a default for STREAM-READ-SEQUENCE
+  (defmacro make-read-sequence (stream-type element-reader)
+    `(defmethod stream-read-sequence ((stream ,stream-type) seq &optional start end)
+       (unless start
+	 (setf start 0))
+       (unless end
+	 (setf end (length seq)))
+       (loop
+	  for i from start below end
+	  for b = (,element-reader stream)
+	  until (eq b :eof)
+	  do (setf (elt seq i) b)
+	  finally (return i))))
+
+  (make-read-sequence fundamental-binary-input-stream stream-read-byte)
+  (make-read-sequence fundamental-character-input-stream stream-read-char))
+
+(defclass coder-stream-mixin ()
+  ((real-stream :type stream
+		:initarg :stream
+		:reader real-stream)
+   (dont-close :initform nil
+	       :initarg :dont-close)))
+
+(defmethod stream-file-position ((stream coder-stream-mixin) &optional position)
+  (apply #'file-position (remove nil (list (slot-value stream 'real-stream)
+                                           position))))
+
+(defclass coder-input-stream-mixin (fundamental-binary-input-stream coder-stream-mixin)
+  ())
+(defclass coder-output-stream-mixin (fundamental-binary-output-stream coder-stream-mixin)
+  ())
+
+
+(defclass quoted-printable-decoder-stream (coder-input-stream-mixin quoted-printable-decoder) ())
+(defclass base64-decoder-stream (coder-input-stream-mixin base64-decoder) ())
+(defclass 8bit-decoder-stream (coder-input-stream-mixin 8bit-decoder) ())
+
+(defclass quoted-printable-encoder-stream (coder-output-stream-mixin quoted-printable-encoder) ())
+(defclass base64-encoder-stream (coder-output-stream-mixin base64-encoder) ())
+(defclass 8bit-encoder-stream (coder-output-stream-mixin 8bit-encoder) ())
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defmethod initialize-instance :after ((stream coder-stream-mixin) &key &allow-other-keys)
+  (unless (slot-boundp stream 'real-stream)
+    (error "REAL-STREAM is unbound.  Must provide a :STREAM argument.")))
+
+(defmethod initialize-instance ((stream coder-output-stream-mixin) &key &allow-other-keys)
+  (call-next-method)
+  (unless (slot-boundp stream 'output-function)
+    (setf (slot-value stream 'output-function)
+	  #'(lambda (char)
+	      (write-char char (slot-value stream 'real-stream))))))
+
+(defmethod initialize-instance ((stream coder-input-stream-mixin) &key &allow-other-keys)
+  (call-next-method)
+  (unless (slot-boundp stream 'input-function)
+    (setf (slot-value stream 'input-function)
+	  #'(lambda ()
+	      (read-char (slot-value stream 'real-stream) nil)))))
+
+(defmethod stream-read-byte ((stream coder-input-stream-mixin))
+  (or (decoder-read-byte stream)
+      :eof))
+
+(defmethod stream-write-byte ((stream coder-output-stream-mixin) byte)
+  (encoder-write-byte stream byte))
+
+(defmethod close ((stream coder-stream-mixin) &key abort)
+  (with-slots (real-stream dont-close) stream
+    (unless dont-close
+      (close real-stream :abort abort))))
+
+(defmethod close ((stream coder-output-stream-mixin) &key abort)
+  (unless abort
+    (encoder-finish-output stream))
+  (call-next-method))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defclass encoder-input-stream (fundamental-character-input-stream coder-stream-mixin)
+  ((encoder)
+   (buffer-queue :initform (make-queue)))
+  (:documentation
+   "This is the base class for encoders with the direction swapped. It
+reads from REAL-STREAM a stream of bytes, encodes it and returnes it
+in a stream of character."))
+
+(defclass quoted-printable-encoder-input-stream (encoder-input-stream) ())
+(defclass base64-encoder-input-stream (encoder-input-stream) ())
+(defclass 8bit-encoder-input-stream (fundamental-character-input-stream coder-stream-mixin) ())
+
+(defmethod initialize-instance ((stream quoted-printable-encoder-input-stream) &key &allow-other-keys)
+  (call-next-method)
+  (with-slots (encoder buffer-queue) stream
+    (setf encoder
+	  (make-instance 'quoted-printable-encoder
+			 :output-function #'(lambda (char)
+					      (queue-append buffer-queue char))))))
+
+(defmethod initialize-instance ((stream base64-encoder-input-stream) &key &allow-other-keys)
+  (call-next-method)
+  (with-slots (encoder buffer-queue) stream
+    (setf encoder
+	  (make-instance 'base64-encoder
+			 :output-function #'(lambda (char)
+					      (queue-append buffer-queue char))))))
+
+(defmethod stream-read-char ((stream encoder-input-stream))
+  (with-slots (encoder buffer-queue real-stream) stream
+    (loop
+       while (queue-empty-p buffer-queue)
+       do (be byte (read-byte real-stream nil)
+	    (if byte
+		(encoder-write-byte encoder byte)
+		(progn
+		  (encoder-finish-output encoder)
+		  (queue-append buffer-queue :eof)))))
+    (queue-pop buffer-queue)))
+
+
+(defmethod stream-read-char ((stream 8bit-encoder-input-stream))
+  (with-slots (real-stream) stream
+    (aif (read-byte real-stream nil)
+	 (code-char it)
+	 :eof)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defclass input-adapter-stream ()
+  ((source :initarg :source)
+   (real-stream)
+   (input-function)))
+
+(defclass binary-input-adapter-stream (fundamental-binary-input-stream input-adapter-stream) ())
+
+(defclass character-input-adapter-stream (fundamental-character-input-stream input-adapter-stream) ())
+
+(defmethod stream-element-type ((stream binary-input-adapter-stream))
+  '(unsigned-byte 8))
+
+(defmethod initialize-instance ((stream input-adapter-stream) &key &allow-other-keys)
+  (call-next-method)
+  (assert (slot-boundp stream 'source)))
+
+(defmethod initialize-instance ((stream binary-input-adapter-stream) &key &allow-other-keys)
+  (call-next-method)
+  ;; REAL-STREAM slot is set only if we are going to close it later on
+  (with-slots (source real-stream input-function) stream
+    (etypecase source
+      (string
+       (setf real-stream (make-string-input-stream source)
+	     input-function #'(lambda ()
+				(awhen (read-char real-stream nil)
+				  (char-code it)))))
+      ((vector (unsigned-byte 8))
+       (be i 0
+	 (setf input-function #'(lambda ()
+				  (when (< i (length source))
+				    (prog1 (aref source i)
+				      (incf i)))))))
+      (stream
+       (assert (input-stream-p source))
+       (setf input-function (if (subtypep (stream-element-type source) 'character)
+				#'(lambda ()
+				    (awhen (read-char source nil)
+				      (char-code it)))
+				#'(lambda ()
+				    (read-byte source nil)))))
+      (pathname
+       (setf real-stream (open source :element-type '(unsigned-byte 8))
+	     input-function #'(lambda ()
+				(read-byte real-stream nil))))
+      (file-portion
+       (setf real-stream (open-decoded-file-portion source)
+	     input-function #'(lambda ()
+				(read-byte real-stream nil)))))))
+
+(defmethod initialize-instance ((stream character-input-adapter-stream) &key &allow-other-keys)
+  (call-next-method)
+  ;; REAL-STREAM slot is set only if we are going to close later on
+  (with-slots (source real-stream input-function) stream
+    (etypecase source
+      (string
+       (setf real-stream (make-string-input-stream source)
+	     input-function #'(lambda ()
+				(read-char real-stream nil))))
+      ((vector (unsigned-byte 8))
+       (be i 0
+	 (setf input-function #'(lambda ()
+				  (when (< i (length source))
+				    (prog1 (code-char (aref source i))
+				      (incf i)))))))
+      (stream
+       (assert (input-stream-p source))
+       (setf input-function (if (subtypep (stream-element-type source) 'character)
+				#'(lambda ()
+				    (read-char source nil))
+				#'(lambda ()
+				    (awhen (read-byte source nil)
+				      (code-char it))))))
+      (pathname
+       (setf real-stream (open source :element-type 'character)
+	     input-function #'(lambda ()
+				(read-char real-stream nil))))
+      (file-portion
+       (setf real-stream (open-decoded-file-portion source)
+	     input-function #'(lambda ()
+				(awhen (read-byte real-stream nil)
+				  (code-char it))))))))
+
+(defmethod close ((stream input-adapter-stream) &key abort)
+  (when (slot-boundp stream 'real-stream)
+    (with-slots (real-stream) stream
+      (close real-stream :abort abort))))
+
+(defmethod stream-read-byte ((stream binary-input-adapter-stream))
+  (with-slots (input-function) stream
+    (or (funcall input-function)
+	:eof)))
+
+(defmethod stream-read-char ((stream character-input-adapter-stream))
+  (with-slots (input-function) stream
+    (or (funcall input-function)
+	:eof)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defclass delimited-input-stream (fundamental-character-input-stream coder-stream-mixin)
+  ((start-offset :initarg :start
+		 :initform 0
+		 :reader stream-start
+		 :type integer)
+   (end-offset :initarg :end
+	       :initform nil
+	       :reader stream-end
+	       :type (or null integer))))
+
+(defmethod print-object ((object delimited-input-stream) stream)
+  (if *print-readably*
+      (call-next-method)
+      (with-slots (start-offset end-offset) object
+	(print-unreadable-object (object stream :type t :identity t)
+	  (format stream "start=~A end=~A" start-offset end-offset)))))
+
+(defun base-stream (stream)
+  (if (typep stream 'delimited-input-stream)
+      (base-stream (real-stream stream))
+      stream))
+
+(defmethod initialize-instance ((stream delimited-input-stream) &key &allow-other-keys)
+  (call-next-method)
+  (unless (slot-boundp stream 'real-stream)
+    (error "REAL-STREAM is unbound.  Must provide a :STREAM argument."))
+  (with-slots (start-offset) stream
+    (when start-offset
+      (file-position stream start-offset))))
+
+(defmethod stream-read-char ((stream delimited-input-stream))
+  (with-slots (real-stream end-offset) stream
+    (if (or (not end-offset)
+	    (< (file-position real-stream) end-offset))
+	(or (read-char real-stream nil)
+	    :eof)
+	:eof)))
+
+#+(OR)(defmethod stream-read-byte ((stream delimited-input-stream))
+  (with-slots (real-stream end-offset) stream
+    (if (or (not end-offset)
+	    (< (file-position real-stream) end-offset))
+	(or (read-byte real-stream nil)
+	    :eof)
+	:eof)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defclass my-string-input-stream (fundamental-character-input-stream coder-stream-mixin)
+  ((string :initarg :string
+	   :reader stream-string)))
+
+(defmethod initialize-instance ((stream my-string-input-stream) &key &allow-other-keys)
+  (call-next-method)
+  (assert (slot-boundp stream 'string))
+  (with-slots (string real-stream) stream
+    (setf real-stream (make-string-input-stream string))))
+
+(defmethod stream-read-char ((stream my-string-input-stream))
+  (with-slots (real-stream) stream
+    (or (read-char real-stream nil)
+	:eof)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defstruct file-portion
+  data					;  string or a pathname
+  encoding
+  start
+  end)
+
+(defun open-file-portion (file-portion)
+  (be data (file-portion-data file-portion)
+    (etypecase data
+      (pathname
+       (be stream (open data)
+	 (make-instance 'delimited-input-stream
+			:stream stream
+			:start (file-portion-start file-portion)
+			:end (file-portion-end file-portion))))
+      (string
+       (make-instance 'delimited-input-stream
+		      :stream (make-string-input-stream data)
+		      :start (file-portion-start file-portion)
+		      :end (file-portion-end file-portion)))
+      (stream
+       (make-instance 'delimited-input-stream
+		      :stream data
+		      :dont-close t
+		      :start (file-portion-start file-portion)
+		      :end (file-portion-end file-portion))))))
+
+(defun open-decoded-file-portion (file-portion)
+  (make-instance (case (file-portion-encoding file-portion)
+		   (:quoted-printable 'quoted-printable-decoder-stream)
+		   (:base64 'base64-decoder-stream)
+		   (t '8bit-decoder-stream))
+		 :stream (open-file-portion file-portion)))
diff --git a/third_party/lisp/mime4cl/test/address.lisp b/third_party/lisp/mime4cl/test/address.lisp
new file mode 100644
index 000000000000..aaa2d231f11c
--- /dev/null
+++ b/third_party/lisp/mime4cl/test/address.lisp
@@ -0,0 +1,124 @@
+;;;  address.lisp --- tests for the e-mail address parser
+
+;;;  Copyright (C) 2007, 2009 by Walter C. Pelissero
+
+;;;  Author: Walter C. Pelissero <walter@pelissero.de>
+;;;  Project: mime4cl
+
+#+cmu (ext:file-comment "$Module: address.lisp $")
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public License
+;;; as published by the Free Software Foundation; either version 2.1
+;;; of the License, or (at your option) any later version.
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free
+;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+;;; 02111-1307 USA
+
+(in-package :mime4cl-tests)
+
+(defun test-parsing (string)
+  (format nil "~{~A~^, ~}" (parse-addresses string)))
+
+(deftest address-parse-simple.1
+    (test-parsing "foo@bar")
+  "foo@bar")
+
+(deftest address-parse-simple.2
+    (test-parsing "foo@bar.com")
+  "foo@bar.com")
+
+(deftest address-parse-simple.3
+    (test-parsing "foo@bar.baz.com")
+  "foo@bar.baz.com")
+
+(deftest address-parse-simple.4
+    (test-parsing "foo.ooo@bar.baz.com")
+  "foo.ooo@bar.baz.com")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(deftest address-parse-simple-commented.1
+    (test-parsing "foo@bar (Some Comment)")
+  "\"Some Comment\" <foo@bar>")
+
+(deftest address-parse-simple-commented.2
+    (test-parsing "foo@bar (Some, Comment)")
+  "\"Some, Comment\" <foo@bar>")
+
+(deftest address-parse-simple-commented.3
+    (test-parsing "foo@bar (Some Comment (yes, indeed))")
+  "\"Some Comment (yes, indeed)\" <foo@bar>")
+
+(deftest address-parse-simple-commented.4
+    (test-parsing "foo.bar@host.complicated.domain.net (Some Comment (yes, indeed))")
+  "\"Some Comment (yes, indeed)\" <foo.bar@host.complicated.domain.net>")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(deftest address-parse-angle.1
+    (test-parsing "<foo@bar.baz.net>")
+  "foo@bar.baz.net")
+
+(deftest address-parse-angle.2
+    (test-parsing "My far far friend <foo@bar.baz.net>")
+  "\"My far far friend\" <foo@bar.baz.net>")
+
+(deftest address-parse-angle.3
+    (test-parsing "\"someone, I don't like\" <foo@bar.baz.net>")
+  "\"someone, I don't like\" <foo@bar.baz.net>")
+
+(deftest address-parse-angle.4
+    (test-parsing "\"this could (be a comment)\" <foo@bar.net>")
+  "\"this could (be a comment)\" <foo@bar.net>")
+
+(deftest address-parse-angle.5
+    (test-parsing "don't be fooled <foo@bar.net>")
+  "\"don't be fooled\" <foo@bar.net>")
+
+(deftest address-parse-angle.6
+    (test-parsing "<foo@bar>")
+  "foo@bar")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(deftest address-parse-domain-literal.1
+    (test-parsing "<foo@[bar]>")
+  "foo@[bar]")
+
+(deftest address-parse-domain-literal.2
+    (test-parsing "<foo@[bar.net]>")
+  "foo@[bar.net]")
+
+(deftest address-parse-domain-literal.3
+    (test-parsing "<foo@[10.0.0.2]>")
+  "foo@[10.0.0.2]")
+
+(deftest address-parse-domain-literal.4
+    (test-parsing "<foo.bar@[10.0.0.2]>")
+  "foo.bar@[10.0.0.2]")
+
+(deftest address-parse-domain-literal.5
+    (test-parsing "somewhere unkown <foo.bar@[10.0.0.2]>")
+  "\"somewhere unkown\" <foo.bar@[10.0.0.2]>")
+
+(deftest address-parse-domain-literal.6
+    (test-parsing "\"Some--One\" <foo.bar@[10.0.0.23]>")
+  "\"Some--One\" <foo.bar@[10.0.0.23]>")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(deftest address-parse-group.1
+    (test-parsing "friends:john@bar.in.soho, jack@pub.round.the.corner, jim@[10.0.1.2];")
+  "friends: john@bar.in.soho, jack@pub.round.the.corner, jim@[10.0.1.2];")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(deftest address-parse-mixed.1
+    (test-parsing "Foo BAR <foo@bar.com>, \"John, Smith (that one!)\" <john.smith@host.domain.org>, friends:john@bar,jack@pub;, foo.bar.baz@wow.mail.mine, dont.bark@me (Fierce Dog)")
+  "\"Foo BAR\" <foo@bar.com>, \"John, Smith (that one!)\" <john.smith@host.domain.org>, friends: john@bar, jack@pub;, foo.bar.baz@wow.mail.mine, \"Fierce Dog\" <dont.bark@me>")
diff --git a/third_party/lisp/mime4cl/test/endec.lisp b/third_party/lisp/mime4cl/test/endec.lisp
new file mode 100644
index 000000000000..7b6763c99035
--- /dev/null
+++ b/third_party/lisp/mime4cl/test/endec.lisp
@@ -0,0 +1,167 @@
+;;;  endec.lisp --- test suite for the MIME encoder/decoder functions
+
+;;;  Copyright (C) 2006, 2007, 2009, 2010 by Walter C. Pelissero
+
+;;;  Author: Walter C. Pelissero <walter@pelissero.de>
+;;;  Project: mime4cl
+
+#+cmu (ext:file-comment "$Module: endec.lisp $")
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public License
+;;; as published by the Free Software Foundation; either version 2.1
+;;; of the License, or (at your option) any later version.
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free
+;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+;;; 02111-1307 USA
+
+(in-package :mime4cl-tests)
+
+(deftest quoted-printable.1
+    (encode-quoted-printable-sequence (map '(vector (unsigned-byte 8)) #'char-code
+					   "Français, Español, böse, skøl"))
+  "Fran=E7ais, Espa=F1ol, b=F6se, sk=F8l")
+
+(deftest quoted-printable.2
+    (encode-quoted-printable-sequence (map '(vector (unsigned-byte 8)) #'char-code
+					   "Français, Español, böse, skøl")
+				      :start 10 :end 17)
+  "Espa=F1ol")
+
+(deftest quoted-printable.3
+    (map 'string #'code-char
+	 (decode-quoted-printable-string "Fran=E7ais, Espa=F1ol, b=F6se, sk=F8l"))
+  "Français, Español, böse, skøl")
+
+(deftest quoted-printable.4
+    (map 'string #'code-char
+	 (decode-quoted-printable-string "Fran=E7ais, Espa=F1ol, b=F6se, sk=F8l"
+					 :start 12 :end 21))
+  "Español")
+
+(deftest quoted-printable.5
+    (map 'string #'code-char
+	 (decode-quoted-printable-string "this = wrong"))
+  "this = wrong")
+
+(deftest quoted-printable.6
+    (map 'string #'code-char
+	 (decode-quoted-printable-string "this is wrong="))
+  "this is wrong=")
+
+(deftest quoted-printable.7
+    (map 'string #'code-char
+	 (decode-quoted-printable-string "this is wrong=1"))
+  "this is wrong=1")
+
+(deftest quoted-printable.8
+    (encode-quoted-printable-sequence (map '(vector (unsigned-byte 8)) #'char-code
+					   "x = x + 1"))
+  "x =3D x + 1")
+
+(deftest quoted-printable.9
+    (encode-quoted-printable-sequence (map '(vector (unsigned-byte 8)) #'char-code
+					   "x = x + 1   "))
+  "x =3D x + 1  =20")
+
+(deftest quoted-printable.10
+    (encode-quoted-printable-sequence (map '(vector (unsigned-byte 8)) #'char-code
+					   "this string is very very very very very very very very very very very very very very very very very very very very long"))
+  "this string is very very very very very very very very very very very ve=
+ry very very very very very very very very long")
+
+(deftest quoted-printable.11
+    (encode-quoted-printable-sequence (map '(vector (unsigned-byte 8)) #'char-code
+					   "this string is very very                                                                                  very very long"))
+  "this string is very very                                                =
+                                  very very long")
+
+(deftest quoted-printable.12
+    (encode-quoted-printable-sequence (map '(vector (unsigned-byte 8)) #'char-code
+					   "please read the next   
+line"))
+  "please read the next  =20
+line")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(deftest base64.1
+    (let ((*base64-line-length* nil))
+      (encode-base64-sequence (map '(vector (unsigned-byte 8)) #'char-code
+				   "Some random string.")))
+  "U29tZSByYW5kb20gc3RyaW5nLg==")
+
+(deftest base64.2
+    (let ((*base64-line-length* nil))
+      (encode-base64-sequence (map '(vector (unsigned-byte 8)) #'char-code
+				   "Some random string.") :start 5 :end 11))
+  "cmFuZG9t")
+
+(deftest base64.3
+    (map 'string #'code-char
+	 (decode-base64-string "U29tZSByYW5kb20gc3RyaW5nLg=="))
+  "Some random string.")
+
+(deftest base64.4
+    (map 'string #'code-char
+	 (decode-base64-string "some rubbish U29tZSByYW5kb20gc3RyaW5nLg== more rubbish"
+			       :start 13 :end 41))
+  "Some random string.")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(deftest RFC2047.1
+    (parse-RFC2047-text "foo bar")
+  ("foo bar"))
+
+(defun perftest-encoder (encoder-class &optional (megs 100))
+  (declare (optimize (speed 3) (debug 0) (safety 0))
+	   (type fixnum megs))
+  (with-open-file (in #P"/dev/random" :element-type '(unsigned-byte 8))
+    (let* ((meg (* 1024 1024))
+	   (buffer (make-sequence '(vector (unsigned-byte 8)) meg))
+	   (encoder (make-instance encoder-class
+				   :output-function #'(lambda (c) (declare (ignore c))))))
+      (declare (type fixnum meg))
+      (time
+       (progn
+	 (dotimes (x megs)
+	   (read-sequence buffer in)
+	   (dotimes (i meg)
+	     (mime4cl:encoder-write-byte encoder (aref buffer i))))
+	 (mime4cl:encoder-finish-output encoder))))))
+
+(defun perftest-decoder (decoder-class &optional (megs 100))
+  (declare (optimize (speed 3) (debug 0) (safety 0))
+	   (type fixnum megs))
+  (with-open-file (in #P"/dev/random" :element-type '(unsigned-byte 8))
+    (let ((sclf:*tmp-file-defaults* (make-pathname :defaults #.(or *load-pathname* *compile-file-pathname*)
+						   :type "encoded-data")))
+      (sclf:with-temp-file (tmp nil :direction :io)
+	(let* ((meg (* 1024 1024))
+	       (buffer (make-sequence '(vector (unsigned-byte 8)) meg))
+	       (encoder-class (ecase decoder-class
+				(mime4cl:base64-decoder 'mime4cl:base64-encoder)
+				(mime4cl:quoted-printable-decoder 'mime4cl:quoted-printable-encoder)))
+	       (encoder (make-instance encoder-class
+				       :output-function #'(lambda (c)
+							    (write-char c tmp))))
+	       (decoder (make-instance decoder-class
+				       :input-function #'(lambda ()
+							   (read-char tmp nil)))))
+	  (declare (type fixnum meg))
+	  (dotimes (x megs)
+	    (read-sequence buffer in)
+	    (dotimes (i meg)
+	      (mime4cl:encoder-write-byte encoder (aref buffer i))))
+	  (mime4cl:encoder-finish-output encoder)
+	  (file-position tmp 0)
+	  (time
+	   (loop
+	      for b = (mime4cl:decoder-read-byte decoder)
+	      while b)))))))
diff --git a/third_party/lisp/mime4cl/test/mime.lisp b/third_party/lisp/mime4cl/test/mime.lisp
new file mode 100644
index 000000000000..1488f927fcd3
--- /dev/null
+++ b/third_party/lisp/mime4cl/test/mime.lisp
@@ -0,0 +1,56 @@
+ ;;; mime.lisp --- MIME regression tests
+
+ ;;; Copyright (C) 2012 by Walter C. Pelissero
+ ;;; Copyright (C) 2021 by the TVL Authors
+
+ ;;; Author: Walter C. Pelissero <walter@pelissero.de>
+ ;;; Project: mime4cl
+
+#+cmu (ext:file-comment "$Module: mime.lisp")
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public License
+;;; as published by the Free Software Foundation; either version 2.1
+;;; of the License, or (at your option) any later version.
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free
+;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+;;; 02111-1307 USA
+
+(in-package :mime4cl-tests)
+
+(defvar *samples-directory*
+  (merge-pathnames (make-pathname :directory '(:relative "samples"))
+		   #.(or *compile-file-pathname*
+			 *load-pathname*
+			 #P"")))
+
+(defvar *sample1-file* (make-pathname :defaults #.(or *compile-file-pathname*
+                                                      *load-pathname*)
+                                      :name "sample1"
+                                      :type "msg"))
+
+(deftest mime.1
+    (let* ((orig (mime-message *sample1-file*))
+	   (dup (mime-message (with-output-to-string (out) (encode-mime-part orig out)))))
+      (mime= orig dup))
+  t)
+
+(deftest mime.2
+    (loop
+       for f in (directory (make-pathname :defaults *samples-directory*
+					  :name :wild
+					  :type "txt"))
+       do
+	 (format t "~A:~%" f)
+	 (finish-output)
+	 (let* ((orig (mime-message f))
+		(dup (mime-message (with-output-to-string (out) (encode-mime-part orig out)))))
+	   (unless (mime= orig dup)
+	     (return nil)))
+       finally (return t))
+  t)
diff --git a/third_party/lisp/mime4cl/test/package.lisp b/third_party/lisp/mime4cl/test/package.lisp
new file mode 100644
index 000000000000..bde0bf25d5b1
--- /dev/null
+++ b/third_party/lisp/mime4cl/test/package.lisp
@@ -0,0 +1,28 @@
+;;;  package.lisp --- package description for the regression tests
+
+;;;  Copyright (C) 2006, 2009 by Walter C. Pelissero
+
+;;;  Author: Walter C. Pelissero <walter@pelissero.de>
+;;;  Project: mime4cl
+
+#+cmu (ext:file-comment "$Module: package.lisp $")
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public License
+;;; as published by the Free Software Foundation; either version 2.1
+;;; of the License, or (at your option) any later version.
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free
+;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+;;; 02111-1307 USA
+
+(cl:in-package :common-lisp)
+
+(defpackage :mime4cl-tests
+  (:use :common-lisp
+	:rtest :mime4cl)
+  (:export))
diff --git a/third_party/lisp/mime4cl/test/rt.lisp b/third_party/lisp/mime4cl/test/rt.lisp
new file mode 100644
index 000000000000..d4dd2aedb677
--- /dev/null
+++ b/third_party/lisp/mime4cl/test/rt.lisp
@@ -0,0 +1,254 @@
+#|----------------------------------------------------------------------------|
+ | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. |
+ |                                                                            |
+ | Permission  to  use,  copy, modify, and distribute this software  and  its |
+ | documentation for any purpose  and without fee is hereby granted, provided |
+ | that this copyright  and  permission  notice  appear  in  all  copies  and |
+ | supporting  documentation,  and  that  the  name  of M.I.T. not be used in |
+ | advertising or  publicity  pertaining  to  distribution  of  the  software |
+ | without   specific,   written   prior   permission.      M.I.T.  makes  no |
+ | representations  about  the  suitability of this software for any purpose. |
+ | It is provided "as is" without express or implied warranty.                |
+ |                                                                            |
+ |  M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE,  INCLUDING  |
+ |  ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL  |
+ |  M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL  DAMAGES  OR  |
+ |  ANY  DAMAGES  WHATSOEVER  RESULTING  FROM  LOSS OF USE, DATA OR PROFITS,  |
+ |  WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER  TORTIOUS  ACTION,  |
+ |  ARISING  OUT  OF  OR  IN  CONNECTION WITH THE USE OR PERFORMANCE OF THIS  |
+ |  SOFTWARE.                                                                 |
+ |----------------------------------------------------------------------------|#
+
+(defpackage #:regression-test
+  (:nicknames #:rtest #-lispworks #:rt) 
+  (:use #:cl)
+  (:export #:*do-tests-when-defined* #:*test* #:continue-testing
+	   #:deftest #:do-test #:do-tests #:get-test #:pending-tests
+	   #:rem-all-tests #:rem-test)
+  (:documentation "The MIT regression tester with pfdietz's modifications"))
+
+(in-package :regression-test)
+
+(defvar *test* nil "Current test name")
+(defvar *do-tests-when-defined* nil)
+(defvar *entries* '(nil) "Test database")
+(defvar *in-test* nil "Used by TEST")
+(defvar *debug* nil "For debugging")
+(defvar *catch-errors* t
+  "When true, causes errors in a test to be caught.")
+(defvar *print-circle-on-failure* nil
+  "Failure reports are printed with *PRINT-CIRCLE* bound to this value.")
+(defvar *compile-tests* nil
+  "When true, compile the tests before running them.")
+(defvar *optimization-settings* '((safety 3)))
+(defvar *expected-failures* nil
+  "A list of test names that are expected to fail.")
+
+(defstruct (entry (:conc-name nil)
+		  (:type list))
+  pend name form)
+
+(defmacro vals (entry) `(cdddr ,entry))
+
+(defmacro defn (entry) `(cdr ,entry))
+
+(defun pending-tests ()
+  (do ((l (cdr *entries*) (cdr l))
+       (r nil))
+      ((null l) (nreverse r))
+    (when (pend (car l))
+      (push (name (car l)) r))))
+
+(defun rem-all-tests ()
+  (setq *entries* (list nil))
+  nil)
+
+(defun rem-test (&optional (name *test*))
+  (do ((l *entries* (cdr l)))
+      ((null (cdr l)) nil)
+    (when (equal (name (cadr l)) name)
+      (setf (cdr l) (cddr l))
+      (return name))))
+
+(defun get-test (&optional (name *test*))
+  (defn (get-entry name)))
+
+(defun get-entry (name)
+  (let ((entry (find name (cdr *entries*)
+		     :key #'name
+		     :test #'equal)))
+    (when (null entry)
+      (report-error t
+        "~%No test with name ~:@(~S~)."
+	name))
+    entry))
+
+(defmacro deftest (name form &rest values)
+  `(add-entry '(t ,name ,form .,values)))
+
+(defun add-entry (entry)
+  (setq entry (copy-list entry))
+  (do ((l *entries* (cdr l))) (nil)
+    (when (null (cdr l))
+      (setf (cdr l) (list entry))
+      (return nil))
+    (when (equal (name (cadr l)) 
+		 (name entry))
+      (setf (cadr l) entry)
+      (report-error nil
+        "Redefining test ~:@(~S~)"
+        (name entry))
+      (return nil)))
+  (when *do-tests-when-defined*
+    (do-entry entry))
+  (setq *test* (name entry)))
+
+(defun report-error (error? &rest args)
+  (cond (*debug* 
+	 (apply #'format t args)
+	 (if error? (throw '*debug* nil)))
+	(error? (apply #'error args))
+	(t (apply #'warn args))))
+
+(defun do-test (&optional (name *test*))
+  (do-entry (get-entry name)))
+
+(defun equalp-with-case (x y)
+  "Like EQUALP, but doesn't do case conversion of characters."
+  (cond
+   ((eq x y) t)
+   ((consp x)
+    (and (consp y)
+	 (equalp-with-case (car x) (car y))
+	 (equalp-with-case (cdr x) (cdr y))))
+   ((and (typep x 'array)
+	 (= (array-rank x) 0))
+    (equalp-with-case (aref x) (aref y)))
+   ((typep x 'vector)
+    (and (typep y 'vector)
+	 (let ((x-len (length x))
+	       (y-len (length y)))
+	   (and (eql x-len y-len)
+		(loop
+		 for e1 across x
+		 for e2 across y
+		 always (equalp-with-case e1 e2))))))
+   ((and (typep x 'array)
+	 (typep y 'array)
+	 (not (equal (array-dimensions x)
+		     (array-dimensions y))))
+    nil)
+   ((typep x 'array)
+    (and (typep y 'array)
+	 (let ((size (array-total-size x)))
+	   (loop for i from 0 below size
+		 always (equalp-with-case (row-major-aref x i)
+					  (row-major-aref y i))))))
+   (t (eql x y))))
+
+(defun do-entry (entry &optional
+		       (s *standard-output*))
+  (catch '*in-test*
+    (setq *test* (name entry))
+    (setf (pend entry) t)
+    (let* ((*in-test* t)
+	   ;; (*break-on-warnings* t)
+	   (aborted nil)
+	   r)
+      ;; (declare (special *break-on-warnings*))
+
+      (block aborted
+	(setf r
+	      (flet ((%do
+		      ()
+		      (if *compile-tests*
+			  (multiple-value-list
+			   (funcall (compile
+				     nil
+				     `(lambda ()
+					(declare
+					 (optimize ,@*optimization-settings*))
+					,(form entry)))))
+			(multiple-value-list
+			 (eval (form entry))))))
+		(if *catch-errors*
+		    (handler-bind
+			((style-warning #'muffle-warning)
+			 (error #'(lambda (c)
+				    (setf aborted t)
+				    (setf r (list c))
+				    (return-from aborted nil))))
+		      (%do))
+		  (%do)))))
+
+      (setf (pend entry)
+	    (or aborted
+		(not (equalp-with-case r (vals entry)))))
+      
+      (when (pend entry)
+	(let ((*print-circle* *print-circle-on-failure*))
+	  (format s "~&Test ~:@(~S~) failed~
+                   ~%Form: ~S~
+                   ~%Expected value~P: ~
+                      ~{~S~^~%~17t~}~%"
+		  *test* (form entry)
+		  (length (vals entry))
+		  (vals entry))
+	  (format s "Actual value~P: ~
+                      ~{~S~^~%~15t~}.~%"
+		  (length r) r)))))
+  (when (not (pend entry)) *test*))
+
+(defun continue-testing ()
+  (if *in-test*
+      (throw '*in-test* nil)
+      (do-entries *standard-output*)))
+
+(defun do-tests (&optional
+		 (out *standard-output*))
+  (dolist (entry (cdr *entries*))
+    (setf (pend entry) t))
+  (if (streamp out)
+      (do-entries out)
+      (with-open-file 
+	  (stream out :direction :output)
+	(do-entries stream))))
+
+(defun do-entries (s)
+  (format s "~&Doing ~A pending test~:P ~
+             of ~A tests total.~%"
+          (count t (cdr *entries*)
+		 :key #'pend)
+	  (length (cdr *entries*)))
+  (dolist (entry (cdr *entries*))
+    (when (pend entry)
+      (format s "~@[~<~%~:; ~:@(~S~)~>~]"
+	      (do-entry entry s))))
+  (let ((pending (pending-tests))
+	(expected-table (make-hash-table :test #'equal)))
+    (dolist (ex *expected-failures*)
+      (setf (gethash ex expected-table) t))
+    (let ((new-failures
+	   (loop for pend in pending
+		 unless (gethash pend expected-table)
+		 collect pend)))
+      (if (null pending)
+	  (format s "~&No tests failed.")
+	(progn
+	  (format s "~&~A out of ~A ~
+                   total tests failed: ~
+                   ~:@(~{~<~%   ~1:;~S~>~
+                         ~^, ~}~)."
+		  (length pending)
+		  (length (cdr *entries*))
+		  pending)
+	  (if (null new-failures)
+	      (format s "~&No unexpected failures.")
+	    (when *expected-failures*
+	      (format s "~&~A unexpected failures: ~
+                   ~:@(~{~<~%   ~1:;~S~>~
+                         ~^, ~}~)."
+		    (length new-failures)
+		    new-failures)))
+	  ))
+      (null pending))))
diff --git a/third_party/lisp/mime4cl/test/sample1.msg b/third_party/lisp/mime4cl/test/sample1.msg
new file mode 100644
index 000000000000..662a9fab341e
--- /dev/null
+++ b/third_party/lisp/mime4cl/test/sample1.msg
@@ -0,0 +1,86 @@
+From wcp@scylla.home.lan Fri Feb 17 11:02:28 2012
+Status: RO
+X-VM-v5-Data: ([nil nil nil nil nil nil nil nil nil]
+	["1133" "Friday" "17" "February" "2012" "11:02:27" "+0100" "Walter C. Pelissero" "walter@pelissero.de" nil "56" "test" "^From:" nil nil "2" nil nil nil nil nil nil nil nil nil nil]
+	nil)
+X-Clpmr-Processed: 2012-02-17T11:02:31
+X-Clpmr-Version: 2011-10-23T12:55:20, SBCL 1.0.49
+Received: from scylla.home.lan (localhost [127.0.0.1])
+	by scylla.home.lan (8.14.5/8.14.5) with ESMTP id q1HA2Sik004513
+	for <wcp@scylla.home.lan>; Fri, 17 Feb 2012 11:02:28 +0100 (CET)
+	(envelope-from wcp@scylla.home.lan)
+Received: (from wcp@localhost)
+	by scylla.home.lan (8.14.5/8.14.5/Submit) id q1HA2SqU004512;
+	Fri, 17 Feb 2012 11:02:28 +0100 (CET)
+	(envelope-from wcp)
+Message-ID: <20286.9651.890757.323027@scylla.home.lan>
+X-Mailer: VM 8.1.1 under 23.3.1 (amd64-portbld-freebsd8.2)
+Reply-To: walter@pelissero.de
+X-Attribution: WP
+X-For-Spammers: blacklistme@pelissero.de
+X-MArch-Processing-Time: 0.552s
+MIME-Version: 1.0
+Content-Type: multipart/mixed; boundary="615CiWUaGO"
+Content-Transfer-Encoding: 7BIT
+From: walter@pelissero.de (Walter C. Pelissero)
+To: wcp@scylla.home.lan
+Subject: test
+Date: Fri, 17 Feb 2012 11:02:27 +0100
+
+
+--615CiWUaGO
+Content-Type: text/plain; charset="us-ascii"
+Content-Transfer-Encoding: 7BIT
+Content-Description: message body text
+
+Hereafter three attachments.
+
+The first:
+
+--615CiWUaGO
+Content-Type: application/octet-stream; name="attach1"
+Content-Transfer-Encoding: BASE64
+Content-Disposition: attachment; filename="attach1"
+
+YXR0YWNoMQo=

+
+--615CiWUaGO
+Content-Type: text/plain; charset="us-ascii"
+Content-Transfer-Encoding: 7BIT
+Content-Description: message body text
+
+
+The second:
+
+--615CiWUaGO
+Content-Type: application/octet-stream; name="attach2"
+Content-Transfer-Encoding: BASE64
+Content-Disposition: attachment; filename="attach2"
+
+YXR0YWNoMgo=

+
+--615CiWUaGO
+Content-Type: text/plain; charset="us-ascii"
+Content-Transfer-Encoding: 7BIT
+Content-Description: message body text
+
+
+The third:
+
+--615CiWUaGO
+Content-Type: application/octet-stream; name="attach3"
+Content-Transfer-Encoding: BASE64
+Content-Disposition: attachment; filename="attach3"
+
+YXR0YWNoMwo=

+
+--615CiWUaGO
+Content-Type: text/plain; charset="us-ascii"
+Content-Transfer-Encoding: 7BIT
+Content-Description: .signature
+
+
+-- 
+http://pelissero.de
+--615CiWUaGO--
+
diff --git a/third_party/lisp/moptilities.nix b/third_party/lisp/moptilities.nix
new file mode 100644
index 000000000000..a8a387ab914f
--- /dev/null
+++ b/third_party/lisp/moptilities.nix
@@ -0,0 +1,18 @@
+# Compatibility layer for minor MOP implementation differences
+{ depot, pkgs, ... }:
+
+let src = pkgs.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" ];
+
+  brokenOn = [
+    "ecl" # TODO(sterni): https://gitlab.com/embeddable-common-lisp/ecl/-/issues/651
+  ];
+}
diff --git a/third_party/lisp/nibbles.nix b/third_party/lisp/nibbles.nix
new file mode 100644
index 000000000000..da542fe91130
--- /dev/null
+++ b/third_party/lisp/nibbles.nix
@@ -0,0 +1,32 @@
+{ depot, pkgs, ... }:
+
+let
+  inherit (depot.nix.buildLisp) bundled;
+  src = pkgs.fetchFromGitHub {
+    owner = "sharplispers";
+    repo = "nibbles";
+    rev = "dad25240928d5cf8f7df69c4398244e03570bb35";
+    sha256 = "0r6ljlpgjmkf87pmvdwzva8qj15bhznc3ylgcjjqyy4frbx9lygz";
+    name = "nibbles-source";
+  };
+
+in depot.nix.buildLisp.library {
+  name = "nibbles";
+
+  deps = with depot.third_party.lisp; [
+    (bundled "asdf")
+  ];
+
+  srcs = map (f: src + ("/" + f)) [
+    "package.lisp"
+    "types.lisp"
+    "macro-utils.lisp"
+    "vectors.lisp"
+    "streams.lisp"
+  ] ++ [
+    { sbcl = "${src}/sbcl-opt/fndb.lisp"; }
+    { sbcl = "${src}/sbcl-opt/nib-tran.lisp"; }
+    { sbcl = "${src}/sbcl-opt/x86-vm.lisp"; }
+    { sbcl = "${src}/sbcl-opt/x86-64-vm.lisp"; }
+  ];
+}
diff --git a/third_party/lisp/npg/.project b/third_party/lisp/npg/.project
new file mode 100644
index 000000000000..82a8fe48bbfb
--- /dev/null
+++ b/third_party/lisp/npg/.project
@@ -0,0 +1 @@
+NPG a Naive Parser Generator
diff --git a/third_party/lisp/npg/.skip-subtree b/third_party/lisp/npg/.skip-subtree
new file mode 100644
index 000000000000..5051f60d6b86
--- /dev/null
+++ b/third_party/lisp/npg/.skip-subtree
@@ -0,0 +1 @@
+prevent readTree from creating entries for subdirs that don't contain an .nix files
diff --git a/third_party/lisp/npg/COPYING b/third_party/lisp/npg/COPYING
new file mode 100644
index 000000000000..223ede7de3ec
--- /dev/null
+++ b/third_party/lisp/npg/COPYING
@@ -0,0 +1,504 @@
+		  GNU LESSER GENERAL PUBLIC LICENSE
+		       Version 2.1, February 1999
+
+ Copyright (C) 1991, 1999 Free Software Foundation, Inc.
+     59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+[This is the first released version of the Lesser GPL.  It also counts
+ as the successor of the GNU Library Public License, version 2, hence
+ the version number 2.1.]
+
+			    Preamble
+
+  The licenses for most software are designed to take away your
+freedom to share and change it.  By contrast, the GNU General Public
+Licenses are intended to guarantee your freedom to share and change
+free software--to make sure the software is free for all its users.
+
+  This license, the Lesser General Public License, applies to some
+specially designated software packages--typically libraries--of the
+Free Software Foundation and other authors who decide to use it.  You
+can use it too, but we suggest you first think carefully about whether
+this license or the ordinary General Public License is the better
+strategy to use in any particular case, based on the explanations below.
+
+  When we speak of free software, we are referring to freedom of use,
+not price.  Our General Public Licenses are designed to make sure that
+you have the freedom to distribute copies of free software (and charge
+for this service if you wish); that you receive source code or can get
+it if you want it; that you can change the software and use pieces of
+it in new free programs; and that you are informed that you can do
+these things.
+
+  To protect your rights, we need to make restrictions that forbid
+distributors to deny you these rights or to ask you to surrender these
+rights.  These restrictions translate to certain responsibilities for
+you if you distribute copies of the library or if you modify it.
+
+  For example, if you distribute copies of the library, whether gratis
+or for a fee, you must give the recipients all the rights that we gave
+you.  You must make sure that they, too, receive or can get the source
+code.  If you link other code with the library, you must provide
+complete object files to the recipients, so that they can relink them
+with the library after making changes to the library and recompiling
+it.  And you must show them these terms so they know their rights.
+
+  We protect your rights with a two-step method: (1) we copyright the
+library, and (2) we offer you this license, which gives you legal
+permission to copy, distribute and/or modify the library.
+
+  To protect each distributor, we want to make it very clear that
+there is no warranty for the free library.  Also, if the library is
+modified by someone else and passed on, the recipients should know
+that what they have is not the original version, so that the original
+author's reputation will not be affected by problems that might be
+introduced by others.
+
+  Finally, software patents pose a constant threat to the existence of
+any free program.  We wish to make sure that a company cannot
+effectively restrict the users of a free program by obtaining a
+restrictive license from a patent holder.  Therefore, we insist that
+any patent license obtained for a version of the library must be
+consistent with the full freedom of use specified in this license.
+
+  Most GNU software, including some libraries, is covered by the
+ordinary GNU General Public License.  This license, the GNU Lesser
+General Public License, applies to certain designated libraries, and
+is quite different from the ordinary General Public License.  We use
+this license for certain libraries in order to permit linking those
+libraries into non-free programs.
+
+  When a program is linked with a library, whether statically or using
+a shared library, the combination of the two is legally speaking a
+combined work, a derivative of the original library.  The ordinary
+General Public License therefore permits such linking only if the
+entire combination fits its criteria of freedom.  The Lesser General
+Public License permits more lax criteria for linking other code with
+the library.
+
+  We call this license the "Lesser" General Public License because it
+does Less to protect the user's freedom than the ordinary General
+Public License.  It also provides other free software developers Less
+of an advantage over competing non-free programs.  These disadvantages
+are the reason we use the ordinary General Public License for many
+libraries.  However, the Lesser license provides advantages in certain
+special circumstances.
+
+  For example, on rare occasions, there may be a special need to
+encourage the widest possible use of a certain library, so that it becomes
+a de-facto standard.  To achieve this, non-free programs must be
+allowed to use the library.  A more frequent case is that a free
+library does the same job as widely used non-free libraries.  In this
+case, there is little to gain by limiting the free library to free
+software only, so we use the Lesser General Public License.
+
+  In other cases, permission to use a particular library in non-free
+programs enables a greater number of people to use a large body of
+free software.  For example, permission to use the GNU C Library in
+non-free programs enables many more people to use the whole GNU
+operating system, as well as its variant, the GNU/Linux operating
+system.
+
+  Although the Lesser General Public License is Less protective of the
+users' freedom, it does ensure that the user of a program that is
+linked with the Library has the freedom and the wherewithal to run
+that program using a modified version of the Library.
+
+  The precise terms and conditions for copying, distribution and
+modification follow.  Pay close attention to the difference between a
+"work based on the library" and a "work that uses the library".  The
+former contains code derived from the library, whereas the latter must
+be combined with the library in order to run.
+
+		  GNU LESSER GENERAL PUBLIC LICENSE
+   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+  0. This License Agreement applies to any software library or other
+program which contains a notice placed by the copyright holder or
+other authorized party saying it may be distributed under the terms of
+this Lesser General Public License (also called "this License").
+Each licensee is addressed as "you".
+
+  A "library" means a collection of software functions and/or data
+prepared so as to be conveniently linked with application programs
+(which use some of those functions and data) to form executables.
+
+  The "Library", below, refers to any such software library or work
+which has been distributed under these terms.  A "work based on the
+Library" means either the Library or any derivative work under
+copyright law: that is to say, a work containing the Library or a
+portion of it, either verbatim or with modifications and/or translated
+straightforwardly into another language.  (Hereinafter, translation is
+included without limitation in the term "modification".)
+
+  "Source code" for a work means the preferred form of the work for
+making modifications to it.  For a library, complete source code means
+all the source code for all modules it contains, plus any associated
+interface definition files, plus the scripts used to control compilation
+and installation of the library.
+
+  Activities other than copying, distribution and modification are not
+covered by this License; they are outside its scope.  The act of
+running a program using the Library is not restricted, and output from
+such a program is covered only if its contents constitute a work based
+on the Library (independent of the use of the Library in a tool for
+writing it).  Whether that is true depends on what the Library does
+and what the program that uses the Library does.
+  
+  1. You may copy and distribute verbatim copies of the Library's
+complete source code as you receive it, in any medium, provided that
+you conspicuously and appropriately publish on each copy an
+appropriate copyright notice and disclaimer of warranty; keep intact
+all the notices that refer to this License and to the absence of any
+warranty; and distribute a copy of this License along with the
+Library.
+
+  You may charge a fee for the physical act of transferring a copy,
+and you may at your option offer warranty protection in exchange for a
+fee.
+
+  2. You may modify your copy or copies of the Library or any portion
+of it, thus forming a work based on the Library, and copy and
+distribute such modifications or work under the terms of Section 1
+above, provided that you also meet all of these conditions:
+
+    a) The modified work must itself be a software library.
+
+    b) You must cause the files modified to carry prominent notices
+    stating that you changed the files and the date of any change.
+
+    c) You must cause the whole of the work to be licensed at no
+    charge to all third parties under the terms of this License.
+
+    d) If a facility in the modified Library refers to a function or a
+    table of data to be supplied by an application program that uses
+    the facility, other than as an argument passed when the facility
+    is invoked, then you must make a good faith effort to ensure that,
+    in the event an application does not supply such function or
+    table, the facility still operates, and performs whatever part of
+    its purpose remains meaningful.
+
+    (For example, a function in a library to compute square roots has
+    a purpose that is entirely well-defined independent of the
+    application.  Therefore, Subsection 2d requires that any
+    application-supplied function or table used by this function must
+    be optional: if the application does not supply it, the square
+    root function must still compute square roots.)
+
+These requirements apply to the modified work as a whole.  If
+identifiable sections of that work are not derived from the Library,
+and can be reasonably considered independent and separate works in
+themselves, then this License, and its terms, do not apply to those
+sections when you distribute them as separate works.  But when you
+distribute the same sections as part of a whole which is a work based
+on the Library, the distribution of the whole must be on the terms of
+this License, whose permissions for other licensees extend to the
+entire whole, and thus to each and every part regardless of who wrote
+it.
+
+Thus, it is not the intent of this section to claim rights or contest
+your rights to work written entirely by you; rather, the intent is to
+exercise the right to control the distribution of derivative or
+collective works based on the Library.
+
+In addition, mere aggregation of another work not based on the Library
+with the Library (or with a work based on the Library) on a volume of
+a storage or distribution medium does not bring the other work under
+the scope of this License.
+
+  3. You may opt to apply the terms of the ordinary GNU General Public
+License instead of this License to a given copy of the Library.  To do
+this, you must alter all the notices that refer to this License, so
+that they refer to the ordinary GNU General Public License, version 2,
+instead of to this License.  (If a newer version than version 2 of the
+ordinary GNU General Public License has appeared, then you can specify
+that version instead if you wish.)  Do not make any other change in
+these notices.
+
+  Once this change is made in a given copy, it is irreversible for
+that copy, so the ordinary GNU General Public License applies to all
+subsequent copies and derivative works made from that copy.
+
+  This option is useful when you wish to copy part of the code of
+the Library into a program that is not a library.
+
+  4. You may copy and distribute the Library (or a portion or
+derivative of it, under Section 2) in object code or executable form
+under the terms of Sections 1 and 2 above provided that you accompany
+it with the complete corresponding machine-readable source code, which
+must be distributed under the terms of Sections 1 and 2 above on a
+medium customarily used for software interchange.
+
+  If distribution of object code is made by offering access to copy
+from a designated place, then offering equivalent access to copy the
+source code from the same place satisfies the requirement to
+distribute the source code, even though third parties are not
+compelled to copy the source along with the object code.
+
+  5. A program that contains no derivative of any portion of the
+Library, but is designed to work with the Library by being compiled or
+linked with it, is called a "work that uses the Library".  Such a
+work, in isolation, is not a derivative work of the Library, and
+therefore falls outside the scope of this License.
+
+  However, linking a "work that uses the Library" with the Library
+creates an executable that is a derivative of the Library (because it
+contains portions of the Library), rather than a "work that uses the
+library".  The executable is therefore covered by this License.
+Section 6 states terms for distribution of such executables.
+
+  When a "work that uses the Library" uses material from a header file
+that is part of the Library, the object code for the work may be a
+derivative work of the Library even though the source code is not.
+Whether this is true is especially significant if the work can be
+linked without the Library, or if the work is itself a library.  The
+threshold for this to be true is not precisely defined by law.
+
+  If such an object file uses only numerical parameters, data
+structure layouts and accessors, and small macros and small inline
+functions (ten lines or less in length), then the use of the object
+file is unrestricted, regardless of whether it is legally a derivative
+work.  (Executables containing this object code plus portions of the
+Library will still fall under Section 6.)
+
+  Otherwise, if the work is a derivative of the Library, you may
+distribute the object code for the work under the terms of Section 6.
+Any executables containing that work also fall under Section 6,
+whether or not they are linked directly with the Library itself.
+
+  6. As an exception to the Sections above, you may also combine or
+link a "work that uses the Library" with the Library to produce a
+work containing portions of the Library, and distribute that work
+under terms of your choice, provided that the terms permit
+modification of the work for the customer's own use and reverse
+engineering for debugging such modifications.
+
+  You must give prominent notice with each copy of the work that the
+Library is used in it and that the Library and its use are covered by
+this License.  You must supply a copy of this License.  If the work
+during execution displays copyright notices, you must include the
+copyright notice for the Library among them, as well as a reference
+directing the user to the copy of this License.  Also, you must do one
+of these things:
+
+    a) Accompany the work with the complete corresponding
+    machine-readable source code for the Library including whatever
+    changes were used in the work (which must be distributed under
+    Sections 1 and 2 above); and, if the work is an executable linked
+    with the Library, with the complete machine-readable "work that
+    uses the Library", as object code and/or source code, so that the
+    user can modify the Library and then relink to produce a modified
+    executable containing the modified Library.  (It is understood
+    that the user who changes the contents of definitions files in the
+    Library will not necessarily be able to recompile the application
+    to use the modified definitions.)
+
+    b) Use a suitable shared library mechanism for linking with the
+    Library.  A suitable mechanism is one that (1) uses at run time a
+    copy of the library already present on the user's computer system,
+    rather than copying library functions into the executable, and (2)
+    will operate properly with a modified version of the library, if
+    the user installs one, as long as the modified version is
+    interface-compatible with the version that the work was made with.
+
+    c) Accompany the work with a written offer, valid for at
+    least three years, to give the same user the materials
+    specified in Subsection 6a, above, for a charge no more
+    than the cost of performing this distribution.
+
+    d) If distribution of the work is made by offering access to copy
+    from a designated place, offer equivalent access to copy the above
+    specified materials from the same place.
+
+    e) Verify that the user has already received a copy of these
+    materials or that you have already sent this user a copy.
+
+  For an executable, the required form of the "work that uses the
+Library" must include any data and utility programs needed for
+reproducing the executable from it.  However, as a special exception,
+the materials to be distributed need not include anything that is
+normally distributed (in either source or binary form) with the major
+components (compiler, kernel, and so on) of the operating system on
+which the executable runs, unless that component itself accompanies
+the executable.
+
+  It may happen that this requirement contradicts the license
+restrictions of other proprietary libraries that do not normally
+accompany the operating system.  Such a contradiction means you cannot
+use both them and the Library together in an executable that you
+distribute.
+
+  7. You may place library facilities that are a work based on the
+Library side-by-side in a single library together with other library
+facilities not covered by this License, and distribute such a combined
+library, provided that the separate distribution of the work based on
+the Library and of the other library facilities is otherwise
+permitted, and provided that you do these two things:
+
+    a) Accompany the combined library with a copy of the same work
+    based on the Library, uncombined with any other library
+    facilities.  This must be distributed under the terms of the
+    Sections above.
+
+    b) Give prominent notice with the combined library of the fact
+    that part of it is a work based on the Library, and explaining
+    where to find the accompanying uncombined form of the same work.
+
+  8. You may not copy, modify, sublicense, link with, or distribute
+the Library except as expressly provided under this License.  Any
+attempt otherwise to copy, modify, sublicense, link with, or
+distribute the Library is void, and will automatically terminate your
+rights under this License.  However, parties who have received copies,
+or rights, from you under this License will not have their licenses
+terminated so long as such parties remain in full compliance.
+
+  9. You are not required to accept this License, since you have not
+signed it.  However, nothing else grants you permission to modify or
+distribute the Library or its derivative works.  These actions are
+prohibited by law if you do not accept this License.  Therefore, by
+modifying or distributing the Library (or any work based on the
+Library), you indicate your acceptance of this License to do so, and
+all its terms and conditions for copying, distributing or modifying
+the Library or works based on it.
+
+  10. Each time you redistribute the Library (or any work based on the
+Library), the recipient automatically receives a license from the
+original licensor to copy, distribute, link with or modify the Library
+subject to these terms and conditions.  You may not impose any further
+restrictions on the recipients' exercise of the rights granted herein.
+You are not responsible for enforcing compliance by third parties with
+this License.
+
+  11. If, as a consequence of a court judgment or allegation of patent
+infringement or for any other reason (not limited to patent issues),
+conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License.  If you cannot
+distribute so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you
+may not distribute the Library at all.  For example, if a patent
+license would not permit royalty-free redistribution of the Library by
+all those who receive copies directly or indirectly through you, then
+the only way you could satisfy both it and this License would be to
+refrain entirely from distribution of the Library.
+
+If any portion of this section is held invalid or unenforceable under any
+particular circumstance, the balance of the section is intended to apply,
+and the section as a whole is intended to apply in other circumstances.
+
+It is not the purpose of this section to induce you to infringe any
+patents or other property right claims or to contest validity of any
+such claims; this section has the sole purpose of protecting the
+integrity of the free software distribution system which is
+implemented by public license practices.  Many people have made
+generous contributions to the wide range of software distributed
+through that system in reliance on consistent application of that
+system; it is up to the author/donor to decide if he or she is willing
+to distribute software through any other system and a licensee cannot
+impose that choice.
+
+This section is intended to make thoroughly clear what is believed to
+be a consequence of the rest of this License.
+
+  12. If the distribution and/or use of the Library is restricted in
+certain countries either by patents or by copyrighted interfaces, the
+original copyright holder who places the Library under this License may add
+an explicit geographical distribution limitation excluding those countries,
+so that distribution is permitted only in or among countries not thus
+excluded.  In such case, this License incorporates the limitation as if
+written in the body of this License.
+
+  13. The Free Software Foundation may publish revised and/or new
+versions of the Lesser General Public License from time to time.
+Such new versions will be similar in spirit to the present version,
+but may differ in detail to address new problems or concerns.
+
+Each version is given a distinguishing version number.  If the Library
+specifies a version number of this License which applies to it and
+"any later version", you have the option of following the terms and
+conditions either of that version or of any later version published by
+the Free Software Foundation.  If the Library does not specify a
+license version number, you may choose any version ever published by
+the Free Software Foundation.
+
+  14. If you wish to incorporate parts of the Library into other free
+programs whose distribution conditions are incompatible with these,
+write to the author to ask for permission.  For software which is
+copyrighted by the Free Software Foundation, write to the Free
+Software Foundation; we sometimes make exceptions for this.  Our
+decision will be guided by the two goals of preserving the free status
+of all derivatives of our free software and of promoting the sharing
+and reuse of software generally.
+
+			    NO WARRANTY
+
+  15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO
+WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW.
+EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR
+OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY
+KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE
+LIBRARY IS WITH YOU.  SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME
+THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
+
+  16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN
+WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY
+AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU
+FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR
+CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE
+LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
+RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
+FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
+SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH
+DAMAGES.
+
+		     END OF TERMS AND CONDITIONS
+
+           How to Apply These Terms to Your New Libraries
+
+  If you develop a new library, and you want it to be of the greatest
+possible use to the public, we recommend making it free software that
+everyone can redistribute and change.  You can do so by permitting
+redistribution under these terms (or, alternatively, under the terms of the
+ordinary General Public License).
+
+  To apply these terms, attach the following notices to the library.  It is
+safest to attach them to the start of each source file to most effectively
+convey the exclusion of warranty; and each file should have at least the
+"copyright" line and a pointer to where the full notice is found.
+
+    <one line to give the library's name and a brief idea of what it does.>
+    Copyright (C) <year>  <name of author>
+
+    This library is free software; you can redistribute it and/or
+    modify it under the terms of the GNU Lesser General Public
+    License as published by the Free Software Foundation; either
+    version 2 of the License, or (at your option) any later version.
+
+    This library is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+    Lesser General Public License for more details.
+
+    You should have received a copy of the GNU Lesser General Public
+    License along with this library; if not, write to the Free Software
+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+Also add information on how to contact you by electronic and paper mail.
+
+You should also get your employer (if you work as a programmer) or your
+school, if any, to sign a "copyright disclaimer" for the library, if
+necessary.  Here is a sample; alter the names:
+
+  Yoyodyne, Inc., hereby disclaims all copyright interest in the
+  library `Frob' (a library for tweaking knobs) written by James Random Hacker.
+
+  <signature of Ty Coon>, 1 April 1990
+  Ty Coon, President of Vice
+
+That's all there is to it!
+
+
diff --git a/third_party/lisp/npg/OWNERS b/third_party/lisp/npg/OWNERS
new file mode 100644
index 000000000000..f16dd105d761
--- /dev/null
+++ b/third_party/lisp/npg/OWNERS
@@ -0,0 +1,3 @@
+inherited: true
+owners:
+  - sterni
diff --git a/third_party/lisp/npg/README b/third_party/lisp/npg/README
new file mode 100644
index 000000000000..a1661e744a37
--- /dev/null
+++ b/third_party/lisp/npg/README
@@ -0,0 +1,48 @@
+
+		     NPG a Naive Parser Generator
+			   for Common Lisp
+
+	 Copyright (C) 2003-2006, 2010 by Walter C. Pelissero
+	 Copyright (C) 2021 by the TVL Authors
+
+Vendored into depot as it is a dependency of mime4cl and upstream has
+become inactive. Upstream and depot version may diverge.
+
+Upstream Website: http://wcp.sdf-eu.org/software/#npg
+Vendored Tarball: http://wcp.sdf-eu.org/software/npg-20150517T144652.tbz
+
+This library is  free software; you can redistribute  it and/or modify
+it  under  the terms  of  the GNU  Lesser  General  Public License  as
+published by the  Free Software Foundation; either version  2.1 of the
+License,  or (at  your option)  any  later version.   This library  is
+distributed  in the  hope  that it  will  be useful,  but WITHOUT  ANY
+WARRANTY;  without even  the  implied warranty  of MERCHANTABILITY  or
+FITNESS FOR A  PARTICULAR PURPOSE.  See the GNU  Lesser General Public
+License for more details.  You should  have received a copy of the GNU
+Lesser General Public  License along with this library;  if not, write
+to the  Free Software  Foundation, Inc., 59  Temple Place,  Suite 330,
+Boston, MA 02111-1307 USA
+
+
+This library generates on the fly (no external representation of the
+parser is produced) a recursive descent parser based on the grammar
+rules you have fed it with.  The parser object can then be used to
+scan tokenised input.  Although a facility to produce a lexical
+analiser is not provided, to write such a library is fairly easy for
+most languages.  NPG parsers require your lexer to adhere to a certain
+protocol to be able to communicate with them.  Examples are provided
+that explain these requirements.
+
+While quite possibly not producing the fastest parsers in town, it's
+fairly simple and hopefully easy to debug.  It accepts a lispy EBNF
+grammar description of arbitrary complexity with the exception of
+mutually left recursive rules (watch out, they produce undetected
+infinite recursion) and produces a backtracking recursive descent
+parser.  Immediate left recursive rules are properly simplified,
+though.
+
+Multiple concurrent parsers are supported.
+
+To compile, an ASDF and nix file are provided.
+
+See the examples directory for clues on how to use it.
diff --git a/third_party/lisp/npg/default.nix b/third_party/lisp/npg/default.nix
new file mode 100644
index 000000000000..af7ec53eaf93
--- /dev/null
+++ b/third_party/lisp/npg/default.nix
@@ -0,0 +1,14 @@
+# Copyright (C) 2021 by the TVL Authors
+# SPDX-License-Identifier: LGPL-2.1-or-later
+{ depot, pkgs, ... }:
+
+depot.nix.buildLisp.library {
+  name = "npg";
+
+  srcs = [
+    ./src/package.lisp
+    ./src/common.lisp
+    ./src/define.lisp
+    ./src/parser.lisp
+  ];
+}
diff --git a/third_party/lisp/npg/examples/python.lisp b/third_party/lisp/npg/examples/python.lisp
new file mode 100644
index 000000000000..68d794ddec03
--- /dev/null
+++ b/third_party/lisp/npg/examples/python.lisp
@@ -0,0 +1,336 @@
+;;;  python.lisp --- sample grammar definition for the Python language
+
+;;;  Copyright (C) 2003 by Walter C. Pelissero
+
+;;;  Author: Walter C. Pelissero <walter@pelissero.de>
+;;;  Project: NPG a Naive Parser Generator
+;;;  $Id: F-C1A8CD5961889C584B22F05E8B956006.lisp,v 1.3 2004/03/09 10:33:06 wcp Exp $
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public License
+;;; as published by the Free Software Foundation; either version 2.1
+;;; of the License, or (at your option) any later version.
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free
+;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+;;; 02111-1307 USA
+
+;;;  Commentary:
+;;;
+;;; This is far from being a complete Python grammar.  Actually I
+;;; haven't even read a Python book before starting to write this
+;;; stuff, so the code below comes mostly from wild guessing while
+;;; reading a Python source file.
+;;;
+;;; It's a design decision to avoid writing any transformation in this
+;;; module; only tagging is done at this level.  This improves the
+;;; separation between parsing and transformation, making the grammar
+;;; reusable for other purposes.
+
+
+#+cmu (ext:file-comment "$Id: F-C1A8CD5961889C584B22F05E8B956006.lisp,v 1.3 2004/03/09 10:33:06 wcp Exp $")
+
+(in-package :grammar)
+
+(deflazy define-grammar
+  (let ((*package* #.*package*)
+	(*compile-print* (and parser::*debug* t)))
+    (reset-grammar)
+    (format t "~&creating Python grammar...~%")
+    (populate-grammar)
+    (let ((grammar (parser:generate-grammar)))
+      (reset-grammar)
+      (parser:print-grammar-figures grammar)
+      grammar)))
+
+(defun populate-grammar ()
+
+(defrule program
+    := comment-string? statement+)
+
+(defrule comment-string
+    := string eol
+    :reduce string)
+
+;;; BOB = Beginning Of Block, EOB = End Of Block.  It's lexical
+;;; analyzer's task to find out where a statement or block starts/ends.
+
+(defrule suite
+    := statement-list eol
+    :reduce statement-list
+    := statement-block)
+
+(defrule commentable-suite
+    := statement-list eol
+    :reduce statement-list
+    := commented-statement-block)
+
+(defrule statement-block
+    := bob statement+ eob
+    :reduce $2)
+
+(defrule commented-statement-block
+    := bob comment-string? statement* eob
+    :reduce (cons comment-string statement))
+
+(defrule statement-list
+    := (+ simple-statement ";")
+    :reduce (if (cdr $1)
+		(cons :statement-list $1)
+		(car $1)))
+
+(defrule statement
+    := statement-list eol
+    :reduce statement-list
+    := compound-statement)
+
+(defrule simple-statement
+    := import-statement
+    := raise-statement
+    := assignment
+    := function-call
+    := return-statement
+    := assert-statement
+    := pass-statement
+    := break-statement
+    := continue-statement)
+
+(defrule compound-statement
+    := class-definition
+    := method-definition
+    := try-statement
+    := if-statement
+    := while-statement
+    := for-statement)
+
+(defrule import-statement
+    := "import" (+ package-name ",")
+    :tag :import
+    := "from" package-name "import" (+ symbol-name ",")
+    :tag :import-from)
+
+(defrule package-name := identifier)
+
+(defrule symbol-name
+    := identifier
+    := "*")
+
+(defrule try-statement
+    := "try" ":" suite try-except-part* try-finally-part?
+    :tag :try)
+
+(defrule try-except-part
+    := "except" exception-subject? ":" suite)
+
+(defrule try-finally-part
+    := "finally" ":" suite)
+
+(defrule exception-subject
+    := exception-name exception-variable?)
+
+(defrule exception-variable
+    := "," identifier)
+
+(defrule exception-name := class-name)
+
+(defrule class-name := identifier)
+
+(defrule raise-statement
+    := "raise"
+    :tag :raise-same
+    := "raise" exception-name
+    :tag :raise
+    := "raise" exception-name "," expression
+    :tag :raise
+    := "raise" exception-name "(" expression ")"
+    :tag :raise)
+
+(defrule assignment
+    := (+ variable-with-optional-subscript ",") "=" more-assignment
+    :tag :set)
+
+(defrule more-assignment
+    := expression
+    := assignment)
+
+(defrule variable-with-optional-subscript
+    := variable-name subscript
+    :tag :subscript
+    := variable-name)
+
+(defrule variable-name
+    := (+ identifier ".")
+    :tag :varef)
+
+(defrule expression
+    := expression "or" expression1
+    :tag :or
+    := expression1)
+
+(defrule expression1
+    := expression1 "and" expression2
+    :tag :and
+    := expression2)
+
+(defrule expression2
+    := expression2 "==" expression3
+    :tag :equal
+    := expression2 ">=" expression3
+    :tag :more-equal
+    := expression2 "<=" expression3
+    :tag :less-equal
+    := expression2 "!=" expression3
+    :tag :not-equal
+    := expression2 ">" expression3
+    :tag :more
+    := expression2 "<" expression3
+    :tag :less
+    := expression2 "is" expression3
+    :tag :equal
+    := expression2 "is" "not" expression3
+    :tag :not-equal
+    := expression3)
+
+(defrule expression3
+    := expression3 "+" expression4
+    :tag :plus
+    := expression3 "-" expression4
+    :tag :minus
+    := expression3 "|" expression4
+    :tag :bit-or
+    := expression4)
+
+;; high priority expression
+(defrule expression4
+    := expression4 "*" expression5
+    :tag :mult
+    := expression4 "/" expression5
+    :tag :div
+    := expression4 "%" expression5
+    :tag :modulo
+    := expression4 "&" expression5
+    :tag :bit-and
+    := expression4 "in" expression5
+    :tag :in
+    := expression5)
+
+(defrule expression5
+    := "~" expression5
+    :tag :bit-not
+    := "not" expression5
+    :tag :not
+    := "(" expression ")"
+    := expression6)
+
+(defrule expression6
+    := simple-expression subscript
+    :tag :subscript
+    := simple-expression)
+
+(defrule simple-expression
+    := function-call
+    := variable-name
+    := constant
+    := string-conversion
+    := list-constructor)
+
+(defrule subscript
+    := "[" expression "]"
+    := "[" expression ":" expression "]"
+    := "[" expression ":" "]"
+    :reduce (list expression nil)
+    := "[" ":" expression "]"
+    :reduce (list nil expression))
+
+(defrule string-conversion
+    := "`" expression "`"
+    :tag :to-string)
+
+(defrule constant
+    := number
+    := string
+    := lambda-expression)
+
+(defrule number
+    := float
+    := integer)
+
+(defrule list-constructor
+    := "[" (* expression ",") "]"
+    :tag :make-list)
+
+(defrule class-definition
+    := "class" class-name superclasses? ":" commentable-suite
+    :tag :defclass)
+
+(defrule superclasses
+    := "(" class-name+ ")")
+
+(defrule method-definition
+    := "def" method-name "(" method-arguments ")" ":" commentable-suite
+    :tag :defmethod)
+
+(defrule method-arguments
+    := (* method-argument ","))
+
+(defrule method-argument
+    := identifier argument-default?)
+
+(defrule argument-default
+    := "=" expression)
+
+(defrule method-name := identifier)
+
+(defrule if-statement
+    := "if" expression ":" suite elif-part* else-part?
+    :tag :if)
+
+(defrule else-part
+    :=  "else" ":" suite)
+
+(defrule elif-part
+    := "elif" expression ":" suite)
+
+(defrule lambda-expression
+    := "lambda" method-arguments ":" expression
+    :tag :lambda)
+
+(defrule function-call
+    := (+ identifier ".") "(" (* expression ",") ")"
+    :tag :funcall)
+
+(defrule for-statement
+    := "for" identifier "in" expression ":" suite
+    :tag :do-list
+    := "for" identifier "in" "range" "(" expression "," expression ")" ":" suite
+    :tag :do-range)
+
+(defrule while-statement
+    := "while" expression ":" suite
+    :tag :while)
+
+(defrule return-statement
+    := "return" expression?
+    :tag :return)
+
+(defrule assert-statement
+    := "assert" expression "," string
+    :tag :assert)
+
+(defrule pass-statement
+    := "pass"
+    :tag :pass)
+
+(defrule break-statement
+    := "break"
+    :tag :break)
+
+(defrule continue-statement
+    := "continue"
+    :tag :continue)
+
+)					; end of POPULATE-GRAMMAR
diff --git a/third_party/lisp/npg/examples/vs-cobol-ii.lisp b/third_party/lisp/npg/examples/vs-cobol-ii.lisp
new file mode 100644
index 000000000000..2edf1292da53
--- /dev/null
+++ b/third_party/lisp/npg/examples/vs-cobol-ii.lisp
@@ -0,0 +1,1901 @@
+;;;  vs-cobol-ii.lisp --- sample grammar for VS-Cobol II
+
+;;;  Copyright (C) 2003 by Walter C. Pelissero
+
+;;;  Author: Walter C. Pelissero <walter@pelissero.de>
+;;;  Project: NPG a Naive Parser Generator
+;;;  $Id: F-1D03709AEB30BA7644C1CFA2DF60FE8C.lisp,v 1.2 2004/03/09 10:33:07 wcp Exp $
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public License
+;;; as published by the Free Software Foundation; either version 2.1
+;;; of the License, or (at your option) any later version.
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free
+;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+;;; 02111-1307 USA
+
+;;;  Commentary:
+;;;
+;;; A fairly incomplete VS-Cobol II grammar fro NPG.  It's probably
+;;; not very accurate either.
+
+#+cmu (ext:file-comment "$Id: F-1D03709AEB30BA7644C1CFA2DF60FE8C.lisp,v 1.2 2004/03/09 10:33:07 wcp Exp $")
+
+(in-package :grammar)
+
+(defun make-keyword (string)
+  "Create a keyword from STRING."
+  (intern (string-upcase string) :keyword))
+
+(defun flatten-list (list)
+  "Remove one depth level in LIST."
+  (mapcan #'identity list))
+
+(deflazy define-grammar
+  (let ((*package* #.*package*)
+	(*compile-print* (and parser::*debug* t)))
+    (reset-grammar)
+    (format t "creating Cobol grammar...~%")
+    (populate-grammar)
+    (let ((grammar (parser:generate-grammar)))
+      (reset-grammar)
+      (parser:print-grammar-figures grammar)
+      grammar)))
+
+(defun populate-grammar ()
+;;;
+;;; Hereafter PP means Partial Program
+;;;
+
+#+nil
+(defrule pp--declarations
+    := identification-division environment-division? data-division? "PROCEDURE" "DIVISION" using-phrase? "." :rest)
+
+;;; We need to split the parsing of the declarations from the rest
+;;; because the declarations may change the lexical rules (ie decimal
+;;; point)
+
+(defrule pp--declarations
+    := identification-division environment-division? data-division-head-or-procedure-division-head :rest)
+
+(defrule data-division-head-or-procedure-division-head
+    := data-division-head
+    :reduce :data-division
+    := procedure-division-head
+    :reduce (list :procedure-division $1))
+
+(defrule pp--data-division
+    := data-division-content procedure-division-head :rest)
+
+(defrule pp--sentence
+    := sentence :rest
+    := :eof)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; The real grammar
+;;;
+
+(defrule cobol-source-program
+    := identification-division environment-division? data-division procedure-division end-program?)
+
+(defrule identification-division
+    := identification "DIVISION" "." program-id-cobol-source-program identification-division-content
+    :reduce program-id-cobol-source-program)
+
+(defrule priority-number
+    := integer)
+
+(defrule level-number
+    := integer)
+
+(defrule to-id-or-lit
+    := "TO" id-or-lit)
+
+(defrule inspect-by-argument
+    := variable-identifier
+    := string
+    := figurative-constant-simple)
+
+(defrule figurative-constant-simple
+    := "ZERO"
+    :reduce :zero
+    := "ZEROS"
+    :reduce :zero
+    := "ZEROES"
+    :reduce :zero
+    := "SPACE"
+    :reduce :space
+    := "SPACES"
+    :reduce :space
+    := "HIGH-VALUE"
+    :reduce :high
+    := "HIGH-VALUES"
+    :reduce :high
+    := "LOW-VALUE"
+    :reduce :low
+    := "LOW-VALUES"
+    :reduce :low
+    := "QUOTE"
+    :reduce :quote
+    := "QUOTES"
+    :reduce :quote
+    := "NULL"
+    :reduce :null
+    := "NULLS"
+    :reduce :null)
+
+(defrule write-exceptions
+    := at-end-of-page-statement-list? not-at-end-of-page-statement-list? invalid-key-statement-list? not-invalid-key-statement-list?)
+
+(defrule set-statement-phrase
+    := variable-identifier+ set-oper set-src)
+
+(defrule set-src
+    := variable-identifier
+    := literal
+    := "TRUE"
+    := "ON"
+    := "OFF")
+
+(defrule set-oper
+    := "TO"
+    :reduce :to
+    := "UP" "BY"
+    :reduce :up
+    := "DOWN" "BY"
+    :reduce :down)
+
+(defrule fce-phrase
+    := reserve-clause
+    := fce-organization
+    := fce-access-mode
+    := record-key-clause
+    := password-clause
+    := alternate-record-key-clause
+    := file-status-clause
+    := padding-character-clause
+    := record-delimiter-clause)
+
+(defrule fce-organization
+    := organization-is? alt-indexed-relative-sequential
+    :reduce (list :organization (make-keyword alt-indexed-relative-sequential)))
+
+(defrule fce-access-mode
+    := "ACCESS" "MODE"? "IS"? alt-sequential-random-dynamic relative-key-clause?
+    :reduce (list :access-mode (make-keyword alt-sequential-random-dynamic)))
+
+(defrule alt-indexed-relative-sequential
+    := "INDEXED"
+    := "RELATIVE"
+    := "SEQUENTIAL")
+
+(defrule is-not
+    := "IS"? "NOT"?)
+
+(defrule all-procedures
+    := "ALL" "PROCEDURES")
+
+(defrule next-sentence
+    := "NEXT" "SENTENCE")
+
+(defrule no-rewind
+    := "NO" "REWIND")
+
+(defrule for-removal
+    := "FOR"? "REMOVAL")
+
+(defrule values
+    := "VALUE"
+    := "VALUES")
+
+(defrule records
+    := "RECORD"
+    := "RECORDS")
+
+(defrule end-program
+    := "END" "PROGRAM" program-name ".")
+
+(defrule environment-division
+    := "ENVIRONMENT" "DIVISION" "." environment-division-content)
+
+(defrule data-division-head
+    := "DATA" "DIVISION" ".")
+
+(defrule data-division
+    := data-division-head data-division-content
+    :reduce data-division-content)
+
+(defrule identification
+    := "IDENTIFICATION"
+    := "ID")
+
+(defrule identification-division-content
+    := identification-division-phrase*)
+
+(defrule author
+    := "AUTHOR" ".")
+
+(defrule installation
+    := "INSTALLATION" ".")
+
+(defrule date-written
+    := "DATE-WRITTEN" ".")
+
+(defrule date-compiled
+    := "DATE-COMPILED" ".")
+
+(defrule security
+    := "SECURITY" ".")
+
+(defrule remarks
+    := "REMARKS" ".")
+
+(defrule identification-division-phrase
+    := author
+    := installation
+    := date-written
+    := date-compiled
+    := security
+    := remarks)
+
+(defrule program-id-cobol-source-program
+    := "PROGRAM-ID" "."? program-name initial-program? "."
+    :reduce program-name)
+
+(defrule initial-program
+    := "IS"? "INITIAL" "PROGRAM"?)
+
+(defrule environment-division-content
+    := configuration-section? input-output-section?)
+
+(defrule input-output-section
+    := "INPUT-OUTPUT" "SECTION" "." file-control-paragraph? i-o-control-paragraph?
+    :reduce file-control-paragraph)
+
+(defrule file-control-paragraph
+    := "FILE-CONTROL" "." file-control-entry*)
+
+(defrule file-control-entry
+    := select-clause assign-clause fce-phrase* "."
+    :reduce (append select-clause
+		    assign-clause
+		    (flatten-list fce-phrase)))
+
+(defrule organization-is
+    := "ORGANIZATION" "IS"?)
+
+(defrule alt-sequential-random-dynamic
+    := "SEQUENTIAL"
+    := "RANDOM"
+    := "DYNAMIC")
+
+(defrule select-clause
+    := "SELECT" "OPTIONAL"? file-name
+    :reduce (list file-name :optional (and $2 t)))
+
+(defrule assign-clause
+    := "ASSIGN" "TO"? alt-assignment-name-literal+
+    :reduce (list :assign alt-assignment-name-literal))
+
+(defrule alt-assignment-name-literal
+    := assignment-name
+    := literal)
+
+(defrule reserve-clause
+    := "RESERVE" integer areas?)
+
+(defrule areas
+    := "AREA"
+    := "AREAS")
+
+(defrule padding-character-clause
+    := "PADDING" "CHARACTER"? "IS"? alt-qualified-data-name-literal)
+
+(defrule record-delimiter-clause
+    := "RECORD" "DELIMITER" "IS"? record-delimiter-name)
+
+(defrule record-delimiter-name
+    := "STANDARD-1"
+    := assignment-name)
+
+(defrule password-clause
+    := "PASSWORD" "IS"? data-name)
+
+(defrule file-status-clause
+    := "FILE"? "STATUS" "IS"? qualified-data-name qualified-data-name?
+    :reduce (list :file-status qualified-data-name))
+
+(defrule relative-key-clause
+    := "RELATIVE" "KEY"? "IS"? qualified-data-name
+    :reduce (list :relative-key qualified-data-name))
+
+(defrule record-key-clause
+    := "RECORD" "KEY"? "IS"? qualified-data-name
+    :reduce (list :key qualified-data-name))
+
+(defrule alternate-record-key-clause
+    := "ALTERNATE" "RECORD"? "KEY"? "IS"? qualified-data-name password-clause? with-duplicates?
+    :reduce (list :alternate-key qualified-data-name with-duplicates))
+
+(defrule with-duplicates
+    := "WITH"? "DUPLICATES")
+
+(defrule i-o-control-paragraph
+    := "I-O-CONTROL" "." i-o-sam? i-o-sort-merge?)
+
+(defrule i-o-sam
+    := qsam-or-sam-or-vsam-i-o-control-entries+ ".")
+
+(defrule i-o-sort-merge
+    := sort-merge-i-o-control-entries ".")
+
+(defrule qsam-or-sam-or-vsam-i-o-control-entries
+    := qsam-or-sam-or-vsam-i-o-control-entries-1
+    := qsam-or-sam-or-vsam-i-o-control-entries-2
+    := qsam-or-sam-or-vsam-i-o-control-entries-3
+    := qsam-or-sam-or-vsam-i-o-control-entries-4)
+
+(defrule qsam-or-sam-or-vsam-i-o-control-entries-1
+    := "RERUN" "ON" alt-assignment-name-file-name "EVERY"? every-phrase "OF"? file-name)
+
+(defrule every-phrase-1
+    := integer "RECORDS")
+
+(defrule every-phrase-2
+    := "END" "OF"? alt-reel-unit)
+
+(defrule every-phrase
+    := every-phrase-1
+    := every-phrase-2)
+
+(defrule alt-assignment-name-file-name
+    := assignment-name
+    := file-name)
+
+(defrule qsam-or-sam-or-vsam-i-o-control-entries-2
+    := "SAME" "RECORD"? "AREA"? "FOR"? file-name file-name+)
+
+(defrule qsam-or-sam-or-vsam-i-o-control-entries-3
+    := "MULTIPLE" "FILE" "TAPE"? "CONTAINS"? file-name-position+)
+
+(defrule position
+    := "POSITION" integer)
+
+(defrule file-name-position
+    := file-name position?)
+
+(defrule qsam-or-sam-or-vsam-i-o-control-entries-4
+    := "APPLY" "WRITE-ONLY" "ON"? file-name+)
+
+(defrule sort-merge-i-o-control-entries
+    := rerun-on? same-area+)
+
+(defrule rerun-on
+    := "RERUN" "ON" assignment-name)
+
+(defrule record-sort
+    := "RECORD"
+    := "SORT"
+    := "SORT-MERGE")
+
+(defrule same-area
+    := "SAME" record-sort "AREA"? "FOR"? file-name file-name+)
+
+(defrule configuration-section
+    := "CONFIGURATION" "SECTION" "." configuration-section-paragraph*
+    :reduce (flatten-list configuration-section-paragraph))
+
+(defrule configuration-section-paragraph
+    := source-computer-paragraph
+    := object-computer-paragraph
+    := special-names-paragraph)
+
+(defrule source-computer-paragraph
+    := "SOURCE-COMPUTER" "." source-computer-name
+    :reduce (list :source-computer source-computer-name))
+
+(defrule with-debugging-mode
+    := "WITH"? "DEBUGGING" "MODE")
+
+(defrule source-computer-name
+    := computer-name with-debugging-mode? "."
+    :reduce computer-name)
+
+(defrule object-computer-paragraph
+    := "OBJECT-COMPUTER" "." object-computer-name
+    :reduce (list :object-computer object-computer-name))
+
+(defrule memory-size-type
+    := "WORDS"
+    := "CHARACTERS"
+    := "MODULES")
+
+(defrule memory-size
+    := "MEMORY" "SIZE"? integer memory-size-type)
+
+(defrule object-computer-name
+    := computer-name memory-size? object-computer-paragraph-sequence-phrase "."
+    :reduce computer-name)
+
+(defrule object-computer-paragraph-sequence-phrase
+    := program-collating-sequence? segment-limit?)
+
+(defrule program-collating-sequence
+    := "PROGRAM"? "COLLATING"? "SEQUENCE" "IS"? alphabet-name)
+
+(defrule segment-limit
+    := "SEGMENT-LIMIT" "IS"? priority-number)
+
+(defrule special-names-paragraph
+    := "SPECIAL-NAMES" "." special-names-paragraph-phrase* special-names-paragraph-clause* "."
+    :reduce (flatten-list special-names-paragraph-clause))
+
+(defrule is-mnemonic-name
+    := "IS"? mnemonic-name special-names-paragraph-status-phrase?)
+
+(defrule special-names-paragraph-phrase-tail
+    := is-mnemonic-name
+    := special-names-paragraph-status-phrase)
+
+(defrule special-names-paragraph-phrase
+    := environment-name special-names-paragraph-phrase-tail)
+
+(defrule special-names-paragraph-status-phrase
+    := special-names-paragraph-status-phrase-1
+    := special-names-paragraph-status-phrase-2)
+
+(defrule special-names-paragraph-status-phrase-1
+    := "ON" "STATUS"? "IS"? condition off-status?)
+
+(defrule off-status
+    := "OFF" "STATUS"? "IS"? condition)
+
+(defrule special-names-paragraph-status-phrase-2
+    := "OFF" "STATUS"? "IS"? condition on-status?)
+
+(defrule on-status
+    := "ON" "STATUS"? "IS"? condition)
+
+(defrule special-names-paragraph-clause
+    ;; := alphabet-clause
+    ;; := symbolic-characters-clause
+    := currency-sign-clause
+    := decimal-point-clause)
+
+(defrule alphabet-clause
+    := "ALPHABET" alphabet-name "IS"? alphabet-type)
+
+(defrule alphabet-type-also
+    := "ALSO" literal)
+
+(defrule alphabet-type-alsos
+    := alphabet-type-also+)
+
+(defrule alphabet-type-also-through
+    := through-literal
+    := alphabet-type-alsos)
+
+(defrule alphabet-type-other
+    := literal alphabet-type-also-through?)
+
+(defrule alphabet-type-others
+    := alphabet-type-other+)
+
+(defrule alphabet-type
+    := "STANDARD-1"
+    := "STANDARD-2"
+    := "NATIVE"
+    := "EBCDIC"
+    := alphabet-type-others)
+
+(defrule symbolic-characters-clause
+    := "SYMBOLIC" "CHARACTERS"? symbolic-character-mapping+ in-alphabet-name?)
+
+(defrule are
+    := "ARE"
+    := "IS")
+
+(defrule symbolic-character-mapping
+    := symbolic-character+ are? integer+)
+
+(defrule in-alphabet-name
+    := "IN" alphabet-name)
+
+(defrule currency-sign-clause
+    := "CURRENCY" "SIGN"? "IS"? literal
+    :reduce (list :currency-sign literal))
+
+(defrule decimal-point-clause
+    := "DECIMAL-POINT" "IS"? "COMMA"
+    :reduce (list :decimal-point #\,))
+
+(defrule data-division-content
+    := file-section? working-storage-section? linkage-section?)
+
+(defrule file-section-entry
+    := file-and-sort-description-entry data-description-entry+
+    :reduce (cons file-and-sort-description-entry data-description-entry))
+
+(defrule file-section-head
+    := "FILE" "SECTION" ".")
+
+(defrule file-section
+    := file-section-head file-section-entry*
+    :reduce $2)
+
+(defrule working-storage-section-head
+    := "WORKING-STORAGE" "SECTION" ".")
+
+(defrule working-storage-section
+    := working-storage-section-head data-description-entry*
+    :reduce $2)
+
+(defrule linkage-section-head
+    := "LINKAGE" "SECTION" ".")
+
+(defrule linkage-section
+    := linkage-section-head data-description-entry*
+    :reduce $2)
+
+(defrule file-and-sort-description-entry
+    := alt-fd-sd file-name file-and-sort-description-entry-clause* "."
+    :reduce (list (make-keyword alt-fd-sd) file-name file-and-sort-description-entry-clause))
+
+(defrule alt-fd-sd
+    := "FD"
+    := "SD")
+
+(defrule file-and-sort-description-entry-clause
+    := external-clause
+    := global-clause
+    := block-contains-clause
+    := record-clause
+    := label-records-clause
+    := value-of-clause
+    := data-records-clause
+    := linage-clause
+    := recording-mode-clause
+    := code-set-clause)
+
+(defrule integer-to
+    := integer "TO")
+
+(defrule block-contains-clause
+    := "BLOCK" "CONTAINS"? integer-to? integer alt-characters-records?)
+
+(defrule alt-characters-records
+    := "CHARACTERS"
+    := "RECORDS"
+    := "RECORD")
+
+(defrule record-clause
+    := "RECORD" record-clause-tail)
+
+(defrule depending-on
+    := "DEPENDING" "ON"? data-name)
+
+(defrule record-clause-tail-1
+    := "CONTAINS"? integer "CHARACTERS"?)
+
+(defrule record-clause-tail-2
+    := "CONTAINS"? integer "TO" integer "CHARACTERS"?)
+
+(defrule record-clause-tail-3
+    := record-varying-phrase depending-on?)
+
+(defrule record-clause-tail
+    := record-clause-tail-2
+    := record-clause-tail-1
+    := record-clause-tail-3)
+
+(defrule record-varying-phrase
+    := "IS"? "VARYING" "IN"? "SIZE"? from-integer? to-integer? "CHARACTERS"?)
+
+(defrule from-integer
+    := "FROM"? integer)
+
+(defrule to-integer
+    := "TO" integer)
+
+(defrule label-records-clause
+    := "LABEL" records-are label-records-clause-tail
+    :reduce (list :label-record label-records-clause-tail))
+
+(defrule data-names
+    := data-name+)
+
+(defrule label-records-clause-tail
+    := "STANDARD" :reduce :standard
+    := "OMITTED" :reduce :omitted
+    := data-names)
+
+(defrule value-of-clause
+    := "VALUE" "OF" value-of-clause-tail+)
+
+(defrule alt-qualified-data-name-literal
+    := qualified-data-name
+    := literal)
+
+(defrule value-of-clause-tail
+    := variable-identifier "IS"? alt-qualified-data-name-literal)
+
+(defrule data-records-clause
+    := "DATA" records-are data-name+)
+
+(defrule records-are
+    := records are?)
+
+(defrule linage-clause
+    := "LINAGE" "IS"? alt-data-name-integer "LINES"? linage-footing-phrase)
+
+(defrule linage-footing-phrase
+    := footing? lines-top? lines-bottom?)
+
+(defrule alt-data-name-integer
+    := data-name
+    := integer)
+
+(defrule footing
+    := "WITH"? "FOOTING" "AT"? alt-data-name-integer)
+
+(defrule lines-top
+    := "LINES"? "AT"? "TOP" alt-data-name-integer)
+
+(defrule lines-bottom
+    := "LINES"? "AT"? "BOTTOM" alt-data-name-integer)
+
+(defrule recording-mode-clause
+    := "RECORDING" "MODE"? "IS"? variable-identifier)
+
+(defrule code-set-clause
+    := "CODE-SET" "IS"? alphabet-name)
+
+(defrule data-description-entry
+    := level-number alt-data-name-filler? data-description-entry-clause* "."
+    :reduce (append (list level-number alt-data-name-filler)
+		    (flatten-list data-description-entry-clause)))
+
+(defrule alt-data-name-filler
+    := data-name
+    := "FILLER"
+    :reduce (list))
+
+(defrule data-description-entry-clause
+    := picture-clause
+    := redefines-clause
+    := blank-when-zero-clause
+    := external-clause
+    := global-clause
+    := justified-clause
+    := occurs-clause
+    := sign-clause
+    := synchronized-clause
+    := usage-clause
+    := renames-clause
+    := value-clause)
+
+(defrule value-clause
+    := "VALUE" "IS"? literal
+    :reduce (list :value literal))
+
+(defrule redefines-clause
+    := "REDEFINES" data-name
+    :reduce `(:redefines ,data-name))
+
+(defrule blank-when-zero-clause
+    := "BLANK" "WHEN"? zeroes
+    :reduce '(:blank-when-zero t))
+
+(defrule zeroes
+    := "ZERO"
+    := "ZEROS"
+    := "ZEROES")
+
+(defrule external-clause
+    := "IS"? "EXTERNAL"
+    :reduce '(:external t))
+
+(defrule global-clause
+    := "IS"? "GLOBAL"
+    :reduce '(:global t))
+
+(defrule justified-clause
+    := justified "RIGHT"?
+    :reduce `(:justified ,(if $2 :right :left)))
+
+(defrule justified
+    := "JUSTIFIED"
+    := "JUST")
+
+(defrule occurs-clause
+    := "OCCURS" integer "TIMES"? occurs-clause-key* indexed-by?
+    ;; to be completed -wcp16/7/03.
+    :reduce `(:times ,integer)
+    := "OCCURS" integer "TO" integer "TIMES"? "DEPENDING" "ON"? qualified-data-name occurs-clause-key* indexed-by?
+    ;; to be completed -wcp16/7/03.
+    :reduce `(:times (,integer ,integer2 ,qualified-data-name)))
+
+(defrule occurs-clause-key
+    := alt-ascending-descending "KEY"? "IS"? qualified-data-name+)
+
+(defrule indexed-by
+    := "INDEXED" "BY"? index-name+)
+
+(defrule picture-clause
+    := picture "IS"? picture-string
+    :reduce `(:picture ,picture-string))
+
+(defrule picture
+    := "PICTURE"
+    := "PIC")
+
+(defrule sign-clause
+    := sign-is? alt-leading-trailing separate-character?
+    :reduce `(:separate-sign ,separate-character :sign-position ,alt-leading-trailing))
+
+(defrule sign-is
+    := "SIGN" "IS"?)
+
+(defrule separate-character
+    := "SEPARATE" "CHARACTER"?
+    :reduce t)
+
+(defrule alt-leading-trailing
+    := "LEADING"
+    :reduce :leading
+    := "TRAILING"
+    :reduce :trailing)
+
+(defrule synchronized-clause
+    := synchronized alt-left-right?
+    :reduce `(:synchronized ,(if alt-left-right
+				 alt-left-right
+				 t)))
+
+(defrule alt-left-right
+    := "LEFT"
+    :reduce :left
+    := "RIGHT"
+    :reduce :right)
+
+(defrule synchronized
+    := "SYNCHRONIZED"
+    := "SYNC")
+
+(defrule usage-clause
+    := usage-is? usage
+    :reduce (list :encoding usage))
+
+(defrule usage-is
+    := "USAGE" "IS"?)
+
+(defrule usage
+    := "BINARY"
+    :reduce :binary
+    := "COMP"
+    :reduce :comp
+    := "COMP-1"
+    :reduce :comp1
+    := "COMP-2"
+    :reduce :comp2
+    := "COMP-3"
+    :reduce :comp3
+    := "COMP-4"
+    :reduce :comp4
+    := "COMPUTATIONAL"
+    :reduce :comp
+    := "COMPUTATIONAL-1"
+    :reduce :comp1
+    := "COMPUTATIONAL-2"
+    :reduce :comp2
+    := "COMPUTATIONAL-3"
+    :reduce :comp3
+    := "COMPUTATIONAL-4"
+    :reduce :comp4
+    := "DISPLAY"
+    :reduce :display
+    := "DISPLAY-1"
+    :reduce :display1
+    := "INDEX"
+    :reduce :index
+    := "PACKED-DECIMAL"
+    :reduce :packed-decimal
+    := "POINTER"
+    :reduce :pointer)
+
+(defrule renames-clause
+    := "RENAMES" qualified-data-name through-qualified-data-name?
+    :reduce `(:renames ,qualified-data-name ,through-qualified-data-name))
+
+(defrule through-qualified-data-name
+    := through qualified-data-name
+    :reduce qualified-data-name)
+
+(defrule condition-value-clause
+    := values-are literal-through-literal+)
+
+(defrule through-literal
+    := through literal)
+
+(defrule literal-through-literal
+    := literal through-literal?)
+
+(defrule values-are
+    := values are?)
+
+(defrule procedure-division-head
+    := "PROCEDURE" "DIVISION" using-phrase? ".")
+
+(defrule procedure-division
+    := procedure-division-head sentence+)
+
+(defrule using-phrase
+    := "USING" data-name+)
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(defrule declaratives
+    := "DECLARATIVES" "." declaratives-content+ "END" "DECLARATIVES" ".")
+
+(defrule declaratives-content
+    := cobol-identifier "SECTION" "." use-statement "." sentence*)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(defrule paragraph-header
+    := cobol-identifier "SECTION"?
+    :reduce (list (if $2 :section :label) $1))
+
+(defrule sentence
+    := declaratives
+    := statement* "."
+    :reduce $1
+    := paragraph-header "."
+    :reduce $1)
+
+(defrule statement
+    := move-statement
+    := if-statement
+    := perform-statement
+    := go-to-statement
+    := accept-statement
+    := add-statement
+    := alter-statement
+    := call-statement
+    := cancel-statement
+    := close-statement
+    := compute-statement
+    := continue-statement
+    := delete-statement
+    := display-statement
+    := divide-statement
+    := entry-statement
+    := evaluate-statement
+    := exit-program-statement
+    := exit-statement
+    := goback-statement
+    := initialize-statement
+    := inspect-statement
+    := merge-statement
+    := multiply-statement
+    := open-statement
+    := read-statement
+    := release-statement
+    := return-statement
+    := rewrite-statement
+    := search-statement
+    := set-statement
+    := sort-statement
+    := start-statement
+    := stop-statement
+    := string-statement
+    := subtract-statement
+    := unstring-statement
+    := write-statement
+    := paragraph-header)
+
+(defrule accept-statement
+    := "ACCEPT" variable-identifier "FROM" date
+    := "ACCEPT" variable-identifier "AT" screen-coordinates
+    :reduce (apply #'list 'accept-at variable-identifier screen-coordinates)
+    := "ACCEPT" variable-identifier from-environment-name?)
+
+(defrule from-environment-name
+    := "FROM" cobol-identifier)
+
+
+(defrule date
+    := "DATE"
+    := "DAY"
+    := "DAY-OF-WEEK"
+    := "TIME")
+
+(defrule add-statement
+    := "ADD" id-or-lit+ to-id-or-lit? "GIVING" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-ADD"?
+    := "ADD" id-or-lit+ "TO" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-ADD"?
+    := "ADD" corresponding variable-identifier "TO" variable-identifier "ROUNDED"? on-size-error-statement-list? not-on-size-error-statement-list? "END-ADD"?)
+
+(defrule statement-list
+    := statement+)
+
+(defrule alter-statement
+    := "ALTER" procedure-to-procedure+)
+
+(defrule proceed-to
+    := "PROCEED" "TO")
+
+(defrule procedure-to-procedure
+    := procedure-name "TO" proceed-to? procedure-name)
+
+(defrule call-statement
+    := "CALL" id-or-lit using-parameters? call-rest-phrase "END-CALL"?
+    :reduce (list 'call id-or-lit (cons 'list using-parameters)))
+
+(defrule by-reference
+    := "BY"? "REFERENCE")
+
+(defrule content-parameter-value
+    := cobol-identifier
+    := literal)
+
+(defrule reference-parameter
+    := by-reference? variable-identifier)
+
+(defrule content-parameter
+    := "BY"? "CONTENT" content-parameter-value+)
+
+(defrule parameter
+    := reference-parameter
+    := content-parameter
+    := literal)
+
+(defrule using-parameters
+    := "USING" parameter+)
+
+(defrule call-rest-phrase
+    := on-exception-statement-list? not-on-exception-statement-list? on-overflow-statement-list?)
+
+(defrule on-exception-statement-list
+    := "ON"? "EXCEPTION" statement-list)
+
+(defrule not-on-exception-statement-list
+    := "NOT" "ON"? "EXCEPTION" statement-list)
+
+(defrule cancel-statement
+    := "CANCEL" id-or-lit+)
+
+(defrule close-statement
+    := "CLOSE" close-statement-file-name+
+    :reduce (list 'close close-statement-file-name))
+
+(defrule alt-removal-no-rewind
+    := for-removal
+    := with-no-rewind)
+
+(defrule alt-reel-unit
+    := "REEL"
+    := "UNIT")
+
+(defrule alt-no-rewind-lock
+    := no-rewind
+    := "LOCK")
+
+(defrule close-statement-options-1
+    := alt-reel-unit alt-removal-no-rewind?)
+
+(defrule close-statement-options-2
+    := "WITH"? alt-no-rewind-lock)
+
+(defrule close-statement-options
+    := close-statement-options-1
+    := close-statement-options-2)
+
+(defrule close-statement-file-name
+    := file-name close-statement-options?)
+
+(defrule compute-statement
+    := "COMPUTE" cobword-rounded+ equal arithmetic-expression on-size-error-statement-list? not-on-size-error-statement-list? "END-COMPUTE"?
+    :reduce (list 'compute cobword-rounded arithmetic-expression :on-size-error on-size-error-statement-list
+		  :not-on-size-error not-on-size-error-statement-list))
+
+(defrule equal
+    := "="
+    := "EQUAL")
+
+(defrule continue-statement
+    := "CONTINUE")
+
+(defrule delete-statement
+    := "DELETE" file-name "RECORD"? invalid-key-statement-list? not-invalid-key-statement-list? "END-DELETE"?
+    :reduce (list 'delete file-name :invalid invalid-key-statement-list :not-invalid not-invalid-key-statement-list))
+
+(defrule display-statement
+    := "DISPLAY" id-or-lit+ upon-environment-name? with-no-advancing?
+    :reduce (list 'display (cons 'list id-or-lit) :upon upon-environment-name :advance (not with-no-advancing))
+    := "DISPLAY" id-or-lit "AT" screen-coordinates
+    :reduce (apply #'list 'display-at id-or-lit screen-coordinates))
+
+(defrule screen-coordinates
+    := integer
+    :reduce (multiple-value-list (truncate integer 100)))
+
+(defrule upon-environment-name
+    := "UPON" cobol-identifier)
+
+(defrule with-no-advancing
+    := "WITH"? "NO" "ADVANCING")
+
+(defrule divide-statement
+    := "DIVIDE" id-or-lit "INTO" id-or-lit "GIVING" variable-identifier "ROUNDED"? "REMAINDER" variable-identifier on-size-error-statement-list? not-on-size-error-statement-list? "END-DIVIDE"?
+    := "DIVIDE" id-or-lit "BY" id-or-lit "GIVING" variable-identifier "ROUNDED"? "REMAINDER" variable-identifier on-size-error-statement-list? not-on-size-error-statement-list? "END-DIVIDE"?
+    := "DIVIDE" id-or-lit "INTO" id-or-lit "GIVING" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-DIVIDE"?
+    := "DIVIDE" id-or-lit "BY" id-or-lit "GIVING" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-DIVIDE"?
+    := "DIVIDE" id-or-lit "INTO" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-DIVIDE"?)
+
+(defrule entry-statement
+    := "ENTRY" literal using-phrase?)
+
+(defrule evaluate-statement
+    := "EVALUATE" evaluate-condition also-phrase* when-phrases+ when-other-phrase? "END-EVALUATE"?)
+
+(defrule evaluate-condition
+    := condition
+    := "TRUE"
+    := "FALSE")
+
+(defrule also-phrase
+    := "ALSO" evaluate-condition)
+
+(defrule when-phrase-also-phrase
+    := "ALSO" evaluate-phrase)
+
+(defrule when-phrase
+    := "WHEN" evaluate-phrase when-phrase-also-phrase*)
+
+(defrule when-phrases
+    := when-phrase+ statement-list)
+
+(defrule when-other-phrase
+    := "WHEN" "OTHER" statement-list)
+
+(defrule evaluate-phrase
+    := "ANY"
+    := condition
+    := "TRUE"
+    := "FALSE"
+    := evaluate-phrase-1)
+
+(defrule evaluate-phrase-1
+    := "NOT"? arithmetic-expression through-arithmetic-expression?)
+
+(defrule through-arithmetic-expression
+    := through arithmetic-expression)
+
+(defrule exit-statement
+    := "EXIT"
+    :reduce '(exit-paragraph))
+
+(defrule exit-program-statement
+    := "EXIT" "PROGRAM"
+    :reduce '(exit-program))
+
+(defrule goback-statement
+    := "GOBACK"
+    :reduce '(go-back))
+
+(defrule go-to-statement
+    := "GO" "TO"? procedure-name+ "DEPENDING" "ON"? variable-identifier
+    :reduce (list 'goto-depending variable-identifier procedure-name)
+    := "GO" "TO"? procedure-name
+    :reduce (list 'goto procedure-name))
+
+(defrule if-phrase
+    := "IF" condition "THEN"? alt-statement-list-next-sentence "ELSE" alt-statement-list-next-sentence
+    :reduce (list 'if condition
+		  (if (cdr alt-statement-list-next-sentence)
+		      (cons 'progn alt-statement-list-next-sentence)
+		      (car alt-statement-list-next-sentence))
+		  (if (cdr alt-statement-list-next-sentence2)
+		      (cons 'progn alt-statement-list-next-sentence2)
+		      (car alt-statement-list-next-sentence2)))
+    := "IF" condition "THEN"? alt-statement-list-next-sentence
+    :reduce (append (list 'when condition) alt-statement-list-next-sentence))
+
+(defrule if-statement
+    := if-phrase "END-IF"?
+    :reduce $1)
+
+(defrule initialize-statement
+    := "INITIALIZE" variable-identifier+ initialize-replacing-phrase?)
+
+(defrule initialize-replacing-type
+    := "ALPHABETIC"
+    := "ALPHANUMERIC"
+    := "NUMERIC"
+    := "ALPHANUMERIC-EDITED"
+    := "NUMERIC-EDITED"
+    := "DBCS"
+    := "EGCS")
+
+(defrule initialize-replacing-argument
+    := initialize-replacing-type "DATA"? "BY" id-or-lit)
+
+(defrule initialize-replacing-phrase
+    := "REPLACING" initialize-replacing-argument+)
+
+(defrule inspect-statement
+    := inspect-statement-1
+    := inspect-statement-2
+    := inspect-statement-3
+    := inspect-statement-4)
+
+(defrule inspect-statement-1
+    := "INSPECT" variable-identifier "TALLYING" tallying-argument+)
+
+(defrule inspect-statement-2
+    := "INSPECT" variable-identifier "CONVERTING" id-or-lit "TO" id-or-lit before-after-phrase*)
+
+(defrule inspect-statement-3
+    := "INSPECT" variable-identifier "TALLYING" tallying-argument+ "REPLACING" inspect-replacing-phrase+)
+
+(defrule tallying-for-id-or-lit
+    := id-or-lit before-after-phrase*)
+
+(defrule alt-all-leading
+    := "ALL"
+    := "LEADING")
+
+(defrule tallying-for-argument-1
+    := "CHARACTERS" before-after-phrase*)
+
+(defrule tallying-for-argument-2
+    := alt-all-leading tallying-for-id-or-lit+)
+
+(defrule tallying-for-argument
+    := tallying-for-argument-1
+    := tallying-for-argument-2)
+
+(defrule tallying-argument
+    := variable-identifier "FOR" tallying-for-argument+)
+
+(defrule inspect-statement-4
+    := "INSPECT" variable-identifier "REPLACING" inspect-replacing-phrase+)
+
+(defrule inspect-replacing-argument
+    := inspect-by-argument "BY" inspect-by-argument before-after-phrase*)
+
+(defrule alt-all-leading-first
+    := "ALL"
+    := "LEADING"
+    := "FIRST")
+
+(defrule inspect-replacing-phrase-1
+    := "CHARACTERS" "BY" id-or-lit before-after-phrase*)
+
+(defrule inspect-replacing-phrase-2
+    := alt-all-leading-first inspect-replacing-argument+)
+
+(defrule inspect-replacing-phrase
+    := inspect-replacing-phrase-1
+    := inspect-replacing-phrase-2)
+
+(defrule before-after-phrase
+    := alt-before-after "INITIAL"? id-or-lit)
+
+(defrule merge-statement
+    := "MERGE" file-name on-key-phrase+ collating-sequence? "USING" file-name file-name+ merge-statement-tail)
+
+(defrule on-key-phrase
+    := "ON"? alt-ascending-descending "KEY"? qualified-data-name+)
+
+(defrule merge-statement-tail
+    := output-procedure
+    := giving-file-names)
+
+(defrule move-statement
+    := "MOVE" id-or-lit "TO" variable-identifier+
+    :reduce (apply #'list 'move id-or-lit variable-identifier)
+    := "MOVE" corresponding variable-identifier "TO" variable-identifier+
+    :reduce (apply #'list 'move-corresponding variable-identifier variable-identifier2))
+
+(defrule multiply-statement
+    := "MULTIPLY" id-or-lit "BY" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-MULTIPLY"?
+    :reduce (list 'multiply id-or-lit cobword-rounded :on-size-error on-size-error-statement-list
+		  :not-on-size-error not-on-size-error-statement-list)
+    := "MULTIPLY" id-or-lit "BY" id-or-lit "GIVING" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-MULTIPLY"?
+    :reduce (list 'multiply id-or-lit id-or-lit2 :giving cobword-rounded
+		  :on-size-error on-size-error-statement-list
+		  :not-on-size-error not-on-size-error-statement-list))
+
+(defrule open-statement
+    := "OPEN" open-statement-phrase+
+    :reduce (list 'open open-statement-phrase))
+
+(defrule alt-reversed-with-no-rewind
+    := "REVERSED"
+    := with-no-rewind)
+
+(defrule open-statement-input-file-name
+    := file-name alt-reversed-with-no-rewind?)
+
+(defrule with-no-rewind
+    := "WITH"? "NO" "REWIND")
+
+(defrule open-statement-output-file-name
+    := file-name with-no-rewind?)
+
+(defrule open-statement-input
+    := "INPUT" open-statement-input-file-name+)
+
+(defrule open-statement-output
+    := "OUTPUT" open-statement-output-file-name+)
+
+(defrule open-statement-i-o
+    := "I-O" file-name+)
+
+(defrule open-statement-extend
+    := "EXTEND" file-name+)
+
+(defrule open-statement-phrase
+    := open-statement-input
+    := open-statement-output
+    := open-statement-i-o
+    := open-statement-extend)
+
+(defrule perform-statement
+    := "PERFORM" procedure-name through-procedure-name? perform-until-phrase
+    :reduce `(perform-until ,procedure-name ,through-procedure-name ,perform-until-phrase)
+    := "PERFORM" procedure-name through-procedure-name? perform-varying-phrase perform-after-phrase*
+    :reduce `(perform-varying ,perform-varying-phrase ,procedure-name ,through-procedure-name ,perform-after-phrase)
+    := "PERFORM" procedure-name through-procedure-name? cobword-int "TIMES"
+    :reduce `(perform-times ,cobword-int ,procedure-name ,through-procedure-name)
+    := "PERFORM" procedure-name through-procedure-name?
+    :reduce (append (list 'perform procedure-name) through-procedure-name))
+
+(defrule perform-varying-phrase
+    := with-test? "VARYING" variable-identifier "FROM" id-or-lit "BY" id-or-lit "UNTIL" condition)
+
+(defrule perform-after-phrase
+    := "AFTER" variable-identifier "FROM" id-or-lit "BY" id-or-lit "UNTIL" condition)
+
+(defrule perform-until-phrase
+    := with-test? "UNTIL" condition)
+
+(defrule with-test
+    := "WITH"? "TEST" alt-before-after
+    :reduce alt-before-after)
+
+(defrule read-statement
+    := "READ" file-name "NEXT"? "RECORD"? into-identifier? key-is-qualified-data-name? invalid-key-statement-list? not-invalid-key-statement-list? at-end-statement-list? not-at-end-statement-list? "END-READ"?)
+
+(defrule key-is-qualified-data-name
+    := "KEY" "IS"? qualified-data-name)
+
+(defrule release-statement
+    := "RELEASE" record-name from-identifier?)
+
+(defrule return-statement
+    := "RETURN" file-name "RECORD"? into-identifier? "AT"? "END" statement-list not-at-end-statement-list? "END-RETURN"?)
+
+(defrule into-identifier
+    := "INTO" variable-identifier)
+
+(defrule not-at-end-statement-list
+    := "NOT" "AT"? "END" statement-list)
+
+(defrule rewrite-statement
+    := "REWRITE" record-name from-identifier? invalid-key-statement-list? not-invalid-key-statement-list? "END-REWRITE"?)
+
+(defrule search-statement
+    := search-statement-1
+    := search-statement-2)
+
+(defrule search-statement-1
+    := "SEARCH" cobol-identifier varying-identifier? at-end-statement-list? when-condition-stats+ "END-SEARCH"?)
+
+(defrule varying-identifier
+    := "VARYING" variable-identifier)
+
+(defrule when-condition-stats
+    := "WHEN" condition alt-statement-list-next-sentence)
+
+(defrule search-statement-2
+    := "SEARCH" "ALL" variable-identifier at-end-statement-list? "WHEN" search-statement-condition search-statement-condition-tail* alt-statement-list-next-sentence "END-SEARCH"?)
+
+(defrule at-end-statement-list
+    := "AT"? "END" statement-list)
+
+(defrule search-statement-equal-expression
+    := variable-identifier "IS"? equal-to arithmetic-expression
+    :reduce (list '= variable-identifier arithmetic-expression))
+
+(defrule search-statement-condition
+    := search-statement-equal-expression
+    := condition-name-reference)
+
+(defrule search-statement-condition-tail
+    := "AND" search-statement-condition)
+
+(defrule alt-statement-list-next-sentence
+    := statement+
+    := next-sentence
+    :reduce :next-sentence)
+
+(defrule set-statement
+    := "SET" set-statement-phrase+)
+
+(defrule sort-statement
+    := "SORT" file-name on-key-is-phrase+ with-duplicates-in-order? collating-sequence? sort-statement-in sort-statement-out)
+
+(defrule key-is
+    := "KEY" "IS"?)
+
+(defrule alt-ascending-descending
+    := "ASCENDING"
+    := "DESCENDING")
+
+(defrule on-key-is-phrase
+    := "ON"? alt-ascending-descending key-is? qualified-data-name+)
+
+(defrule with-duplicates-in-order
+    := "WITH"? "DUPLICATES" "IN"? "ORDER"?)
+
+(defrule collating-sequence
+    := "COLLATING"? "SEQUENCE" "IS"? alphabet-name)
+
+(defrule through
+    := "THROUGH"
+    := "THRU")
+
+(defrule through-procedure-name
+    := through procedure-name
+    :reduce procedure-name)
+
+(defrule using-file-names
+    := "USING" file-name+)
+
+(defrule input-procedure
+    := "INPUT" "PROCEDURE" "IS"? procedure-name through-procedure-name?)
+
+(defrule giving-file-names
+    := "GIVING" file-name+)
+
+(defrule output-procedure
+    := "OUTPUT" "PROCEDURE" "IS"? procedure-name through-procedure-name?)
+
+(defrule sort-statement-in
+    := using-file-names
+    := input-procedure)
+
+(defrule sort-statement-out
+    := giving-file-names
+    := output-procedure)
+
+(defrule start-statement
+    := "START" file-name key-is-rel-op-qualified-data-name? invalid-key-statement-list? not-invalid-key-statement-list? "END-START"?)
+
+(defrule rel-op
+    := equal-to
+    :reduce '=
+    := greater-than
+    :reduce '>
+    := greater-equal
+    :reduce '>=)
+
+(defrule key-is-rel-op-qualified-data-name
+    := "KEY" "IS"? rel-op qualified-data-name
+    :reduce (list rel-op qualified-data-name))
+
+(defrule stop-statement
+    := "STOP" alt-run-literal
+    :reduce '(stop))
+
+(defrule alt-run-literal
+    := "RUN"
+    := literal)
+
+(defrule string-statement
+    := "STRING" delimited-by-phrase+ "INTO" variable-identifier with-pointer-identifier? on-overflow-statement-list? not-on-overflow-statement-list? "END-STRING"?
+    :reduce (list 'string-concat delimited-by-phrase variable-identifier :with-pointer with-pointer-identifier :on-overflow on-overflow-statement-list :not-on-overflow not-on-overflow-statement-list))
+
+(defrule id-or-lit-size
+    := literal
+    := variable-identifier
+    := "SIZE")
+
+(defrule delimited-by-phrase
+    := id-or-lit+ "DELIMITED" "BY"? id-or-lit-size
+    :reduce (list id-or-lit id-or-lit-size))
+
+(defrule subtract-statement
+    := "SUBTRACT" id-or-lit+ "FROM" id-or-lit "GIVING" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-SUBTRACT"?
+    :reduce (list 'subtract-giving id-or-lit id-or-lit2 cobword-rounded
+		  :on-size-error on-size-error-statement-list
+		  :not-on-size-error not-on-size-error-statement-list)
+    := "SUBTRACT" id-or-lit+ "FROM" cobword-rounded+ on-size-error-statement-list? not-on-size-error-statement-list? "END-SUBTRACT"?
+    :reduce (list 'subtract id-or-lit cobword-rounded
+		  :on-size-error on-size-error-statement-list
+		  :not-on-size-error not-on-size-error-statement-list)
+    := "SUBTRACT" corresponding variable-identifier "FROM" variable-identifier "ROUNDED"? on-size-error-statement-list? not-on-size-error-statement-list? "END-SUBTRACT"?
+    :reduce (list 'subtract-corr variable-identifier variable-identifier
+		  :rounded (and $5 t)
+		  :on-size-error on-size-error-statement-list
+		  :not-on-size-error not-on-size-error-statement-list))
+
+(defrule cobword-rounded
+    := variable-identifier "ROUNDED"?
+    :reduce (list variable-identifier (and $2 t)))
+
+(defrule on-size-error-statement-list
+    := "ON"? "SIZE" "ERROR" statement-list
+    :reduce statement-list)
+
+(defrule not-on-size-error-statement-list
+    := "NOT" "ON"? "SIZE" "ERROR" statement-list
+    :reduce statement-list)
+
+(defrule corresponding
+    := "CORRESPONDING"
+    := "CORR")
+
+(defrule unstring-statement
+    := "UNSTRING" variable-identifier delimited-by-all-phrase? "INTO" unstring-statement-dst+ with-pointer-identifier? tallying-in-identifier? on-overflow-statement-list? not-on-overflow-statement-list? "END-UNSTRING"?
+    :reduce (list 'unstring variable-identifier unstring-statement-dst
+		  :delimited-by-all delimited-by-all-phrase
+		  :with-pointer with-pointer-identifier
+		  :tallying tallying-in-identifier
+		  :on-overflow on-overflow-statement-list
+		  :not-on-overflow not-on-overflow-statement-list))
+
+(defrule id-or-lit
+    := literal
+    := variable-identifier)
+
+(defrule or-all-id-or-lit
+    := "OR" "ALL"? id-or-lit)
+
+(defrule delimited-by-all-phrase
+    := "DELIMITED" "BY"? "ALL"? id-or-lit or-all-id-or-lit*)
+
+(defrule delimiter-in-identifier
+    := "DELIMITER" "IN"? variable-identifier)
+
+(defrule count-in-identifier
+    := "COUNT" "IN"? variable-identifier)
+
+(defrule unstring-statement-dst
+    := variable-identifier delimiter-in-identifier? count-in-identifier?)
+
+(defrule with-pointer-identifier
+    := "WITH"? "POINTER" variable-identifier)
+
+(defrule tallying-in-identifier
+    := "TALLYING" "IN"? variable-identifier)
+
+(defrule on-overflow-statement-list
+    := "ON"? "OVERFLOW" statement-list)
+
+(defrule not-on-overflow-statement-list
+    := "NOT" "ON"? "OVERFLOW" statement-list)
+
+(defrule write-statement
+    := "WRITE" record-name from-identifier? advancing-phrase? write-exceptions "END-WRITE"?)
+
+(defrule lines
+    := "LINE"
+    := "LINES")
+
+(defrule cobword-int
+    := cobol-identifier
+    := integer)
+
+(defrule nr-lines-phrase
+    := cobword-int lines?)
+
+(defrule page-phrase
+    := nr-lines-phrase
+    := "PAGE")
+
+(defrule alt-before-after
+    := "BEFORE"
+    := "AFTER")
+
+(defrule advancing-phrase
+    := alt-before-after "ADVANCING"? page-phrase)
+
+(defrule from-identifier
+    := "FROM" variable-identifier)
+
+(defrule invalid-key-statement-list
+    := "INVALID" "KEY"? statement-list
+    :reduce statement-list)
+
+(defrule not-invalid-key-statement-list
+    := "NOT" "INVALID" "KEY"? statement-list
+    :reduce statement-list)
+
+(defrule end-of-page
+    := "END-OF-PAGE"
+    := "EOP")
+
+(defrule at-end-of-page-statement-list
+    := "AT"? end-of-page statement-list
+    :reduce statement-list)
+
+(defrule not-at-end-of-page-statement-list
+    := "NOT" "AT"? end-of-page statement-list
+    :reduce statement-list)
+
+;; This is left in the grammar but is not used.  COPYs are handled by
+;; the lexical scanner.
+(defrule copy-statement
+    := "COPY" alt-text-name-literal in-library? "SUPPRESS"? copy-statement-replacing-phrase?)
+
+(defrule in
+    := "OF"
+    := "IN")
+
+(defrule alt-library-name-literal
+    := library-name
+    := literal)
+
+(defrule in-library
+    := in alt-library-name-literal)
+
+(defrule copy-statement-by-phrase
+    := copy-operand "BY" copy-operand)
+
+(defrule copy-statement-replacing-phrase
+    := "REPLACING" copy-statement-by-phrase+)
+
+(defrule alt-text-name-literal
+    := text-name
+    := literal)
+
+(defrule copy-operand
+    := cobol-identifier
+    := literal)
+
+(defrule use-statement
+    := use-statement-1
+    := use-statement-2
+    := use-statement-3)
+
+(defrule use-statement-1
+    := "USE" "GLOBAL"? "AFTER" "STANDARD"? alt-exception-error "PROCEDURE" "ON"? alt-file-names-i-o)
+
+(defrule alt-exception-error
+    := "EXCEPTION"
+    := "ERROR")
+
+(defrule use-statement-2
+    := "USE" "GLOBAL"? "AFTER" "STANDARD"? alt-beginning-ending? alt-file-reel-unit? "LABEL" "PROCEDURE" "ON"? alt-file-names-i-o)
+
+(defrule alt-beginning-ending
+    := "BEGINNING"
+    := "ENDING")
+
+(defrule alt-file-reel-unit
+    := "FILE"
+    := "REEL"
+    := "UNIT")
+
+(defrule file-names
+    := file-name+)
+
+(defrule alt-file-names-i-o
+    := file-names
+    := "INPUT"
+    := "OUTPUT"
+    := "I-O"
+    := "EXTEND")
+
+(defrule use-statement-3
+    := "USE" "FOR"? "DEBUGGING" "ON"? alt-procedures-all-procedures)
+
+(defrule procedure-names
+    := procedure-name+)
+
+(defrule alt-procedures-all-procedures
+    := procedure-names
+    := all-procedures)
+
+(defrule condition
+    := combinable-condition
+    := combinable-condition "AND" condition
+    :reduce `(and ,combinable-condition ,condition)
+    := combinable-condition "OR" condition
+    :reduce `(or ,combinable-condition ,condition)
+    := combinable-condition "AND" id-or-lit
+    :reduce `(and ,combinable-condition (,(car combinable-condition) ,(cadr combinable-condition) ,id-or-lit))
+    := combinable-condition "OR" id-or-lit
+    :reduce `(or ,combinable-condition (,(car combinable-condition) ,(cadr combinable-condition) ,id-or-lit)))
+
+(defrule combinable-condition
+    := "NOT"? simple-condition
+    :reduce (if $1
+		(list 'not simple-condition)
+		simple-condition))
+
+(defrule simple-condition
+    := class-condition
+    := relation-condition
+    := sign-condition
+    := "(" condition ")"
+    ;; not sure if it's necessary -wcp15/7/03.
+    ;; := arithmetic-expression
+    )
+
+(defrule class-condition
+    := variable-identifier "IS"? "NOT"? class-type
+    :reduce (if $3
+		(list 'not (list 'type-of variable-identifier (make-keyword class-type)))
+		(list 'type-of variable-identifier (make-keyword class-type))))
+
+(defrule class-type
+    := "NUMERIC"
+    := "ALPHABETIC"
+    := "ALPHABETIC-LOWER"
+    := "ALPHABETIC-UPPER"
+    := "DBCS")
+
+(defun unfold-subrelations (main-relation subs)
+  (destructuring-bind (main-operator main-variable other-variable) main-relation
+    (declare (ignore other-variable))
+    (labels ((unfold (subs)
+	       (if (null subs)
+		   main-relation
+		   (destructuring-bind (connection operator variable) (car subs)
+		     (list connection
+			   (list (or operator main-operator) main-variable variable)
+			   (unfold (cdr subs)))))))
+      (unfold subs))))
+
+(defrule relation-condition
+    ;; This is too complex
+    ;; := arithmetic-expression relational-operator simple-condition
+    := id-or-lit relational-operator id-or-lit subordinate-relation*
+    :reduce (unfold-subrelations (list relational-operator id-or-lit id-or-lit2) subordinate-relation))
+
+(defrule or-and
+    := "OR" :reduce 'or
+    := "AND" :reduce 'and)
+
+(defrule subordinate-relation
+    := or-and relational-operator? id-or-lit
+    :reduce (list or-and relational-operator id-or-lit))
+
+(defrule relational-operator
+    := "IS"? relational-operator-type
+    :reduce relational-operator-type)
+
+(defrule less-than
+    := "LESS" "THAN"?
+    := "<")
+
+(defrule greater-equal
+    := "GREATER" "THAN"? "OR" "EQUAL" "TO"?
+    := ">="
+    := ">" "="
+    := "NOT" "<"
+    := "NOT" "LESS" "THAN"?)
+
+(defrule less-equal
+    := "LESS" "THAN"? "OR" "EQUAL" "TO"?
+    := "<="
+    := "<" "="
+    := "NOT" ">"
+    := "NOT" "GREATER" "THAN"?)
+
+(defrule greater-than
+    := "GREATER" "THAN"?
+    := ">")
+
+(defrule equal-to
+    := "EQUAL" "TO"?
+    := "=")
+
+(defrule relational-operator-type
+    := greater-equal
+    :reduce 'cob>=
+    := less-equal
+    :reduce 'cob<=
+    := greater-than
+    :reduce 'cob>
+    := less-than
+    :reduce 'cob<
+    := equal-to
+    :reduce 'cob=
+    := "NOT" equal-to
+    :reduce 'cob-not=)
+
+(defrule sign-condition
+    := arithmetic-expression "IS"? "NOT"? sign-type
+    :reduce (if $3
+		`(not (,sign-type ,arithmetic-expression))
+		`(,sign-type ,arithmetic-expression)))
+
+(defrule sign-type
+    := "POSITIVE" :reduce '>
+    := "NEGATIVE" :reduce '<
+    := "ZERO" :reduce '=
+    := "ZEROES" :reduce '=
+    := "ZEROS" :reduce '=)
+
+(defrule procedure-name
+    := paragraph-or-section-name in-section-name
+    :reduce (list paragraph-or-section-name in-section-name)
+    := paragraph-or-section-name
+    :reduce paragraph-or-section-name)
+
+(defrule in-section-name
+    := in cobol-identifier
+    :reduce cobol-identifier)
+
+(defrule variable-identifier
+    := qualified-data-name subscript-parentheses* ;; reference-modification?
+    :reduce (if subscript-parentheses
+		(list :aref qualified-data-name subscript-parentheses)
+		qualified-data-name))
+
+(defrule reference-modification
+    := "(" leftmost-character-position ":" length? ")"
+    :reduce (if length
+		(list :range leftmost-character-position length)
+		leftmost-character-position))
+
+(defrule condition-name-reference
+    := condition-name in-data-or-file-or-mnemonic-name* subscript-parentheses*)
+
+(defrule in-data-or-file-or-mnemonic-name
+    := in data-or-file-or-mnemonic-name)
+
+(defrule subscript-parentheses
+    := "(" subscript ")")
+
+(defrule subscript
+    := subscript-expression+)
+
+(defrule plus-minus-integer
+    := plus-or-minus integer)
+
+(defrule subscript-expression-ambiguous
+    := qualified-data-name plus-minus-integer?)
+
+(defrule subscript-expression
+    := literal
+    := subscript-expression-ambiguous)
+
+(defrule qualified-data-name
+    := data-name in-data-or-file-name*
+    :reduce (if in-data-or-file-name
+		(list data-name in-data-or-file-name) ; incomplete -wcp15/7/03.
+		data-name)
+    := "ADDRESS" "OF" data-name
+    :reduce (list 'address-of data-name)
+    := "LENGTH" "OF" cobol-identifier
+    :reduce (list 'length-of cobol-identifier))
+
+(defrule in-data-or-file-name
+    := in data-or-file-name)
+
+(defrule leftmost-character-position
+    := arithmetic-expression)
+
+(defrule length
+    := arithmetic-expression)
+
+(defrule arithmetic-expression
+    := times-div
+    := times-div "+" arithmetic-expression
+    :reduce `(+ ,times-div ,arithmetic-expression)
+    := times-div "-" arithmetic-expression
+    :reduce `(- ,times-div ,arithmetic-expression))
+
+(defrule times-div
+    := power
+    := power "*" times-div
+    :reduce `(* ,power ,times-div)
+    := power "/" times-div
+    :reduce `(/ ,power ,times-div))
+
+(defrule power
+    := plus-or-minus? basis
+    := plus-or-minus? basis "**" power
+    :reduce (if plus-or-minus
+		`(plus-or-minus (expt basis basis2))
+		`(expt basis basis2)))
+
+(defrule plus-or-minus
+    := "+"
+    :reduce '+
+    := "-"
+    :reduce '-)
+
+;; (defrule power-tail
+;;     := "**" basis)
+
+(defrule basis
+    := literal
+    := variable-identifier
+    := "(" arithmetic-expression ")")
+
+(defrule alphabet-name
+    := cobol-identifier)
+
+(defrule condition-name
+    := cobol-identifier)
+
+(defrule data-name
+    := cobol-identifier)
+
+(defrule cobol-identifier
+    := identifier
+    :reduce (intern (string-upcase identifier)))
+
+(defrule file-name
+    := cobol-identifier)
+
+(defrule data-or-file-name
+    := cobol-identifier)
+
+(defrule index-name
+    := cobol-identifier)
+
+(defrule mnemonic-name
+    := cobol-identifier)
+
+(defrule data-or-file-or-mnemonic-name
+    := cobol-identifier)
+
+(defrule record-name
+    := qualified-data-name)
+
+(defrule symbolic-character
+    := cobol-identifier)
+
+(defrule library-name
+    := cobol-identifier)
+
+(defrule program-name
+    := cobol-identifier
+    := string)
+
+(defrule text-name
+    := cobol-identifier)
+
+(defrule paragraph-or-section-name
+    := cobol-identifier
+    := integer)
+
+(defrule computer-name
+    := identifier)
+
+(defrule environment-name
+    := cobol-identifier)
+
+(defrule assignment-name
+    := cobol-identifier)
+
+(defrule figurative-constant
+    := figurative-constant-simple
+    := figurative-constant-all)
+
+(defrule figurative-constant-all
+    := "ALL" literal)
+
+(defrule literal
+    := string
+    := float
+    := integer
+    := figurative-constant)
+
+)					; defun populate-grammar
diff --git a/third_party/lisp/npg/npg.asd b/third_party/lisp/npg/npg.asd
new file mode 100644
index 000000000000..addb7c6932af
--- /dev/null
+++ b/third_party/lisp/npg/npg.asd
@@ -0,0 +1,55 @@
+;;;  npg.asd --- declaration of this system
+
+;;;  Copyright (C) 2003, 2006 by Walter C. Pelissero
+
+;;;  Author: Walter C. Pelissero <walter@pelissero.de>
+;;;  Project: NPG a Naive Parser Generator
+
+#+cmu (ext:file-comment "$Module: npg.asd, Time-stamp: <2006-01-03 17:20:21 wcp> $")
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public License
+;;; as published by the Free Software Foundation; either version 2.1
+;;; of the License, or (at your option) any later version.
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free
+;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+;;; 02111-1307 USA
+
+(defpackage :npg-system
+  (:use :common-lisp :asdf))
+
+(in-package :npg-system)
+
+(defclass sample-file (doc-file) ())
+(defmethod source-file-type ((c sample-file) (s module))
+  "lisp")
+
+(defsystem npg
+  :name "NPG"
+  :author "Walter C. Pelissero <walter@pelissero.de>"
+  :maintainer "Walter C. Pelissero <walter@pelissero.de>"
+  :licence "Lesser General Public License"
+  :description "NPG a Naive Parser Generator"
+  :long-description
+  "NPG is a backtracking recursive descent parser generator for
+Common Lisp. It accepts rules in a Lispy EBNF syntax without indirect
+left recursive rules."
+  :components
+  ((:doc-file "README")
+   (:doc-file "COPYING")
+   (:doc-file ".project")
+   (:module :examples
+	    :components
+	    ((:sample-file "python")
+	     (:sample-file "vs-cobol-ii")))
+   (:module :src
+	    :components
+	    ((:file "package")
+	     (:file "common" :depends-on ("package"))
+	     (:file "define" :depends-on ("package" "common"))
+	     (:file "parser" :depends-on ("package" "common"))))))
diff --git a/third_party/lisp/npg/src/common.lisp b/third_party/lisp/npg/src/common.lisp
new file mode 100644
index 000000000000..8b64f5cc0a7b
--- /dev/null
+++ b/third_party/lisp/npg/src/common.lisp
@@ -0,0 +1,79 @@
+;;;  common.lisp --- common stuff
+
+;;;  Copyright (C) 2003-2006, 2009 by Walter C. Pelissero
+
+;;;  Author: Walter C. Pelissero <walter@pelissero.de>
+;;;  Project: NPG a Naive Parser Generator
+
+#+cmu (ext:file-comment "$Module: common.lisp $")
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public License
+;;; as published by the Free Software Foundation; either version 2.1
+;;; of the License, or (at your option) any later version.
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free
+;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+;;; 02111-1307 USA
+
+(in-package :naive-parser-generator)
+
+(eval-when (:compile-toplevel :load-toplevel)
+  (defstruct grammar
+    rules
+    keywords
+    equal-p)
+
+  (defstruct rule
+    name
+    productions)
+
+  (defstruct (production (:conc-name prod-))
+    tokens
+    (tokens-length 0 :type fixnum)
+    action)
+
+  (defstruct token
+    type		     ; type of token (identifier, number, ...)
+    value				; its actual value
+    position)			     ; line/column in the input stream
+  ) ; eval-when
+
+(defmethod print-object ((obj rule) stream)
+  (format stream "#R(~A)" (rule-name obj)))
+
+(defmethod print-object ((obj production) stream)
+  (format stream "#P(action: ~S)" (prod-action obj)))
+
+(defmethod print-object ((obj token) stream)
+  (format stream "#T:~A=~S" (token-type obj) (token-value obj)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(declaim (inline make-rules-table find-rule add-rule))
+
+(defun make-rules-table ()
+  (make-hash-table))
+
+(defun find-rule (rule-name rules)
+  (gethash rule-name rules))
+
+(defun add-rule (rule-name rule rules)
+  (setf (gethash rule-name rules) rule))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(declaim (inline make-keywords-table find-keyword add-keyword))
+
+(defun make-keywords-table ()
+   (make-hash-table :test 'equal))
+
+(defun find-keyword (keyword-name keywords)
+  (gethash keyword-name keywords))
+
+(defun add-keyword (keyword keywords)
+  (setf (gethash keyword keywords) t))
diff --git a/third_party/lisp/npg/src/define.lisp b/third_party/lisp/npg/src/define.lisp
new file mode 100644
index 000000000000..f52f0381a2de
--- /dev/null
+++ b/third_party/lisp/npg/src/define.lisp
@@ -0,0 +1,408 @@
+;;;  define.lisp --- grammar rules definition
+
+;;;  Copyright (C) 2003-2006, 2009 by Walter C. Pelissero
+
+;;;  Author: Walter C. Pelissero <walter@pelissero.de>
+;;;  Project: NPG a Naive Parser Generator
+
+#+cmu (ext:file-comment "$Module: define.lisp $")
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public License
+;;; as published by the Free Software Foundation; either version 2.1
+;;; of the License, or (at your option) any later version.
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free
+;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+;;; 02111-1307 USA
+
+(in-package :naive-parser-generator)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defvar *smart-default-reduction* t
+  "If true the default reductions take only the non-static tokens -
+those that are not declared as strings in the grammar.")
+
+;; These two are filled with DEFRULE.
+(defvar *rules* (make-rules-table))
+(defvar *keywords* (make-keywords-table))
+
+(defun make-action-arguments (tokens)
+  "Given a list of tokens making up a production, return three values:
+the list of variables for the function reducing this production, those
+that are non static and their unambiguous user-friendly names."
+  (flet ((unique (sym list)
+	   (if (not (assoc sym list))
+	       sym
+	       (loop
+		  for i of-type fixnum from 2
+		  for x = (intern (format nil "~:@(~A~)~A" sym i))
+		  while (assoc x list)
+		  finally (return x)))))
+    (loop
+       for tok in tokens
+       for i of-type fixnum from 1
+       for arg = (intern (format nil "$~A" i) (find-package #.*package*))
+       collect arg into args
+       unless (const-terminal-p tok)
+         collect arg into vars
+         and when (symbolp tok)
+           collect (list (unique tok named-vars) arg) into named-vars
+       when (and (listp tok)
+		 (symbolp (cadr tok)))
+	 collect (list (unique (cadr tok) named-vars) arg) into named-vars
+       finally
+       (return (values args vars named-vars)))))
+
+(defun make-action-function (name tokens action)
+  "Create a function with name NAME, arguments derived from TOKENS and
+body ACTION.  Return it's definition."
+  (let ((function
+	 (multiple-value-bind (args vars named-vars)
+	     (make-action-arguments tokens)
+	   `(lambda ,args
+	      (declare (ignorable ,@args))
+	      (let (($vars (list ,@vars))
+		    ($all (list ,@args))
+		    ,@named-vars
+		    ($alist (list ,@(mapcar #'(lambda (v)
+						`(cons ',(intern (symbol-name (car v)))
+						       ,(cadr v)))
+					    named-vars))))
+		(declare (ignorable $vars $all $alist ,@(mapcar #'car named-vars)))
+		(flet ((make-object (&optional type args)
+			 (apply #'make-instance (or type ',name)
+				(append args $alist))))
+		  ,action))))))
+    (when *compile-print*
+      (if *compile-verbose*
+	  (format t "; Compiling ~S:~%  ~S~%" name function)
+	  (format t "; Compiling ~S~%" name)))
+    (compile name function)))
+
+(defun define-rule (name productions)
+  "Accept a rule in EBNF-like syntax, translate it into a sexp and a
+call to INSERT-RULE-IN-CURRENT-GRAMMAR."
+  (flet ((transform (productions)
+	   (loop
+	      for tok in productions
+	      with prod = nil
+	      with action = nil
+	      with phase = nil
+	      with new-prods = nil
+	      while tok
+	      do (cond ((eq tok :=)
+			(push (list (nreverse prod) action) new-prods)
+			(setf prod nil
+			      action nil
+			      phase :prod))
+		       ((eq tok :reduce)
+			(setf phase :action))
+		       ((eq tok :tag)
+			(setf phase :tag))
+		       ((eq phase :tag)
+			(setf action `(cons ,tok $vars)))
+		       ((eq phase :action)
+			(setf action tok))
+		       ((eq phase :prod)
+			(push tok prod)))
+	      finally
+		(return (cdr (nreverse (cons (list (nreverse prod) action) new-prods)))))))
+    (insert-rule-in-current-grammar name (transform productions))))
+
+(defmacro defrule (name &rest productions)
+  "Wrapper macro for DEFINE-RULE."
+  `(define-rule ',name ',productions))
+
+(defun make-optional-rule (token)
+  "Make a rule for a possibly missing (non)terminal (? syntax) and
+return it."
+  (insert-rule-in-current-grammar
+   (gensym (concatenate 'string "OPT-"
+			(if (rule-p token)
+			    (symbol-name (rule-name token))
+			    (string-upcase token))))
+   `(((,token)) (()))))
+
+(defun make-alternative-rule (tokens)
+  "Make a rule for a list of alternatives (\"or\" syntax) and return it."
+  (insert-rule-in-current-grammar
+   (gensym "ALT")
+   (mapcar #'(lambda (alternative)
+	       `((,alternative)))
+	   tokens)))
+
+(defun make-nonempty-list-rule (token &optional separator)
+  "Make a rule for a non-empty list (+ syntax) and return it."
+  (let ((rule-name (gensym (concatenate 'string "NELST-"
+					(if (rule-p token)
+					    (symbol-name (rule-name token))
+					    (string-upcase token))))))
+    (insert-rule-in-current-grammar
+     rule-name
+     (if separator
+	 `(((,token ,separator ,rule-name)
+	    (cons $1 $3))
+	   ((,token) ,#'list))
+	 `(((,token ,rule-name)
+	    (cons $1 $2))
+	   ((,token) ,#'list))))))
+
+(defun make-list-rule (token &optional separator)
+  "Make a rule for a possibly empty list (* syntax) return it."
+  (make-optional-rule (make-nonempty-list-rule token separator)))
+
+(defun const-terminal-p (object)
+  (or (stringp object)
+      (keywordp object)))
+
+(defun expand-production-token (tok)
+  "Translate token of the type NAME? or NAME* or NAME+ into (? NAME)
+or (* NAME) or (+ NAME).  This is used by the DEFRULE macro."
+  (if (symbolp tok)
+      (let* ((name (symbol-name tok))
+	     (last (char name (1- (length name))))
+	     ;; this looks silly but we need to make sure that we
+	     ;; return symbols interned in this package, no one else
+	     (op (cadr (assoc last '((#\? ?) (#\+ +) (#\* *))))))
+	(if (and (> (length name) 1) op)
+	    (list op
+		  (intern (subseq name 0 (1- (length name)))))
+	    tok))
+      tok))
+
+(defun EBNF-to-SEBNF (tokens)
+  "Take a production as a list of TOKENS and expand it.  This turns a
+EBNF syntax into a sexp-based EBNF syntax or SEBNF."
+  (loop
+     for tok in tokens
+     for token = (expand-production-token tok)
+     with new-tokens = '()
+     do (cond ((member token '(* + ?))
+	       (setf (car new-tokens)
+		     (list token (car new-tokens))))
+	      (t
+	       (push token new-tokens)))
+     finally (return (nreverse new-tokens))))
+
+(defun SEBNF-to-BNF (tokens)
+  "Take a production in SEBNF (Symbolic Extended BNF) syntax and turn
+it into BNF.  The production is simplified but the current grammar is
+populated with additional rules."
+  (flet ((make-complex-token-rule (tok)
+	   (ecase (car tok)
+	     (* (apply #'make-list-rule (cdr tok)))
+	     (+ (apply #'make-nonempty-list-rule (cdr tok)))
+	     (? (make-optional-rule (cadr tok)))
+	     (or (make-alternative-rule (cdr tok))))))
+    (loop
+       for token in tokens
+       with new-tokens = '()
+       with keywords = '()
+       do (cond ((listp token)
+		 (push (make-complex-token-rule token) new-tokens))
+		(t
+		 (push token new-tokens)
+		 (when (const-terminal-p token)
+		   (push token keywords))))
+       finally (return (values (nreverse new-tokens) keywords)))))
+
+(defun make-default-action-function (name tokens)
+  "Create a sexp to be used as default action in case one is not
+supplied in the production.  This is usually a quite sensible
+one.  That is, only the non-constant tokens are returned in a
+list and in case only a variable token is available that one is
+returned (not included in a list).  If all the tokens are
+constant, then all of them are returned in a list."
+  (cond ((null tokens)
+	 ;; if the production matched the empty list (no tokens) we
+	 ;; return always nil, that is the function LIST applied to no
+	 ;; arguments
+	 #'list)
+	((null (cdr tokens))
+	 ;; if the production matches just one token we simply return
+	 ;; that
+	 #'identity)
+	(*smart-default-reduction*
+	 ;; If we are required to be "smart" then create a function
+	 ;; that simply returns the non static tokens of the
+	 ;; production.  If the production doesn't have nonterminal,
+	 ;; then return all the tokens.  If the production has only
+	 ;; one argument then return that one only.
+	 (make-action-function name tokens '(cond
+					     ((null $vars) $all)
+					     ((null (cdr $vars)) (car $vars))
+					     (t $vars))))
+	(t
+	 ;; in all the other cases we return all the token matching
+	 ;; the production
+	 #'list)))
+
+(defun make-production-from-descr (name production-description)
+  "Take a production NAME and its description in the form of a sexp
+and return a production structure object together with a list of used
+keywords."
+  (destructuring-bind (tokens &optional action) production-description
+    (let ((expanded-tokens (EBNF-to-SEBNF tokens)))
+      (multiple-value-bind (production-tokens keywords)
+	  (sebnf-to-bnf expanded-tokens)
+      (let ((funct
+	     (cond ((not action)
+		    (make-default-action-function name expanded-tokens))
+		   ((or (listp action)
+			;; the case when the action is simply to
+			;; return a token (ie $2) or a constant value
+			(symbolp action))
+		    (make-action-function name expanded-tokens action))
+		   ((functionp action)
+		    action)
+		   (t			; action is a constant
+		    #'(lambda (&rest args)
+			(declare (ignore args))
+			action)))))
+	(values
+	 ;; Make a promise instead of actually resolving the
+	 ;; nonterminals.  This avoids endless recursion.
+	 (make-production :tokens production-tokens
+			  :tokens-length (length production-tokens)
+			  :action funct)
+	 keywords))))))
+
+(defun remove-immediate-left-recursivity (rule)
+  "Turn left recursive rules of the type
+    A -> A x | y
+into
+    A -> y A2
+    A2 -> x A2 | E
+where E is the empty production."
+  (let ((name (rule-name rule))
+	(productions (rule-productions rule)))
+    (loop
+       for prod in productions
+       for tokens = (prod-tokens prod)
+       ;; when immediately left recursive
+       when (eq (car tokens) rule)
+       collect prod into left-recursive
+       else
+       collect prod into non-left-recursive
+       finally
+	 ;; found any left recursive production?
+	 (when left-recursive
+	   (warn "rule ~S is left recursive" name)
+	   (let ((new-rule (make-rule :name (gensym "REWRITE"))))
+	     ;; A -> y A2
+	     (setf (rule-productions rule)
+		   (mapcar #'(lambda (p)
+			       (let ((tokens (prod-tokens p))
+				     (action (prod-action p)))
+				 (make-production :tokens (append tokens (list new-rule))
+						  :tokens-length (1+ (prod-tokens-length p))
+						  :action #'(lambda (&rest args)
+							      (let ((f-A2 (car (last args)))
+								    (head (butlast args)))
+								(funcall f-A2 (apply action head)))))))
+			   non-left-recursive))
+	     ;; A2 -> x A2 | E
+	     (setf (rule-productions new-rule)
+		   (append
+		    (mapcar #'(lambda (p)
+				(let ((tokens (prod-tokens p))
+				      (action (prod-action p)))
+				  (make-production :tokens (append (cdr tokens) (list new-rule))
+						   :tokens-length (prod-tokens-length p)
+						   :action #'(lambda (&rest args)
+							       (let ((f-A2 (car (last args)))
+								     (head (butlast args)))
+								 #'(lambda (x)
+								     (funcall f-A2 (apply action x head))))))))
+			    left-recursive)
+		    (list
+		     (make-production :tokens nil
+				      :tokens-length 0
+				      :action #'(lambda () #'(lambda (arg) arg)))))))))))
+
+(defun remove-left-recursivity-from-rules (rules)
+  (loop
+     for rule being each hash-value in rules
+     do
+     ;; More to be done here.  For now only the trivial immediate left
+     ;; recursivity is removed -wcp18/11/03.
+       (remove-immediate-left-recursivity rule)))
+
+(defun resolve-all-nonterminals (rules)
+  (loop
+     for rule being each hash-value in rules
+     do (loop
+	   for production in (rule-productions rule)
+	   do (setf (prod-tokens production)
+		    (resolve-nonterminals (prod-tokens production) rules)))))
+
+(defun make-rule-productions (rule-name production-descriptions)
+  "Return a production object that belongs to RULE-NAME made according
+to PRODUCTION-DESCRIPTIONS.  See also MAKE-PRODUCTION-FROM-DESCR."
+  (loop
+     for descr in production-descriptions
+     for i of-type fixnum from 1 by 1
+     for prod-name = (intern (format nil "~:@(~A~)-PROD~A" rule-name i))
+     with productions = '()
+     with keywords = '()
+     do (progn
+	  (multiple-value-bind (production keyws)
+	      (make-production-from-descr prod-name descr)
+	    (push production productions)
+	    (setf keywords (append keyws keywords))))
+     finally (return
+	       (values (nreverse productions) keywords))))
+
+(defun create-rule (name production-descriptions)
+  "Return a new rule object together with a list of keywords making up
+the production definitions."
+  (multiple-value-bind (productions keywords)
+      (make-rule-productions name production-descriptions)
+    (values (make-rule :name name :productions productions)
+	    keywords)))
+
+(defun insert-rule-in-current-grammar (name productions)
+  "Add rule to the current grammar and its keywords to the keywords
+hash table.  You don't want to use this directly.  See DEFRULE macro
+instead."
+  (when (find-rule name *rules*)
+    (error "redefining rule ~A" name))
+  (multiple-value-bind (rule keywords)
+      (create-rule name productions)
+    (add-rule name rule *rules*)
+    (dolist (term keywords)
+      (add-keyword term *keywords*))
+    rule))
+
+(defun resolve-nonterminals (tokens rules)
+  "Given a list of production tokens, try to expand the nonterminal
+ones with their respective rule from the the RULES pool."
+  (flet ((resolve-symbol (sym)
+	   (or (find-rule sym rules)
+	       sym)))
+    (mapcar #'(lambda (tok)
+		(if (symbolp tok)
+		    (resolve-symbol tok)
+		    tok))
+	    tokens)))
+
+(defun reset-grammar ()
+  "Empty the current grammar from any existing rule."
+  (setf *rules* (make-rules-table)
+	*keywords* (make-keywords-table)))
+
+(defun generate-grammar (&optional (equal-p #'string-equal))
+  "Return a GRAMMAR structure suitable for the PARSE function, using
+the current rules.  EQUAL-P, if present, is a function to be used to
+match the input tokens; it defaults to STRING-EQUAL."
+  (resolve-all-nonterminals *rules*)
+  (remove-left-recursivity-from-rules *rules*)
+  (make-grammar :rules *rules*
+		:keywords *keywords*
+		:equal-p equal-p))
diff --git a/third_party/lisp/npg/src/package.lisp b/third_party/lisp/npg/src/package.lisp
new file mode 100644
index 000000000000..b405f7b5f19e
--- /dev/null
+++ b/third_party/lisp/npg/src/package.lisp
@@ -0,0 +1,50 @@
+;;;  package.lisp --- backtracking parser package definition
+
+;;;  Copyright (C) 2003-2006, 2009 by Walter C. Pelissero
+
+;;;  Author: Walter C. Pelissero <walter@pelissero.de>
+;;;  Project: NPG a Naive Parser Generator
+
+#+cmu (ext:file-comment "$Module: package.lisp $")
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public License
+;;; as published by the Free Software Foundation; either version 2.1
+;;; of the License, or (at your option) any later version.
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free
+;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+;;; 02111-1307 USA
+
+(in-package :cl-user)
+
+(defpackage :naive-parser-generator
+  (:nicknames :npg)
+  (:use :common-lisp)
+  (:export
+   #:parse				; The Parser
+   #:reset-grammar
+   #:generate-grammar
+   #:print-grammar-figures
+   #:grammar-keyword-p
+   #:keyword
+   #:grammar
+   #:make-token
+   #:token-value
+   #:token-type
+   #:token-position
+   #:later-position
+   #:defrule				; to define grammars
+   #:deftoken				; to define a lexer
+   #:input-cursor-mixin
+   #:copy-input-cursor-slots
+   #:dup-input-cursor
+   #:read-next-tokens
+   #:end-of-input
+   #:? #:+ #:* #:or
+   #:$vars #:$all #:$alist
+   #:$1 #:$2 #:$3 #:$4 #:$5 #:$6 #:$7 #:$8 #:$9 #:$10))
diff --git a/third_party/lisp/npg/src/parser.lisp b/third_party/lisp/npg/src/parser.lisp
new file mode 100644
index 000000000000..328be1dcf30f
--- /dev/null
+++ b/third_party/lisp/npg/src/parser.lisp
@@ -0,0 +1,234 @@
+;;;  parser.lisp --- runtime parser
+
+;;;  Copyright (C) 2003-2006, 2009 by Walter C. Pelissero
+
+;;;  Author: Walter C. Pelissero <walter@pelissero.de>
+;;;  Project: NPG a Naive Parser Generator
+
+#+cmu (ext:file-comment "$Module: parser.lisp $")
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public License
+;;; as published by the Free Software Foundation; either version 2.1
+;;; of the License, or (at your option) any later version.
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free
+;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+;;; 02111-1307 USA
+
+;;;  Commentary:
+;;;
+;;; This is the runtime part of the parser.  The code that is
+;;; responsible to execute the parser defined with the primitives
+;;; found in define.lisp.
+
+(in-package :naive-parser-generator)
+
+(defvar *debug* nil
+  "Either nil or a stream where to write the debug informations.")
+#+debug (declaim (fixnum *maximum-recursion-depth*))
+#+debug (defvar *maximum-recursion-depth* 1000
+  "Maximum depth the parser is allowed to recursively call itself.
+This is the only way for the parser to detect a loop in the grammar.
+Tune this if your grammar is unusually complex.")
+
+(declaim (inline reduce-production))
+(defun reduce-production (production arguments)
+  "Apply PRODUCTION's action on ARGUMENTS.  This has the effect of
+  \"reducing\" the production."
+  (when *debug*
+    (format *debug* "reducing ~S on ~S~%" production arguments))
+  (flet ((safe-token-value (token)
+	   (if (token-p token)
+	       (token-value token)
+	       token)))
+    (apply (prod-action production) (mapcar #'safe-token-value arguments))))
+
+(defgeneric later-position (pos1 pos2)
+  (:documentation
+   "Compare two file postions and return true if POS1 is later than
+POS2 in the input stream."))
+
+;; This is meant to be overloaded in the lexer
+(defmethod later-position ((pos1 integer) (pos2 integer))
+  (> pos1 pos2))
+
+;; this looks silly but turns out to be useful (see below)
+(defmethod later-position (pos1 pos2)
+  (and (eq pos1 :eof) (not (eq pos2 :eof))))
+
+(defgeneric read-next-tokens (tokens-source)
+  (:documentation "Read next token from a lexical analysed stream.  The nature of
+TOKENS-SOURCE is implementation dependent and any lexical analyzer is
+supposed to specialise this method."))
+
+;; This is the actual parser.  the algorithm is pretty
+;; straightforward, the execution of the reductions a bit less.  Error
+;; recovery is rather clumsy.
+
+(defun parse (grammar start tokenizer)
+  "Match a GRAMMAR against the list of input tokens coming from TOKENIZER.
+Return the reduced values according to the nonterminal actions.  Raise
+an error on failure."
+  (declare (type grammar grammar)
+	   (type symbol start))
+  (labels
+      ((match-token (expected token)
+	 (when *debug*
+	   (format *debug* "match-token ~S ~S -> " expected token))
+	 (let ((res (cond ((symbolp expected)
+			   ;; non-costant terminal (like identifiers)
+			   (eq expected (token-type token)))
+			  ((and (stringp expected)
+				(stringp (token-value token)))
+			   ;; string costant terminal
+			   (funcall (the function (grammar-equal-p grammar)) expected (token-value token)))
+			  ((functionp expected)
+			   ;; custom equality predicate (must be able
+			   ;; to deal with token objects)
+			   (funcall expected token))
+			  ;; all the rest
+			  (t (equal expected (token-value token))))))
+	   (when *debug*
+	     (format *debug* "~Amatched~%" (if res "" "not ")))
+	   res))
+       (match (expected matched #+debug depth)
+	 (declare (list expected matched)
+		  #+debug (fixnum depth))
+	 (let ((first-expected (car expected)))
+	   (cond #+debug ((> depth *maximum-recursion-depth*)
+		  (error "endless recursion on ~A ~A at ~A expecting ~S"
+			 (token-type (car matched)) (token-value (car matched))
+			 (token-position (car matched)) expected))
+		 ((eq first-expected :any)
+		  (match (cdr expected) (cdr matched) #+debug depth))
+		 ;; This is a trick to obtain partial parses.  When we
+		 ;; reach this expected token we assume we succeeded
+		 ;; the parsing and return the remaining tokens as
+		 ;; part of the match.
+		 ((eq first-expected :rest)
+		  ;; we could be at the end of input so we check this
+		  (unless (cdr matched)
+		    (setf (cdr matched) (list :rest)))
+		  (list nil nil))
+		 ((rule-p first-expected)
+		  ;; If it's a rule, then we try to match all its
+		  ;; productions.  We return the first that succeeds.
+		  (loop
+		     for production in (rule-productions first-expected)
+		     for production-tokens of-type list = (prod-tokens production)
+		     with last-error-position = nil
+		     with last-error = nil
+		     for (error-position error-descr) =
+		       (progn
+			 (when *debug*
+			   (format *debug* "trying to match ~A: ~S~%"
+				   (rule-name first-expected) production-tokens))
+			 (match (append production-tokens (cdr expected)) matched #+debug (1+ depth)))
+		     do (cond ((not error-position)
+			       (return (let ((args-count (prod-tokens-length production)))
+					 (setf (cdr matched)
+					       (cons (reduce-production
+						      production
+						      (subseq (the list (cdr matched)) 0 args-count))
+						     (nthcdr (1+ args-count) matched)))
+					 (list nil nil))))
+			      ((or (not last-error)
+				   (later-position error-position last-error-position))
+			       (setf last-error-position error-position
+				     last-error error-descr)))
+		     ;; if everything fails return the "best" error
+		     finally (return (list last-error-position
+					   (if *debug*
+					       #'(lambda ()
+						   (format nil "~A, trying to match ~A"
+							   (funcall (the function last-error))
+							   (rule-name first-expected)))
+					       last-error)))))
+		 (t
+		  ;; if necessary load the next tokens
+		  (when (null (cdr matched))
+		    (setf (cdr matched) (read-next-tokens tokenizer)))
+		  (cond ((and (or (null expected) (eq first-expected :eof))
+			      (null (cdr matched)))
+			 ;; This point is reached only once for each complete
+			 ;; parsing.  The expected tokens and the input
+			 ;; tokens have been exhausted at the same time.
+			 ;; Hence we succeeded the parsing.
+			 (setf (cdr matched) (list :eof))
+			 (list nil nil))
+			((null expected)
+			 ;; Garbage at end of parsing.  This may mean that we
+			 ;; have considered a production completed too soon.
+			 (list (token-position (car matched))
+			       #'(lambda ()
+				   "garbage at end of parsing")))
+			((null (cdr matched))
+			 ;; EOF error
+			 (list :eof
+			       #'(lambda ()
+				   (format nil "end of input expecting ~S" expected))))
+			(t ;; normal token
+			 (let ((first-token (cadr matched)))
+			   (if (match-token first-expected first-token)
+			       (match (cdr expected) (cdr matched) #+debug depth)
+			       ;; failed: we return the error
+			       (list (token-position first-token)
+				     #'(lambda ()
+					 (format nil "expected ~S but got ~S ~S"
+						 first-expected (token-type first-token)
+						 (token-value first-token)))))))))))))
+    (declare (inline match-token))
+    (let ((result (list :head)))
+      (destructuring-bind (error-position error)
+	  (match (list (find-rule start (grammar-rules grammar))) result #+debug 0)
+	(when error-position
+	  (error "~A at ~A~%" (funcall (the function error)) error-position))
+	(cadr result)))))
+
+(defgeneric terminals-in-grammar (grammar-or-hashtable)
+  (:documentation
+   "Find non constant terminal symbols in GRAMMAR."))
+
+(defmethod terminals-in-grammar ((grammar hash-table))
+  (loop
+     for rule being each hash-value of grammar
+     with terminals = '()
+     do (loop
+	   for prod in (rule-productions rule)
+	   do (loop
+		 for tok in (prod-tokens prod)
+		 when (symbolp tok)
+		 do (pushnew tok terminals)))
+     finally (return terminals)))
+
+(defmethod terminals-in-grammar ((grammar grammar))
+  (terminals-in-grammar (grammar-rules grammar)))
+
+(defun print-grammar-figures (grammar &optional (stream *standard-output*))
+  (format stream "rules: ~A~%constant terminals: ~A~%variable terminals: ~S~%"
+	  (hash-table-count (grammar-rules grammar))
+	  (hash-table-count (grammar-keywords grammar))
+	  (terminals-in-grammar (grammar-rules grammar))))
+
+
+(defun grammar-keyword-p (keyword grammar)
+  "Check if KEYWORD is part of this grammar."
+  (find-keyword keyword (grammar-keywords grammar)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defvar *grammars* (make-hash-table))
+
+(defun find-grammar (name)
+  (gethash name *grammars*))
+
+(defun delete-grammar (name)
+  (remhash name *grammars*))
+
+(defun add-grammar (name grammar)
+  (setf (gethash name *grammars*) grammar))
diff --git a/third_party/lisp/parse-float.nix b/third_party/lisp/parse-float.nix
new file mode 100644
index 000000000000..4e36e69c7d98
--- /dev/null
+++ b/third_party/lisp/parse-float.nix
@@ -0,0 +1,22 @@
+{ depot, pkgs, ... }:
+
+let
+  src = pkgs.fetchFromGitHub {
+    owner = "soemraws";
+    repo = "parse-float";
+    rev = "3074765101e41222b6b624a66aaf1e6416379f9c";
+    sha256 = "0jd2spawc3v8vzqf8ky4cngl45jm65fhkrdf20mf6dcbn3mzpkmr";
+  };
+
+in depot.nix.buildLisp.library {
+  name = "parse-float";
+
+  deps = with depot.third_party.lisp; [
+    alexandria
+  ];
+
+  srcs = map (f: src + ("/" + f)) [
+    "package.lisp"
+    "parse-float.lisp"
+  ];
+}
diff --git a/third_party/lisp/parse-number.nix b/third_party/lisp/parse-number.nix
new file mode 100644
index 000000000000..1ceba2863d8d
--- /dev/null
+++ b/third_party/lisp/parse-number.nix
@@ -0,0 +1,17 @@
+{ depot, pkgs, ... }:
+
+let
+
+  src = pkgs.fetchFromGitHub {
+    owner = "sharplispers";
+    repo = "parse-number";
+    rev = "7707b224c4b941c2cbd28459113534242cee3a31";
+    sha256 = "0sk06ib1bhqv9y39vwnnw44vmbc4b0kvqm37xxmkxd4dwchq82d7";
+  };
+
+in depot.nix.buildLisp.library {
+  name = "parse-number";
+  srcs = map (f: src + ("/" + f)) [
+    "parse-number.lisp"
+  ];
+}
diff --git a/third_party/lisp/parseq.nix b/third_party/lisp/parseq.nix
new file mode 100644
index 000000000000..fe045d52996f
--- /dev/null
+++ b/third_party/lisp/parseq.nix
@@ -0,0 +1,20 @@
+{ depot, pkgs, ... }:
+
+let
+  src = pkgs.fetchFromGitHub {
+    owner = "mrossini-ethz";
+    repo = "parseq";
+    rev = "5cd95b324b68255d89f27f8065f4c29674558b26";
+    sha256 = "1f3vvxgyiv0xn2hzafhh63l3gnvn2vaxr5pi3ld7d340mka2ndg0";
+  };
+
+in depot.nix.buildLisp.library {
+  name = "parseq";
+
+  srcs = map (f: src + ("/" + f)) [
+    "package.lisp"
+    "conditions.lisp"
+    "utils.lisp"
+    "defrule.lisp"
+  ];
+}
diff --git a/third_party/lisp/physical-quantities.nix b/third_party/lisp/physical-quantities.nix
new file mode 100644
index 000000000000..b8079e8ebaaf
--- /dev/null
+++ b/third_party/lisp/physical-quantities.nix
@@ -0,0 +1,31 @@
+{ depot, pkgs, ... }:
+
+let
+  src = pkgs.fetchFromGitHub {
+    owner = "mrossini-ethz";
+    repo = "physical-quantities";
+    rev = "v0.2.1";
+    sha256 = "0mb2s94s6fhw5vfa89naalw7ld11sdsszlqpz0c65dvpfyfmmdmh";
+  };
+
+in depot.nix.buildLisp.library {
+  name = "physical-quantities";
+
+  deps = with depot.third_party.lisp; [
+    parseq
+  ];
+
+  srcs = map (f: src + ("/" + f)) [
+    "package.lisp"
+    "utils.lisp"
+    "conditions.lisp"
+    "unit-factor.lisp"
+    "unit-database.lisp"
+    "units.lisp"
+    "quantity.lisp"
+    "numeric.lisp"
+    "parse-rules.lisp"
+    "read-macro.lisp"
+    "si-units.lisp"
+  ];
+}
diff --git a/third_party/lisp/postmodern.nix b/third_party/lisp/postmodern.nix
new file mode 100644
index 000000000000..333a9d9b770f
--- /dev/null
+++ b/third_party/lisp/postmodern.nix
@@ -0,0 +1,94 @@
+{ depot, pkgs, ... }:
+
+let
+  inherit (depot.nix.buildLisp) bundled;
+
+  src = pkgs.fetchFromGitHub {
+    owner = "marijnh";
+    repo = "Postmodern";
+    rev = "v1.32";
+    sha256 = "0prwmpixcqpzqd67v77cs4zgbs73a10m6hs7q0rpv0z1qm7mqfcb";
+  };
+
+  cl-postgres = depot.nix.buildLisp.library {
+    name = "cl-postgres";
+    deps = with depot.third_party.lisp; [
+      md5
+      split-sequence
+      ironclad
+      cl-base64
+      uax-15
+      usocket
+    ];
+
+    srcs = map (f: src + ("/cl-postgres/" + f)) [
+      "package.lisp"
+      "features.lisp"
+      "errors.lisp"
+      "sql-string.lisp"
+      "trivial-utf-8.lisp"
+      "strings-utf-8.lisp"
+      "communicate.lisp"
+      "messages.lisp"
+      "oid.lisp"
+      "ieee-floats.lisp"
+      "interpret.lisp"
+      "saslprep.lisp"
+      "scram.lisp"
+      "protocol.lisp"
+      "public.lisp"
+      "bulk-copy.lisp"
+    ];
+  };
+
+  s-sql = depot.nix.buildLisp.library {
+    name = "s-sql";
+    deps = with depot.third_party.lisp; [
+      cl-postgres
+      alexandria
+    ];
+
+    srcs = map (f: src + ("/s-sql/" + f)) [
+      "package.lisp"
+      "s-sql.lisp"
+    ];
+  };
+
+  postmodern = depot.nix.buildLisp.library {
+    name = "postmodern";
+
+    deps = with depot.third_party.lisp; [
+      alexandria
+      cl-postgres
+      s-sql
+      global-vars
+      split-sequence
+      cl-unicode
+      closer-mop
+      bordeaux-threads
+    ];
+
+    srcs = [
+      "${src}/postmodern.asd"
+    ] ++ (map (f: src + ("/postmodern/" + f)) [
+      "package.lisp"
+      "connect.lisp"
+      "query.lisp"
+      "prepare.lisp"
+      "roles.lisp"
+      "util.lisp"
+      "transaction.lisp"
+      "namespace.lisp"
+      "execute-file.lisp"
+      "table.lisp"
+      "deftable.lisp"
+    ]);
+
+    brokenOn = [
+      "ecl" # TODO(sterni): https://gitlab.com/embeddable-common-lisp/ecl/-/issues/651
+    ];
+  };
+
+in postmodern // {
+  inherit s-sql cl-postgres;
+}
diff --git a/third_party/lisp/puri.nix b/third_party/lisp/puri.nix
new file mode 100644
index 000000000000..925b457f9f03
--- /dev/null
+++ b/third_party/lisp/puri.nix
@@ -0,0 +1,14 @@
+# Portable URI library
+{ depot, pkgs, ... }:
+
+let src = pkgs.fetchgit {
+  url = "http://git.kpe.io/puri.git";
+  rev = "4bbab89d9ccbb26346899d1f496c97604fec567b";
+  sha256 = "0gq2rsr0aihs0z20v4zqvmdl4szq53b52rh97pvnmwrlbn4mapmd";
+};
+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/restas.nix b/third_party/lisp/restas.nix
new file mode 100644
index 000000000000..cf231286e79a
--- /dev/null
+++ b/third_party/lisp/restas.nix
@@ -0,0 +1,41 @@
+{ depot, pkgs, ... }:
+
+let
+
+  src = pkgs.fetchFromGitHub {
+    owner = "archimag";
+    repo = "restas";
+    rev = "81bbbab6b36f81f846f78e71232e9d3d15f6d952";
+    sha256 = "00ng6jik1lwjw3bbxhijy8s0ml24lgm73liwrr01gcsb0r6wrjjn";
+  };
+
+in depot.nix.buildLisp.library {
+  name = "restas";
+  deps = with depot.third_party.lisp; [
+    cffi
+    hunchentoot
+    bordeaux-threads
+    routes
+    alexandria
+    data-sift
+  ];
+
+  srcs = map (f: src + ("/src/" + f)) [
+    "packages.lisp"
+    "special.lisp"
+    "declarations.lisp"
+    "errors.lisp"
+    "render.lisp"
+    "context.lisp"
+    "module.lisp"
+    "route.lisp"
+    "decorators.lisp"
+    "vhost.lisp"
+    "hunchentoot.lisp"
+    "policy.lisp"
+  ];
+
+  brokenOn = [
+    "ecl" # dynamic cffi
+  ];
+}
diff --git a/third_party/lisp/rfc2388.nix b/third_party/lisp/rfc2388.nix
new file mode 100644
index 000000000000..6af55f927001
--- /dev/null
+++ b/third_party/lisp/rfc2388.nix
@@ -0,0 +1,17 @@
+# Implementation of RFC2388 (multipart/form-data)
+{ depot, pkgs, ... }:
+
+let src = pkgs.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/routes.nix b/third_party/lisp/routes.nix
new file mode 100644
index 000000000000..a76912c651a9
--- /dev/null
+++ b/third_party/lisp/routes.nix
@@ -0,0 +1,38 @@
+{ depot, pkgs, ... }:
+
+let
+
+  src = pkgs.applyPatches {
+    name = "routes-source";
+    src = pkgs.fetchFromGitHub {
+      owner = "archimag";
+      repo = "cl-routes";
+      rev = "1b79e85aa653e1ec87e21ca745abe51547866fa9";
+      sha256 = "1zpk3cp2v8hm50ppjl10yxr437vv4552r8hylvizglzrq2ibsbr1";
+    };
+
+    patches = [
+      (pkgs.fetchpatch {
+        name = "fix-build-with-ccl.patch";
+        url = "https://github.com/archimag/cl-routes/commit/2296cdc316ef8e34310f2718b5d35a30040deee0.patch";
+        sha256 = "007c19kmymalam3v6l6y2qzch8xs3xnphrcclk1jrpggvigcmhax";
+      })
+    ];
+  };
+
+in depot.nix.buildLisp.library {
+  name = "routes";
+
+  deps = with depot.third_party.lisp; [
+    puri
+    iterate
+    split-sequence
+  ];
+
+  srcs = map (f: src + ("/src/" + f)) [
+    "package.lisp"
+    "uri-template.lisp"
+    "route.lisp"
+    "mapper.lisp"
+  ];
+}
diff --git a/third_party/lisp/s-sysdeps.nix b/third_party/lisp/s-sysdeps.nix
new file mode 100644
index 000000000000..571eb147c724
--- /dev/null
+++ b/third_party/lisp/s-sysdeps.nix
@@ -0,0 +1,17 @@
+# A Common Lisp abstraction layer over platform dependent functionality.
+{ depot, pkgs, ... }:
+
+let src = pkgs.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/sclf/.skip-subtree b/third_party/lisp/sclf/.skip-subtree
new file mode 100644
index 000000000000..5051f60d6b86
--- /dev/null
+++ b/third_party/lisp/sclf/.skip-subtree
@@ -0,0 +1 @@
+prevent readTree from creating entries for subdirs that don't contain an .nix files
diff --git a/third_party/lisp/sclf/OWNERS b/third_party/lisp/sclf/OWNERS
new file mode 100644
index 000000000000..f16dd105d761
--- /dev/null
+++ b/third_party/lisp/sclf/OWNERS
@@ -0,0 +1,3 @@
+inherited: true
+owners:
+  - sterni
diff --git a/third_party/lisp/sclf/README b/third_party/lisp/sclf/README
new file mode 100644
index 000000000000..2a1c2c3c5c1c
--- /dev/null
+++ b/third_party/lisp/sclf/README
@@ -0,0 +1,6 @@
+SCLF has originally been written by Walter C. Pelissero and vendored
+into depot since it is a dependency of mime4cl. Upstream and depot version
+may diverge.
+
+Upstream Website: http://wcp.sdf-eu.org/software/#sclf
+Vendored Tarball: http://wcp.sdf-eu.org/software/sclf-20150207T213551.tbz
diff --git a/third_party/lisp/sclf/default.nix b/third_party/lisp/sclf/default.nix
new file mode 100644
index 000000000000..fb07f8f764e5
--- /dev/null
+++ b/third_party/lisp/sclf/default.nix
@@ -0,0 +1,28 @@
+# Copyright (C) 2021 by the TVL Authors
+# SPDX-License-Identifier: LGPL-2.1-or-later
+{ depot, pkgs, ... }:
+
+depot.nix.buildLisp.library {
+  name = "sclf";
+
+  deps = [
+    (depot.nix.buildLisp.bundled "sb-posix")
+  ];
+
+  srcs = [
+    ./package.lisp
+    ./sclf.lisp
+    ./sysproc.lisp
+    ./lazy.lisp
+    ./time.lisp
+    ./directory.lisp
+    ./serial.lisp
+    ./mp/sbcl.lisp
+  ];
+
+  # TODO(sterni): implement OS interaction for ECL and CCL
+  brokenOn = [
+    "ecl"
+    "ccl"
+  ];
+}
diff --git a/third_party/lisp/sclf/directory.lisp b/third_party/lisp/sclf/directory.lisp
new file mode 100644
index 000000000000..4684a8e7056a
--- /dev/null
+++ b/third_party/lisp/sclf/directory.lisp
@@ -0,0 +1,404 @@
+;;;  directory.lisp --- filesystem directory access
+
+;;;  Copyright (C) 2006, 2007, 2008, 2009, 2010 by Walter C. Pelissero
+;;;  Copyright (C) 2021 by the TVL Authors
+
+;;;  Author: Walter C. Pelissero <walter@pelissero.de>
+;;;  Project: sclf
+
+#+cmu (ext:file-comment "$Module: directory.lisp $")
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public License
+;;; as published by the Free Software Foundation; either version 2.1
+;;; of the License, or (at your option) any later version.
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free
+;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+;;; 02111-1307 USA
+
+
+(cl:in-package :sclf)
+
+(defun pathname-as-directory (pathname)
+  "Converts PATHNAME to directory form and return it."
+  (setf pathname (pathname pathname))
+  (if (pathname-name pathname)
+      (make-pathname :directory (append (or (pathname-directory pathname)
+					    '(:relative))
+					(list (file-namestring pathname)))
+		     :name nil
+		     :type nil
+		     :defaults pathname)
+      pathname))
+
+(defun d+ (path &rest rest)
+  "Concatenate directory pathname parts and return a pathname."
+  (make-pathname :defaults path
+		 :directory (append (pathname-directory path) rest)))
+
+(defun delete-directory (pathname)
+  "Remove directory PATHNAME.  Return PATHNAME."
+  #+cmu (multiple-value-bind (done errno)
+	     (unix:unix-rmdir (namestring pathname))
+	   (unless done
+	     (error "Unable to delete directory ~A (errno=~A)"
+		    pathname errno)))
+  #+sbcl (sb-posix:rmdir pathname)
+  #+lispworks (lw:delete-directory pathname)
+  #-(or cmu sbcl)
+  (error "DELETE-DIRECTORY not implemented for you lisp system.")
+  pathname)
+
+(defun list-directory (pathname &key truenamep)
+  "List content of directory PATHNAME.  If TRUENAMEP is true don't try
+to follow symbolic links."
+  #-(or sbcl cmu) (declare (ignore truenamep))
+  (let (#+cmu (lisp::*ignore-wildcards* t))
+    (directory (make-pathname :defaults (pathname-as-directory pathname)
+			      :name :wild
+			      :type :wild
+			      :version :wild)
+	       #+cmu :truenamep #+cmu truenamep
+	       #+sbcl :resolve-symlinks #+sbcl truenamep)))
+
+(defun traverse-directory-tree (root-pathname proc &key truenamep test depth-first)
+  "Call PROC on all pathnames under ROOT-PATHNAME, both files and
+directories.  Unless TRUENAMEP is true, this function doesn't try
+to lookup the truename of files, as finding the truename may be a
+superfluous and noxious activity expecially when you expect
+broken symbolic links in your filesystem."
+  (check-type root-pathname pathname)
+  (check-type proc (or function symbol))
+  (check-type test (or function symbol null))
+  (labels ((ls (dir)
+	     (declare (type pathname dir))
+	     (list-directory dir :truenamep truenamep))
+	   (traverse? (file)
+	     (declare (type pathname file))
+	     (and (not (pathname-name file))
+		  (or truenamep
+		      (not (symbolic-link-p file)))
+		  (or (not test)
+		      (funcall test file))))
+	   (traverse-pre-order (dir)
+	     (declare (type pathname dir))
+	     (loop
+		for file in (ls dir)
+		do (funcall proc file)
+		when (traverse? file)
+		do (traverse-pre-order file)))
+	   (traverse-post-order (dir)
+	     (declare (type pathname dir))
+	     (loop
+		for file in (ls dir)
+		when (traverse? file)
+		do (traverse-post-order file)
+		do (funcall proc file))))
+    (if depth-first
+	(traverse-post-order root-pathname)
+	(traverse-pre-order root-pathname))
+    (values)))
+
+(defmacro do-directory-tree ((file root-pathname &key truenamep test depth-first) &body body)
+  "Call TRAVERSE-DIRECTORY-TREE with BODY es procedure."
+  `(traverse-directory-tree ,root-pathname
+			    #'(lambda (,file)
+				,@body)
+			    :truenamep ,truenamep
+			    :test ,test
+			    :depth-first ,depth-first))
+
+(defun empty-directory-p (pathname)
+  (and (directory-p pathname)
+       (endp (list-directory pathname))))
+
+(defun remove-empty-directories (root)
+  (do-directory-tree (pathname root :depth-first t)
+    (when (empty-directory-p pathname)
+      (delete-directory pathname))))
+
+(defun map-directory-tree (pathname function)
+  "Apply FUNCTION to every file in a directory tree starting from
+PATHNAME.  Return the list of results."
+  (be return-list '()
+    (do-directory-tree (directory-entry pathname)
+      (push (funcall function directory-entry) return-list))
+    (nreverse return-list)))
+
+(defun find-files (root-pathname matcher-function &key truenamep)
+  "In the directory tree rooted at ROOT-PATHNAME, find files that
+when the pathname is applied to MATCHER-FUNCTION will return
+true.  Return the list of files found.  Unless TRUENAMEP is true
+this function doesn't try to lookup the truename of
+files. Finding the truename may be a superfluous and noxious
+activity expecially when you expect broken symbolic links in your
+filesystem.  (This may not apply to your particular lisp
+system.)"
+  (be files '()
+    (do-directory-tree (file root-pathname :truenamep truenamep)
+      (when (funcall matcher-function file)
+	(push file files)))
+    (nreverse files)))
+
+(defun delete-directory-tree (pathname)
+  "Recursively delete PATHNAME and all the directory structure below
+it.
+
+WARNING: depending on the way the DIRECTORY function is implemented on
+your Lisp system this function may follow Unix symbolic links and thus
+delete files outside the PATHNAME hierarchy.  Check this before using
+this function in your programs."
+  (if (pathname-name pathname)
+      (delete-file pathname)
+      (progn
+	(dolist (file (list-directory pathname))
+	  (delete-directory-tree file))
+	(delete-directory pathname))))
+
+(defun make-directory (pathname &optional (mode #o777))
+  "Create a new directory in the filesystem.  Permissions MODE
+will be assigned to it.  Return PATHNAME."
+  #+cmu (multiple-value-bind (done errno)
+	    (unix:unix-mkdir (native-namestring pathname) mode)
+	  (unless done
+	    (error "Unable to create directory ~A (errno=~A)." pathname errno)))
+  #+sbcl (sb-posix:mkdir pathname mode)
+  #-(or cmu sbcl)
+  (error "MAKE-DIRECTORY is not implemented for this Lisp system.")
+  pathname)
+
+;; At least on SBCL/CMUCL + Unix + NFS this function is faster than
+;; ENSURE-DIRECTORIES-EXIST, because it doesn't check all the pathname
+;; components starting from the root; it proceeds from the leaf and
+;; crawls the directory tree upward only if necessary."
+(defun ensure-directory (pathname &key verbose (mode #o777))
+  "Just like ENSURE-DIRECTORIES-EXIST but, in some situations,
+it's faster."
+  (labels ((ensure (path)
+	     (unless (probe-file path)
+	       (be* tail (last (pathname-directory path) 2)
+		    last (cdr tail)
+		 (setf (cdr tail) nil)
+		 (unwind-protect
+		      (ensure path)
+		   (setf (cdr tail) last))
+		 (make-directory path mode)
+		 (when verbose
+		   (format t "Created ~S~%" path))))))
+    (ensure (make-pathname :defaults pathname
+			   :name nil :type nil
+			   :version nil))))
+
+(defun make-temp-directory (&optional (default-pathname *tmp-file-defaults*) (mode #o777))
+  "Create a new directory and return its pathname.
+If DEFAULT-PATHNAME is specified and not NIL it's used as
+defaults to produce the pathname of the directory.  Return the
+pathname of the temporary directory."
+  (loop
+     for name = (pathname-as-directory (temp-file-name default-pathname))
+     when (ignore-errors (make-directory name mode))
+     return name))
+
+(defmacro with-temp-directory ((path &rest make-temp-directory-args) &body body)
+  "Execute BODY with PATH bound to the pathname of a new unique
+temporary directory.  On exit of BODY the directory tree starting from
+PATH will be automatically removed from the filesystem.  Return what
+BODY returns.  BODY is _not_ executed within the PATH directory; the
+working directory is never changed."
+  `(be ,path (make-temp-directory ,@make-temp-directory-args)
+     (unwind-protect
+	  (progn ,@body)
+       (delete-directory-tree ,path))))
+
+(defun current-directory ()
+  "Return the pathname of the current directory."
+  (truename (make-pathname :directory '(:relative))))
+
+(defun ensure-home-translations ()
+  "Ensure that the logical pathname translations for the host \"home\"
+are defined."
+  ;; CMUCL already defines a HOME translation of its own and gets
+  ;; angry if we try to redefine it
+  #-cmu
+  (be home (user-homedir-pathname)
+    ;; we should discard and replace whatever has been defined in any
+    ;; rc file during compilation
+    (setf (logical-pathname-translations "home")
+	  (list
+	   (list "**;*.*.*"
+		 (make-pathname :defaults home
+				:directory (append (pathname-directory home)
+						   '(:wild-inferiors))
+				:name :wild
+				:type :wild))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun parse-native-namestring (string &optional host (defaults *default-pathname-defaults*)
+				&key (start 0) end junk-allowed)
+  #+sbcl (sb-ext:parse-native-namestring string host defaults
+					 :start start
+					 :end end
+					 :junk-allowed junk-allowed)
+  #-sbcl (let (#+cmu(lisp::*ignore-wildcards* t))
+	   (parse-namestring string host defaults
+			     :start start
+			     :end end
+			     :junk-allowed junk-allowed)))
+
+(defun native-namestring (pathname)
+  #+sbcl (sb-ext:native-namestring pathname)
+  #-sbcl (let (#+cmu (lisp::*ignore-wildcards* t))
+	   (namestring pathname)))
+
+(defun native-file-namestring (pathname)
+  #+sbcl (sb-ext:native-namestring
+	  (make-pathname :name (pathname-name pathname)
+			 :type (pathname-type pathname)))
+  #+cmu (be lisp::*ignore-wildcards* t
+	  (file-namestring pathname)))
+
+(defun native-pathname (thing)
+  #+sbcl (sb-ext:native-pathname thing)
+  #+cmu (be lisp::*ignore-wildcards* t
+	  (pathname thing)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun bits-set-p (x bits)
+  (= (logand x bits)
+     bits))
+
+(defun directory-p (pathname)
+  "Return true if PATHNAME names a directory on the filesystem."
+  #-clisp (awhen (unix-stat (native-namestring pathname))
+	    (bits-set-p (stat-mode it)
+			#+sbcl sb-posix:s-ifdir
+			#+cmu unix:s-ifdir))
+  #+clisp (ext:probe-directory (pathname-as-directory pathname)))
+
+(defun regular-file-p (pathname)
+  "Return true if PATHNAME names a regular file on the filesystem."
+  #-(or sbcl cmu) (error "don't know how to check whether a file might be a regular file")
+  (awhen (unix-stat (native-namestring pathname))
+    (bits-set-p (stat-mode it)
+		#+sbcl sb-posix:s-ifreg
+		#+cmu unix:s-ifreg)))
+
+(defun file-readable-p (pathname)
+  #+sbcl (sb-unix:unix-access (native-namestring pathname) sb-unix:r_ok)
+  #+cmu (unix:unix-access (native-namestring pathname) unix:r_ok)
+  #-(or sbcl cmu) (error "don't know how to check whether a file might be readable"))
+
+(defun file-writable-p (pathname)
+  #+sbcl (sb-unix:unix-access (native-namestring pathname) sb-unix:w_ok)
+  #+cmu (unix:unix-access (native-namestring pathname) unix:w_ok)
+  #-(or sbcl cmu) (error "don't know how to check whether a file might be writable"))
+
+(defun file-executable-p (pathname)
+  #+sbcl (sb-unix:unix-access (native-namestring pathname) sb-unix:x_ok)
+  #+cmu (unix:unix-access (native-namestring pathname) unix:x_ok)
+  #-(or sbcl cmu) (error "don't know how to check whether a file might be executable"))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defstruct (unix-file-stat (:conc-name stat-))
+  device
+  inode
+  links
+  atime
+  mtime
+  ctime
+  size
+  blksize
+  blocks
+  uid
+  gid
+  mode)
+
+(defun unix-stat (pathname)
+  ;; this could be different depending on the unix systems
+  (multiple-value-bind (ok? device inode mode links uid gid rdev
+			    size atime mtime ctime
+			    blksize blocks)
+      (#+cmu unix:unix-lstat
+       #+sbcl sb-unix:unix-lstat
+       (if (stringp pathname)
+	   pathname
+	   (native-namestring pathname)))
+    (declare (ignore rdev))
+    (when ok?
+      (make-unix-file-stat :device device
+			   :inode inode
+			   :links links
+			   :atime atime
+			   :mtime mtime
+			   :ctime ctime
+			   :size size
+			   :blksize blksize
+			   :blocks blocks
+			   :uid uid
+			   :gid gid
+			   :mode mode))))
+
+(defun stat-modification-time (stat)
+  "Return the modification time of the STAT structure as Lisp
+Universal Time, which is not the same as the Unix time."
+  (unix->universal-time (stat-mtime stat)))
+
+(defun stat-creation-time (stat)
+  "Return the creation time of the STAT structure as Lisp
+Universal Time, which is not the same as the Unix time."
+  (unix->universal-time (stat-ctime stat)))
+
+(defun file-modification-time (file)
+  "Return the modification time of FILE as Lisp Universal Time, which
+is not the same as the Unix time."
+  (awhen (unix-stat file)
+    (stat-modification-time it)))
+
+(defun file-creation-time (file)
+  "Return the creation time of FILE as Lisp Universal Time, which
+is not the same as the Unix time."
+  (awhen (unix-stat file)
+    (stat-creation-time it)))
+
+(defun read-symbolic-link (symlink)
+  "Return the pathname the SYMLINK points to.  That is, it's
+contents."
+  #+sbcl (sb-posix:readlink (native-namestring symlink))
+  #+cmu (unix:unix-readlink (native-namestring symlink)))
+
+;; FILE-LENGTH is a bit idiosyncratic in this respect.  Besides, Unix
+;; allows to get to know the file size without being able to open a
+;; file; just ask politely.
+(defun file-size (pathname)
+  (stat-size (unix-stat pathname)))
+
+(defun symbolic-link-p (pathname)
+  #-(or sbcl cmu) (error "don't know hot to test for symbolic links.")
+  (aand (unix-stat pathname)
+	(bits-set-p (stat-mode it)
+		    #+sbcl sb-posix:s-iflnk
+		    #+cmu unix:s-iflnk)))
+
+(defun broken-link-p (pathname)
+ (when (symbolic-link-p pathname)
+   #+cmu (not (ignore-errors (truename pathname)))
+   ;; On a broken symlink SBCL returns the link path without resolving
+   ;; the link itself.  De gustibus non est disputandum.
+   #+sbcl (equalp pathname (probe-file pathname))))
+
+(defun move-file (old new)
+  "Just like RENAME-FILE, but doesn't carry on to NEW file the type of
+OLD file, if NEW doesn't specify one.  It does what most people would
+expect from a rename function, which RENAME-FILE doesn't do.
+So (MOVE-FILE \"foo.bar\" \"foo\") does rename foo.bar to foo, losing
+the \"bar\" type; RENAME-FILE wouldn't allow you that."
+  #+sbcl (sb-posix:rename (native-namestring old) (native-namestring new))
+  #+cmu (unix:unix-rename (native-namestring old) (native-namestring new)))
diff --git a/third_party/lisp/sclf/lazy.lisp b/third_party/lisp/sclf/lazy.lisp
new file mode 100644
index 000000000000..18f6bfdb7109
--- /dev/null
+++ b/third_party/lisp/sclf/lazy.lisp
@@ -0,0 +1,134 @@
+;;;  lazy.lisp --- lazy primitives
+
+;;;  Copyright (C) 2008, 2009, 2010 by Walter C. Pelissero
+
+;;;  Author: Walter C. Pelissero <walter@pelissero.de>
+;;;  Project: sclf
+
+#+cmu (ext:file-comment "$Module: lazy.lisp $")
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public License
+;;; as published by the Free Software Foundation; either version 2.1
+;;; of the License, or (at your option) any later version.
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free
+;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+;;; 02111-1307 USA
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Lazy primitives
+;;;
+
+(in-package :sclf)
+
+(defstruct promise
+  procedure
+  value)
+
+(defmacro lazy (form)
+  `(make-promise :procedure #'(lambda () ,form)))
+
+(defun forced-p (promise)
+  (null (promise-procedure promise)))
+
+(defun force (promise)
+  (if (forced-p promise)
+      (promise-value promise)
+      (prog1 (setf (promise-value promise)
+		   (funcall (promise-procedure promise)))
+	(setf (promise-procedure promise) nil))))
+
+(defmacro deflazy (name value &optional documentation)
+  `(defparameter ,name (lazy ,value)
+     ,@(when documentation
+	     (list documentation))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defclass lazy-metaclass (standard-class)
+  ()
+  (:documentation "Metaclass for object having lazy slots.  Lazy slots
+should be specified with the :LAZY keyword which must be a function of
+one argument.  If required this function will be called once to get
+the value to memoize in the slot.  Lazy slots can also be set/read as
+any other."))
+
+(defmethod validate-superclass ((class lazy-metaclass) (super standard-class))
+  "Lazy classes may inherit from ordinary classes."
+  (declare (ignore class super))
+  t)
+
+(defmethod validate-superclass ((class standard-class) (super lazy-metaclass))
+  "Ordinary classes may inherit from lazy classes."
+  (declare (ignore class super))
+  t)
+
+(defclass lazy-slot-mixin ()
+  ((lazy-function :initarg :lazy
+		   :reader lazy-slot-function
+		   :initform nil))
+  (:documentation
+   "Slot for LAZY-METACLASS classes.  Lazy slots must be declared with
+the argument :LAZY which must be a function accepting the object
+instance as argument."))
+
+(defclass lazy-direct-slot-definition (lazy-slot-mixin standard-direct-slot-definition)
+  ())
+
+(defclass lazy-effective-slot-definition (lazy-slot-mixin standard-effective-slot-definition)
+  ())
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defmethod direct-slot-definition-class ((class lazy-metaclass) &rest initargs)
+  (if (getf initargs :lazy nil)
+      (find-class 'lazy-direct-slot-definition)
+      (call-next-method)))
+
+(defmethod effective-slot-definition-class ((class lazy-metaclass) &rest initargs)
+  (if (getf initargs :lazy nil)
+      (find-class 'lazy-effective-slot-definition)
+      (call-next-method)))
+
+(defmethod compute-effective-slot-definition-initargs ((class lazy-metaclass) direct-slots)
+  (let ((ds (car direct-slots)))
+    (if (typep ds 'lazy-direct-slot-definition)
+      (let ((form (lazy-slot-function ds))
+	    (args (call-next-method)))
+	(when (or (getf args :initarg)
+		  (getf args :initform))
+	  (error "Lazy slot ~S cannot have :INITARG nor :INITFORM arguments." ds))
+	(list* :lazy
+	       (cond ((and (listp form)
+			   (eq 'lambda (car form)))
+		      (compile nil form))
+		     ((symbolp form)
+		      form)
+		     (t (compile nil `(lambda (self)
+					(declare (ignorable self))
+					,form))))
+	       args))
+      (call-next-method))))
+
+(defmethod slot-value-using-class ((class lazy-metaclass) instance (slot lazy-slot-mixin))
+  (declare (ignore class))
+  ;; If the slot is unbound, call the lazy function passing the
+  ;; instance and memoize the value in the slot.
+  (unless (slot-boundp-using-class class instance slot)
+    (setf (slot-value-using-class class instance slot)
+	  (funcall (lazy-slot-function slot) instance)))
+  (call-next-method))
+
+(defun reset-lazy-slots (object)
+  "Unbind all the lazy slots in OBJECT so that they will be
+re-evaluated next time their value is requested again."
+  (be* class (class-of object)
+    (dolist (slot (class-slots class))
+      (when (typep slot 'lazy-effective-slot-definition)
+	(slot-makunbound object (slot-definition-name slot))))))
\ No newline at end of file
diff --git a/third_party/lisp/sclf/mp/README b/third_party/lisp/sclf/mp/README
new file mode 100644
index 000000000000..a0732c029453
--- /dev/null
+++ b/third_party/lisp/sclf/mp/README
@@ -0,0 +1,6 @@
+This directory contains an uniforming layer for multiprocessing in the
+style supported by Allegro Common Lisp and CMUCL.  Almost nothing of
+this has been written by me.  It's mostly the work of Gilbert Baumann
+(unk6@rz.uni-karlsruhe.de) and I've shamelessly lifted it from McCLIM.
+The copyright disclaimer in this code is compatible with the one of
+SCLF, so I believe there should be no legal issues.
diff --git a/third_party/lisp/sclf/mp/cmu.lisp b/third_party/lisp/sclf/mp/cmu.lisp
new file mode 100644
index 000000000000..6617f6dadd5d
--- /dev/null
+++ b/third_party/lisp/sclf/mp/cmu.lisp
@@ -0,0 +1,115 @@
+;;;
+;;; Code freely lifted from various places with compatible license
+;;; terms.  Most of this code is copyright Gilbert Baumann
+;;; <unk6@rz.uni-karlsruhe.de>.  The bugs are copyright Walter
+;;; C. Pelissero <walter@pelissero.de>.
+;;;
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Library General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 2 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Library General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Library General Public
+;;; License along with this library; if not, write to the 
+;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 
+;;; Boston, MA  02111-1307  USA.
+
+(in-package :sclf)
+
+(defun make-lock (&optional name)
+  (mp:make-lock name))
+
+(defun make-recursive-lock (&optional name)
+  (mp:make-lock name :kind :recursive))
+
+(defmacro with-lock-held ((lock &key whostate (wait t) timeout) &body forms)
+  `(mp:with-lock-held (,lock ,(or whostate "Lock Wait")
+			     :wait wait
+			     ,@(when timeout (list :timeout timeout)))
+     ,@forms))
+
+(defmacro with-recursive-lock-held ((lock &key wait timeout) &body forms)
+  `(mp:with-lock-held (,lock
+		       ,@(when wait (list :wait wait))
+		       ,@(when timeout (list :timeout timeout)))
+     ,@forms))
+
+(defstruct condition-variable
+  (lock (make-lock "condition variable"))
+  (value nil)
+  (process-queue nil))
+
+(defun %release-lock (lock) ; copied from with-lock-held in multiproc.lisp
+  #+i486 (kernel:%instance-set-conditional
+	  lock 2 mp:*current-process* nil)
+  #-i486 (when (eq (lock-process lock) mp:*current-process*)
+	   (setf (lock-process lock) nil)))
+
+(defun condition-wait (cv lock &optional timeout)
+  (declare (ignore timeout))		;For now
+  (loop
+     (let ((cv-lock (condition-variable-lock cv)))
+       (with-lock-held (cv-lock)
+	 (when (condition-variable-value cv)
+	   (setf (condition-variable-value cv) nil)
+	   (return-from condition-wait t))
+	 (setf (condition-variable-process-queue cv)
+	       (nconc (condition-variable-process-queue cv)
+		      (list mp:*current-process*)))
+	 (%release-lock lock))
+       (mp:process-add-arrest-reason mp:*current-process* cv)
+       (let ((cv-val nil))
+	 (with-lock-held (cv-lock)
+	   (setq cv-val (condition-variable-value cv))
+	   (when cv-val
+	     (setf (condition-variable-value cv) nil)))
+	 (when cv-val
+	   (mp::lock-wait lock "waiting for condition variable lock")
+	   (return-from condition-wait t))))))
+
+(defun condition-notify (cv)
+  (with-lock-held ((condition-variable-lock cv))
+    (let ((proc (pop (condition-variable-process-queue cv))))
+      ;; The waiting process may have released the CV lock but not
+      ;; suspended itself yet
+      (when proc
+	(loop
+	 for activep = (mp:process-active-p proc)
+	 while activep
+	 do (mp:process-yield))
+	(setf (condition-variable-value cv) t)
+	(mp:process-revoke-arrest-reason proc cv))))
+  ;; Give the other process a chance
+  (mp:process-yield))
+
+(defun process-execute (process function)
+  (mp:process-preset process function)
+  ;; For some obscure reason process-preset doesn't make the process
+  ;; runnable.  I'm sure it's me who didn't understand how
+  ;; multiprocessing works under CMUCL, despite the vast documentation
+  ;; available.
+  (mp:enable-process process)
+  (mp:process-add-run-reason process :enable))
+
+(defun destroy-process (process)
+  ;; silnetly ignore a process that is trying to destroy itself
+  (unless (eq (mp:current-process)
+	      process)
+    (mp:destroy-process process)))
+
+(defun restart-process (process)
+  (mp:restart-process process)
+  (mp:enable-process process)
+  (mp:process-add-run-reason process :enable))
+
+(defun process-alive-p (process)
+  (mp:process-alive-p process))
+
+(defun process-join (process)
+  (error "PROCESS-JOIN not support under CMUCL."))
diff --git a/third_party/lisp/sclf/mp/sbcl.lisp b/third_party/lisp/sclf/mp/sbcl.lisp
new file mode 100644
index 000000000000..7f47ec9c615f
--- /dev/null
+++ b/third_party/lisp/sclf/mp/sbcl.lisp
@@ -0,0 +1,235 @@
+;;;
+;;; Code freely lifted from various places with compatible license
+;;; terms.  Most of this code is copyright Daniel Barlow
+;;; <dan@metacircles.com> or Gilbert Baumann
+;;; <unk6@rz.uni-karlsruhe.de>.  The bugs are copyright Walter
+;;; C. Pelissero <walter@pelissero.de>.
+;;;
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Library General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 2 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Library General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Library General Public
+;;; License along with this library; if not, write to the 
+;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 
+;;; Boston, MA  02111-1307  USA.
+
+(in-package :sclf)
+
+(defstruct (process
+	     (:constructor %make-process)
+	     (:predicate processp))
+  name
+  state
+  whostate
+  function
+  thread)
+
+(defvar *current-process*
+  (%make-process
+   :name "initial process" :function nil
+   :thread
+   #+#.(cl:if (cl:find-symbol "THREAD-NAME" "SB-THREAD") '(and) '(or))
+   sb-thread:*current-thread*
+   #-#.(cl:if (cl:find-symbol "THREAD-NAME" "SB-THREAD") '(and) '(or))
+   (sb-thread:current-thread-id)))
+
+(defvar *all-processes* (list *current-process*))
+
+(defvar *all-processes-lock*
+  (sb-thread:make-mutex :name "Lock around *ALL-PROCESSES*"))
+
+;; we implement disable-process by making the disablee attempt to lock
+;; *permanent-queue*, which is already locked because we locked it
+;; here.  enable-process just interrupts the lock attempt.
+
+(defmacro get-mutex (mutex &optional (wait t))
+  `(
+    #+#.(cl:if (cl:find-symbol "GRAB-MUTEX" "SB-THREAD") '(and) '(or))
+	sb-thread:grab-mutex
+	#-#.(cl:if (cl:find-symbol "GRAB-MUTEX" "SB-THREAD") '(and) '(or))
+	sb-thread:get-mutex
+	,mutex :waitp ,wait))
+
+(defvar *permanent-queue*
+  (sb-thread:make-mutex :name "Lock for disabled threads"))
+(unless (sb-thread:mutex-owner *permanent-queue*)
+  (get-mutex *permanent-queue* nil))
+
+(defun make-process (function &key name)
+  (let ((p (%make-process :name name
+			  :function function)))
+    (sb-thread:with-mutex (*all-processes-lock*)
+      (pushnew p *all-processes*))
+    (restart-process p)))
+
+(defun process-kill-thread (process)
+  (let ((thread (process-thread process)))
+    (when (and thread
+	       (sb-thread:thread-alive-p thread))
+      (assert (not (eq thread sb-thread:*current-thread*)))
+      (sb-thread:terminate-thread thread)
+      ;; Wait until all the clean-up forms are done.
+      (sb-thread:join-thread thread :default nil))
+    (setf (process-thread process) nil)))
+
+(defun process-join (process)
+  (sb-thread:join-thread (process-thread process)))
+
+(defun restart-process (p)
+  (labels ((boing ()
+	     (let ((*current-process* p)
+		   (function (process-function p)))
+	       (when function
+		 (funcall function)))))
+    (process-kill-thread p)
+    (when (setf (process-thread p)
+		(sb-thread:make-thread #'boing :name (process-name p)))
+      p)))
+
+(defun destroy-process (process)
+  (sb-thread:with-mutex (*all-processes-lock*)
+    (setf *all-processes* (delete process *all-processes*)))
+  (process-kill-thread process))
+
+(defun current-process ()
+  *current-process*)
+
+(defun all-processes ()
+  ;; we're calling DELETE on *ALL-PROCESSES*.  If we look up the value
+  ;; while that delete is executing, we could end up with nonsense.
+  ;; Better use a lock (or call REMOVE instead in DESTROY-PROCESS).
+  (sb-thread:with-mutex (*all-processes-lock*)
+    *all-processes*))
+
+(defun process-yield ()
+  (sb-thread:thread-yield))
+
+(defun process-wait (reason predicate)
+  (let ((old-state (process-whostate *current-process*)))
+    (unwind-protect
+	 (progn
+	   (setf old-state (process-whostate *current-process*)
+		 (process-whostate *current-process*) reason)
+	   (until (funcall predicate)
+	     (process-yield)))
+      (setf (process-whostate *current-process*) old-state))))
+
+(defun process-wait-with-timeout (reason timeout predicate)
+  (let ((old-state (process-whostate *current-process*))
+	(end-time (+ (get-universal-time) timeout)))
+    (unwind-protect
+	 (progn
+	   (setf old-state (process-whostate *current-process*)
+		 (process-whostate *current-process*) reason)
+	   (loop 
+	      for result = (funcall predicate)
+	      until (or result
+			(> (get-universal-time) end-time))
+	      do (process-yield)
+	      finally (return result)))
+      (setf (process-whostate *current-process*) old-state))))
+
+(defun process-interrupt (process function)
+  (sb-thread:interrupt-thread (process-thread process) function))
+
+(defun disable-process (process)
+  (sb-thread:interrupt-thread
+   (process-thread process)
+   (lambda ()
+     (catch 'interrupted-wait (get-mutex *permanent-queue*)))))
+
+(defun enable-process (process)
+  (sb-thread:interrupt-thread
+   (process-thread process) (lambda () (throw 'interrupted-wait nil))))
+
+(defmacro without-scheduling (&body body)
+  (declare (ignore body))
+  (error "WITHOUT-SCHEDULING is not supported on this platform."))
+
+(defparameter *atomic-lock*
+  (sb-thread:make-mutex :name "atomic incf/decf"))
+
+(defmacro atomic-incf (place)
+  `(sb-thread:with-mutex (*atomic-lock*)
+    (incf ,place)))
+
+(defmacro atomic-decf (place) 
+  `(sb-thread:with-mutex (*atomic-lock*)
+    (decf ,place)))
+
+;;; 32.3 Locks
+
+(defun make-lock (&optional name)
+  (sb-thread:make-mutex :name name))
+
+(defmacro with-lock-held ((place &key state (wait t) timeout) &body body)
+  (declare (ignore timeout))
+  (let ((old-state (gensym "OLD-STATE")))
+    `(sb-thread:with-mutex (,place :wait-p ,wait)
+       (let (,old-state)
+	 (unwind-protect
+	      (progn
+		(when ,state
+		  (setf ,old-state (process-state *current-process*))
+		  (setf (process-state *current-process*) ,state))
+		,@body)
+	   (setf (process-state *current-process*) ,old-state))))))
+
+
+(defun make-recursive-lock (&optional name)
+  (sb-thread:make-mutex :name name))
+
+(defmacro with-recursive-lock-held ((place &optional state (wait t) timeout) &body body)
+  (declare (ignore wait timeout))
+  (let ((old-state (gensym "OLD-STATE")))
+  `(sb-thread:with-recursive-lock (,place)
+    (let (,old-state)
+      (unwind-protect
+	   (progn
+	     (when ,state
+	       (setf ,old-state (process-state *current-process*))
+	       (setf (process-state *current-process*) ,state))
+	     ,@body)
+	(setf (process-state *current-process*) ,old-state))))))
+
+(defun make-condition-variable () (sb-thread:make-waitqueue))
+
+(defun condition-wait (cv lock &optional timeout)
+  (if timeout
+      (handler-case 
+	  (sb-ext:with-timeout timeout
+	    (sb-thread:condition-wait cv lock)
+	    t)
+	(sb-ext:timeout (c)
+	  (declare (ignore c))
+	  nil))
+      (progn (sb-thread:condition-wait cv lock) t)))
+
+(defun condition-notify (cv)
+  (sb-thread:condition-notify cv))
+
+
+(defvar *process-plists* (make-hash-table)
+  "Hash table mapping processes to a property list.  This is used by
+PROCESS-PLIST.")
+
+(defun process-property-list (process)
+  (gethash process *process-plists*))
+
+(defun (setf process-property-list) (value process)
+  (setf (gethash process *process-plists*) value))
+
+(defun process-execute (process function)
+  (setf (process-function process) function)
+  (restart-process process))
+
+(defun process-alive-p (process)
+  (sb-thread:thread-alive-p (process-thread process)))
diff --git a/third_party/lisp/sclf/package.lisp b/third_party/lisp/sclf/package.lisp
new file mode 100644
index 000000000000..652194f93cad
--- /dev/null
+++ b/third_party/lisp/sclf/package.lisp
@@ -0,0 +1,258 @@
+;;;  package.lisp --- packages description
+
+;;;  Copyright (C) 2006, 2007, 2008, 2009, 2010 by Walter C. Pelissero
+;;;  Copyright (C) 2021 by the TVL Authors
+
+;;;  Author: Walter C. Pelissero <walter@pelissero.de>
+;;;  Project: sclf
+
+#+cmu (ext:file-comment "$Module: package.lisp $")
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public License
+;;; as published by the Free Software Foundation; either version 2.1
+;;; of the License, or (at your option) any later version.
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free
+;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+;;; 02111-1307 USA
+
+(in-package :cl-user)
+
+(defpackage :sclf
+  (:use :common-lisp
+	;; we need the MOP for lazy.lisp and serial.lisp
+	#+cmu :pcl
+	#+sbcl :sb-mop)
+  ;; Don't know why but compute-effective-slot-definition-initargs is
+  ;; internal in both CMUCL and SBCL
+  (:import-from #+cmu"PCL" #+sbcl"SB-PCL"
+		#-(or cmu sbcl) "CLOS"
+		"COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS")
+  #+cmu (:import-from :mp
+		      #:make-process
+		      #:current-process
+		      #:all-processes
+		      #:processp
+		      #:process-name
+		      #:process-state
+		      #:process-whostate
+		      #:process-wait
+		      #:process-wait-with-timeout
+		      #:process-yield
+		      #:process-interrupt
+		      #:disable-process
+		      #:enable-process
+		      #:without-scheduling
+		      #:atomic-incf
+		      #:atomic-decf
+		      #:process-property-list)
+  (:export #:be #:be*
+	   #:defconst
+	   #:with-gensyms
+	   #:d+
+	   #:s+
+	   #:f++
+	   #:list->string
+	   #:string-starts-with #:string-ends-with
+	   #:aif #:awhen #:acond #:aand #:acase #:it
+	   #:+whitespace+
+	   #:string-trim-whitespace
+	   #:string-right-trim-whitespace
+	   #:string-left-trim-whitespace
+	   #:whitespace-p #:seq-whitespace-p
+	   #:not-empty
+	   #:position-any
+	   #:+month-names+
+	   #:find-any
+	   #:split-at
+	   #:split-string-at-char
+	   #:week-day->string
+	   #:month->string
+	   #:month-string->number
+	   #:add-months #:add-days
+	   #:read-whole-stream
+	   #:read-file #:write-file #:read-lines
+	   #:read-from-file #:write-to-file
+	   #:string-concat
+	   #:gcase
+	   #:string-truncate
+	   #:promise #:force #:forced-p #:lazy #:deflazy #:lazy-metaclass #:self #:reset-lazy-slots
+	   #:copy-stream #:copy-file
+	   #:symlink-file
+	   #:keywordify
+	   #:until
+	   #:year #:month #:day #:hour #:minute #:week-day #:week #:day-of-the-year
+	   #:beginning-of-week #:end-of-week
+	   #:next-week-day #:next-monday #:full-weeks-in-span
+	   #:beginning-of-first-week #:end-of-last-week
+	   #:beginning-of-month #:end-of-month
+	   #:locate-system-program
+	   #:*tmp-file-defaults*
+	   #:temp-file-name
+	   #:open-temp-file
+	   #:with-temp-file
+	   #:file-size
+	   #:getenv
+	   #:with-system-environment
+	   #:time-string #:iso-time-string #:parse-iso-time-string
+	   #:soundex
+	   #:string-soundex=
+	   #:lru-cache
+	   #:getcache #:cached
+	   #:print-time-span
+	   #:double-linked-list #:limited-list #:sorted-list
+	   #:insert #:size
+	   #:heap #:heap-add #:heap-pop #:heap-empty-p
+	   #:double-linked-element #:make-double-linked-element #:double-linked-element-p
+	   #:dle-previous #:dle-next #:dle-value
+	   #:cons-dle #:dle-remove #:dle-map #:do-dle :do-dle*
+	   #:sl-map #:do-dll #:do-dll*
+	   #:dll-find #:dll-find-cursor
+	   #:push-first #:push-last #:dll-remove
+	   #:pop-first #:pop-last
+	   #:leap-year-p #:last-day-of-month
+	   #:getuid #:setuid #:with-euid
+	   #:get-logname #:get-user-name #:get-user-home #:find-uid
+	   #:super-user-p
+	   #:pathname-as-directory #:pathname-as-file
+	   #:alist->plist #:plist->alist
+	   #:byte-vector->string
+	   #:string->byte-vector
+	   #:outdated-p
+	   #:with-hidden-temp-file
+	   #:let-places #:let-slots
+	   #:*decimal-point*
+	   #:*thousands-comma*
+	   #:format-amount #:parse-amount
+	   #:with-package
+	   #:make-directory #:ensure-directory
+	   #:make-temp-directory
+	   #:with-temp-directory
+	   #:delete-directory
+	   #:delete-directory-tree
+	   #:do-directory-tree
+	   #:traverse-directory-tree
+	   #:empty-directory-p
+	   #:remove-empty-directories
+	   #:map-directory-tree
+	   #:find-files
+	   #:directory-p
+	   #:regular-file-p
+	   #:file-readable-p
+	   #:file-writable-p
+	   #:file-executable-p
+	   #:current-directory
+	   #:ensure-home-translations
+	   #:list-directory
+	   #:string-escape
+	   #:string-substitute
+	   #:bytes-simple-string
+	   #:make-lock-files
+	   #:with-lock-files
+	   #:getpid
+	   #:on-error
+	   #:floor-to
+	   #:round-to
+	   #:ceiling-to
+	   #:insert-in-order
+	   #:forget-documentation
+	   #:load-compiled
+	   #:swap
+	   #:queue #:make-queue #:queue-append #:queue-pop #:queue-empty-p
+	   #:unix-stat #:unix-file-stat
+	   #:stat-device
+	   #:stat-inode
+	   #:stat-links
+	   #:stat-atime
+	   #:stat-mtime
+	   #:stat-ctime
+	   #:stat-birthtime
+	   #:stat-size
+	   #:stat-blksize
+	   #:stat-blocks
+	   #:stat-uid
+	   #:stat-gid
+	   #:stat-mode
+	   #:save-file-excursion
+	   #:stat-modification-time
+	   #:stat-creation-time
+	   #:file-modification-time
+	   #:file-creation-time
+	   #:show
+	   #:memoize-function
+	   #:memoized
+	   #:defun-memoized
+	   #:parse-native-namestring
+	   #:native-file-namestring
+	   #:native-namestring
+	   #:native-pathname
+	   #:read-symbolic-link
+	   #:symbolic-link-p
+	   #:broken-link-p
+	   #:circular-list
+	   #:last-member
+	   #:glob->regex
+	   #:universal->unix-time #:unix->universal-time
+	   #:get-unix-time
+	   #:move-file
+
+	   ;; sysproc.lisp
+	   #:*run-verbose*
+	   #:run-pipe
+	   #:run-program
+	   #:run-shell-command
+	   #:run-async-shell-command
+	   #:exit-code
+	   #:with-open-pipe
+	   #:*bourne-shell*
+	   #:sysproc-kill
+	   #:sysproc-input
+	   #:sysproc-output
+	   #:sysproc-alive-p
+	   #:sysproc-pid
+	   #:sysproc-p
+	   #:sysproc-wait
+	   #:sysproc-exit-code
+	   #:sysproc-set-signal-callback
+
+	   ;; MP
+	   #:make-process
+	   #:destroy-process
+	   #:current-process
+	   #:all-processes
+	   #:processp
+	   #:process-name
+	   #:process-state
+	   #:process-whostate
+	   #:process-wait
+	   #:process-wait-with-timeout
+	   #:process-yield
+	   #:process-interrupt
+	   #:disable-process
+	   #:enable-process
+	   #:restart-process
+	   #:without-scheduling
+	   #:atomic-incf
+	   #:atomic-decf
+	   #:process-property-list
+	   #:process-alive-p
+	   #:process-join
+	   ;;
+	   #:make-lock
+	   #:with-lock-held
+	   #:make-recursive-lock
+	   #:with-recursive-lock-held
+	   ;;
+	   #:make-condition-variable
+	   #:condition-wait
+	   #:condition-notify
+	   #:process-property-list
+	   #:process-execute
+	   ;; mop.lisp
+	   #:printable-object-mixin
+	   ))
diff --git a/third_party/lisp/sclf/sclf.asd b/third_party/lisp/sclf/sclf.asd
new file mode 100644
index 000000000000..dfb56a8ded0e
--- /dev/null
+++ b/third_party/lisp/sclf/sclf.asd
@@ -0,0 +1,58 @@
+;;;  sclf.asd --- system definition
+
+;;;  Copyright (C) 2005, 2006, 2008, 2009 by Walter C. Pelissero
+;;;  Copyright (C) 2021 by the TVL Authors
+
+;;;  Author: Walter C. Pelissero <walter@pelissero.de>
+;;;  Project: SCLF
+
+#+cmu (ext:file-comment "$Module: sclf.asd, Time-stamp: <2013-06-17 15:32:29 wcp> $")
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public License
+;;; as published by the Free Software Foundation; either version 2.1
+;;; of the License, or (at your option) any later version.
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free
+;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+;;; 02111-1307 USA
+
+(in-package :cl-user)
+
+(defpackage :sclf-system
+  (:use :common-lisp :asdf #+asdfa :asdfa))
+
+(in-package :sclf-system)
+
+(defsystem sclf
+    :name "SCLF"
+    :author "Walter C. Pelissero <walter@pelissero.de>"
+    :maintainer "Walter C. Pelissero <walter@pelissero.de>"
+    ;; :version "0.0"
+    :description "Stray Common Lisp Functions"
+    :long-description
+    "A collection of Common Lisp functions for the most disparate
+uses, too small to fit anywhere else."
+    :licence "LGPL"
+    :depends-on (#+sbcl :sb-posix)
+    :components
+    ((:doc-file "README")
+     (:file "package")
+     (:file "sclf" :depends-on ("package"))
+     (:file "sysproc" :depends-on ("package" "sclf"))
+     (:file "lazy" :depends-on ("package" "sclf"))
+     (:file "time" :depends-on ("package" "sclf"))
+     (:file "directory" :depends-on ("package" "sclf" "time"))
+     (:file "serial" :depends-on ("package" "sclf"))
+     (:module "mp"
+	      :depends-on ("package" "sclf")
+	      :components
+	      ((:doc-file "README")
+	       (:file #.(first
+			 (list #+cmu "cmu"
+			       #+sbcl "sbcl"
+			       "unknown")))))))
diff --git a/third_party/lisp/sclf/sclf.lisp b/third_party/lisp/sclf/sclf.lisp
new file mode 100644
index 000000000000..0d587da8eb69
--- /dev/null
+++ b/third_party/lisp/sclf/sclf.lisp
@@ -0,0 +1,1717 @@
+;;;  sclf.lisp --- miscellanea
+
+;;;  Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010 by Walter C. Pelissero
+
+;;;  Author: Walter C. Pelissero <walter@pelissero.de>
+;;;  Project: SCLF
+
+#+cmu (ext:file-comment "$Module: sclf.lisp $")
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public License
+;;; as published by the Free Software Foundation; either version 2.1
+;;; of the License, or (at your option) any later version.
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free
+;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+;;; 02111-1307 USA
+
+;;;  Commentary:
+
+;;; This is a collection of Common Lisp functions of the most disparate
+;;; uses and purposes.  These functions are too small or too unrelated
+;;; to each other to deserve an own module.
+;;;
+;;; If you want to indent properly the following macros you should add
+;;; the following lines to your .emacs file:
+;;;
+;;; (defun cl-indent-be (path state indent-point sexp-column normal-indent)
+;;;   (let ((sexp-start (cadr state))
+;;; 	(i 0))
+;;;     (save-excursion
+;;;       (goto-char sexp-start)
+;;;       (forward-char)
+;;;       (+ sexp-column
+;;; 	 (block indentation
+;;; 	   (condition-case nil
+;;; 	       (while (< (point) indent-point)
+;;; 		 (setq i (1+ i))
+;;; 		 (when (and (= 0 (logand i 1))
+;;; 			    (looking-at "[\t\n ]*\\s("))
+;;; 		   (return-from indentation 2))
+;;; 		 (forward-sexp))
+;;; 	     (error nil))
+;;; 	   (if (= 1 (logand i 1))
+;;; 	       6 4))))))
+;;;
+;;; (put 'be 'common-lisp-indent-function 'cl-indent-be)
+;;; (put 'be* 'common-lisp-indent-function 'cl-indent-be)
+;;; (put 'awhen 'lisp-indent-function 1)
+;;; (put 'gcase 'lisp-indent-function 1)
+;;; (put 'acase 'lisp-indent-function 1)
+;;; (put 'acond 'lisp-indent-function 1)
+;;; (put 'until 'lisp-indent-function 1)
+
+
+
+(cl:in-package :sclf)
+
+(defmacro be (&rest bindings-and-body)
+  "Less-parenthetic let."
+  (let ((bindings
+	 (loop
+	    while (and (symbolp (car bindings-and-body))
+		       (cdr bindings-and-body))
+	    collect (list (pop bindings-and-body)
+			  (pop bindings-and-body)))))
+    `(let ,bindings
+       ,@bindings-and-body)))
+
+(defmacro be* (&rest bindings-and-body)
+  "Less-parenthetic let*."
+  (let ((bindings
+	 (loop
+	    while (and (symbolp (car bindings-and-body))
+		       (cdr bindings-and-body))
+	    collect (list (pop bindings-and-body)
+			  (pop bindings-and-body)))))
+    `(let* ,bindings
+       ,@bindings-and-body)))
+
+(defmacro defconst (name value &rest etc)
+  "For some reason SBCL, between usefulness and adherence to the ANSI
+standard, has chosen the latter, thus rendering the DEFCONSTANT pretty
+useless.  This macro works around that problem."
+  #+sbcl (list* 'defvar name value etc)
+  #-sbcl (list* 'defconstant name value etc))
+
+(defmacro with-gensyms ((&rest symbols) &body body)
+  "Gensym all SYMBOLS and make them available in BODY.
+See also LET-GENSYMS."
+  `(let ,(mapcar #'(lambda (s)
+		     (list s '(gensym))) symbols)
+     ,@body))
+
+(defun s+ (&rest strings)
+  "Return a string which is made of the concatenation of STRINGS."
+  (apply #'concatenate 'string strings))
+
+(defun string-starts-with (prefix string &optional (compare #'string=))
+  (be prefix-length (length prefix)
+    (and (>= (length string) prefix-length)
+	 (funcall compare prefix string :end2 prefix-length))))
+
+(defun string-ends-with (postfix string &optional (compare #'string=))
+  "Return true if STRING's last characters are the same as POSTFIX."
+  (be postfix-length (length postfix)
+      string-length (length string)
+    (and (>= string-length postfix-length)
+	 (funcall compare postfix string :start2 (- string-length postfix-length)))))
+
+(defun string-substitute (from to sequence &key (start 0) end (test #'eql))
+  "Replace in SEQUENCE occurrences of FROM with TO.  FROM and TO don't
+need to be the same length."
+  (be from-length (length from)
+    (with-output-to-string (out)
+      (write-string sequence out :start 0 :end start)
+      (loop
+	 for position = (search from sequence :start2 start :end2 end :test test)
+	 while position
+	 do
+	   (write-string sequence out :start start :end position)
+	   (write-string to out)
+	   (setf start (+ position from-length))
+	 finally (write-string (subseq sequence start) out)))))
+
+(defun string-escape (string character &key (escape-character #\\) (escape-escape t))
+  "Prepend all occurences of CHARACTER in STRING with a
+ESCAPE-CHARACTER."
+  (with-output-to-string (stream)
+    (loop
+       for c across string
+       when (or (char= c character)
+		(and escape-escape
+		     (char= c escape-character)))
+       do (write-char escape-character stream)
+       do (write-char c stream))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defmacro aif (test then &optional else)
+  `(be it ,test
+     (if it
+	 ,then
+	 ,else)))
+
+(defmacro awhen (test &body then)
+  `(be it ,test
+     (when it
+       ,@then)))
+
+(defmacro acond (&body forms)
+  (when forms
+    `(aif ,(caar forms)
+	  (progn ,@(cdar forms))
+	  (acond ,@(cdr forms)))))
+
+(defmacro aand (&rest args)
+  (cond ((null args) t)
+	((null (cdr args)) (car args))
+	(t `(aif ,(car args) (aand ,@(cdr args))))))
+
+(defmacro acase (condition &body forms)
+  `(be it ,condition
+     (case it ,@forms)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defconst +whitespace+ '(#\return #\newline #\tab #\space #\page))
+
+(defun string-trim-whitespace (string)
+  (string-trim +whitespace+ string))
+
+(defun string-right-trim-whitespace (string)
+  (string-right-trim +whitespace+ string))
+
+(defun string-left-trim-whitespace (string)
+  (string-left-trim +whitespace+ string))
+
+(defun whitespace-p (char)
+  (member char +whitespace+))
+
+(defun seq-whitespace-p (sequence)
+  (every #'whitespace-p sequence))
+
+(defun not-empty (sequence)
+  "Return SEQUENCE if it's not empty, otherwise NIL.
+NIL is indeed empty."
+  (when (or (listp sequence)
+	    (not (zerop (length sequence))))
+      sequence))
+
+(defun position-any (bag sequence &rest position-args)
+  "Find any element of bag in sequence and return its position.
+Accept any argument accepted by the POSITION function."
+  (apply #'position-if #'(lambda (element)
+			   (find element bag)) sequence position-args))
+
+(defun find-any (bag sequence &rest find-args)
+  "Find any element of bag in sequence.  Accept any argument
+accepted by the FIND function."
+  (apply #'find-if #'(lambda (element)
+			   (find element bag)) sequence find-args))
+
+(defun split-at (bag sequence &key (start 0) key)
+  "Split SEQUENCE at occurence of any element from BAG.
+Contiguous occurences of elements from BAG are considered atomic;
+so no empty sequence is returned."
+  (be len (length sequence)
+    (labels ((split-from (start)
+	       (unless (>= start len)
+		 (be sep (position-any bag sequence :start start :key key)
+		   (cond ((not sep)
+			  (list (subseq sequence start)))
+			 ((> sep start)
+			  (cons (subseq sequence start sep)
+				(split-from (1+ sep))))
+			 (t
+			  (split-from (1+ start))))))))
+      (split-from start))))
+
+(defun split-string-at-char (string separator &key escape skip-empty)
+  "Split STRING at SEPARATORs and return a list of the substrings.  If
+SKIP-EMPTY is true then filter out the empty substrings.  If ESCAPE is
+not nil then split at SEPARATOR only if it's not preceded by ESCAPE."
+  (declare (type string string) (type character separator))
+  (labels ((next-separator (beg)
+             (be pos (position separator string :start beg)
+	       (if (and escape
+			pos
+			(plusp pos)
+			(char= escape (char string (1- pos))))
+		   (next-separator (1+ pos))
+		   pos)))
+           (parse (beg)
+             (cond ((< beg (length string))
+                    (let* ((end (next-separator beg))
+                           (substring (subseq string beg end)))
+                      (cond ((and skip-empty (string= "" substring))
+                             (parse (1+ end)))
+                            ((not end)
+                             (list substring))
+                            (t
+			     (cons substring (parse (1+ end)))))))
+                   (skip-empty
+		    '())
+                   (t
+		    (list "")))))
+    (parse 0)))
+
+(defun copy-stream (in out)
+  (loop
+     for c = (read-char in nil)
+     while c
+     do (write-char c out)))
+
+(defun pathname-as-file (pathname)
+  "Converts PATHNAME to file form and return it."
+  (unless (pathnamep pathname)
+    (setf pathname (pathname pathname)))
+  (cond ((pathname-name pathname)
+	 pathname)
+	((stringp (car (last (pathname-directory pathname))))
+	 (be name (parse-native-namestring (car (last (pathname-directory pathname))))
+	   (make-pathname :directory (butlast (pathname-directory pathname))
+			  :name (pathname-name name)
+			  :type (pathname-type name)
+			  :defaults pathname)))
+	;; it can't be done?
+	(t pathname)))
+
+(defun copy-file (file copy-file &key (if-exists :error))
+  (with-open-file (in file)
+    (with-open-file (out copy-file :direction :output :if-exists if-exists)
+      (copy-stream in out))))
+
+(defun symlink-file (src dst &key (if-exists :error))
+  (when (and (eq :supersede if-exists)
+	     (probe-file dst))
+    (delete-file dst))
+  #+sbcl (sb-posix:symlink src dst)
+  #+cmu(unix:unix-symlink (native-namestring src) (native-namestring dst))
+  #-(or sbcl cmu) (error "don't know how to symlink files"))
+
+(defun read-whole-stream (stream)
+  "Read stream until the end and return it as a string."
+  (with-output-to-string (string)
+    (loop
+       for line = (read-line stream nil)
+       while line
+       do (write-line line string))))
+
+(defun read-lines (stream &optional n)
+  "Read N lines from stream and return them as a list of strings.  If
+N is NIL, read the whole stream til the end.  If the stream ends
+before N lines a read, this function will return those without
+signalling an error."
+  (loop
+     for line = (read-line stream nil)
+     for i from 0
+     while (and line
+		(or (not n)
+		    (< i n)))
+     collect line))
+
+(defun read-file (pathname &key (element-type 'character) (if-does-not-exist :error) default)
+  "Read the whole content of file and return it as a sequence which
+can be a string, a vector of bytes, or whatever you specify as
+ELEMENT-TYPE."
+  (with-open-file (in pathname
+		      :element-type element-type
+		      :if-does-not-exist (unless (eq :value if-does-not-exist)
+					   :error))
+    (if in
+	(be seq (make-array (file-length in) :element-type element-type)
+	  (read-sequence seq in)
+	  seq)
+	default)))
+
+(defun write-file (pathname contents &key (if-exists :error))
+  "Read the whole content of file and return it as a sequence which
+can be a string, a vector of bytes, or whatever you specify as
+ELEMENT-TYPE."
+  (with-open-file (out pathname
+		       :element-type (if (stringp contents)
+					 'character
+					 (array-element-type contents))
+		       :if-exists if-exists)
+    (write-sequence contents out)))
+
+(defun read-from-file (pathname &key (on-error :error) default)
+  "Similar to READ-FROM-STRING but for files.  Read the first Lisp
+object in file and return it.  If file does not exist or does not
+contain a readable Lisp object, ON-ERROR tells what to do.  If
+ON-ERROR is :ERROR, an error is signalled.  If ON-ERROR is :VALUE,
+DEFAULT is returned."
+  (ecase on-error
+    (:error
+     (with-open-file (in pathname)
+       (read in)))
+    (:value
+     (handler-case (with-open-file (in pathname)
+		     (read in))
+       (t ()
+	 default)))))
+
+(defun write-to-file (object pathname &key (if-exists :error) pretty)
+  "Similar to WRITE-TO-STRING but for files.  Write OBJECT to a file
+with pathname PATHNAME."
+  (with-open-file (out pathname :direction :output :if-exists if-exists)
+    (write object :stream out :escape t :readably t :pretty pretty)))
+
+(defun string-concat (list &optional (separator ""))
+  "Concatenate the strings in LIST interposing SEPARATOR (default
+nothing) between them."
+  (reduce #'(lambda (&rest args)
+	      (if args
+		  (s+ (car args) separator (cadr args))
+		  ""))
+	  list))
+
+;; to indent it properly: (put 'gcase 'lisp-indent-function 1)
+(defmacro gcase ((value &optional (test 'equalp)) &rest cases)
+  "Generic CASE macro.  Match VALUE to CASES as if by the normal CASE
+but use TEST as the comparison function, which defaults to EQUALP."
+  (with-gensyms (val)
+    `(be ,val ,value
+       ,(cons 'cond
+	      (mapcar #'(lambda (case-desc)
+			  (destructuring-bind (vals &rest forms) case-desc
+			    `(,(cond ((consp vals)
+				      (cons 'or (mapcar #'(lambda (v)
+							    (list test val v))
+							vals)))
+				     ((or (eq vals 'otherwise)
+					  (eq vals t))
+				      t)
+				     (t (list test val vals)))
+			       ,@forms)))
+		      cases)))))
+
+(defun string-truncate (string max-length)
+  "If STRING is longer than MAX-LENGTH, return a shorter version.
+Otherwise return the same string unchanged."
+  (if (> (length string) max-length)
+      (subseq string 0 max-length)
+      string))
+
+;; to indent properly: (put 'until 'lisp-indent-function 1)
+(defmacro until (test &body body)
+  (with-gensyms (result)
+    `(loop
+	for ,result = ,test
+	until ,result
+	do (progn ,@body)
+	finally (return ,result))))
+
+(defun keywordify (string)
+  (intern (string-upcase string) :keyword))
+
+(defun locate-system-program (name)
+  "Given the NAME of a system program try to find it through the
+search of the environment variable PATH.  Return the full
+pathname."
+  (loop
+     for dir in (split-string-at-char (getenv "PATH") #\:)
+     for pathname = (merge-pathnames name (pathname-as-directory dir))
+     when (probe-file pathname)
+     return pathname))
+
+(defvar *tmp-file-defaults* #P"/tmp/")
+
+(defun temp-file-name (&optional (default *tmp-file-defaults*))
+  "Create a random pathname based on DEFAULT.  No effort is made
+to make sure that the returned pathname doesn't identify an
+already existing file.  If missing DEFAULT defaults to
+*TMP-FILE-DEFAULTS*."
+  (make-pathname :defaults default
+		 :name (format nil "~36R" (random #.(expt 36 10)))))
+
+(defun open-temp-file (&optional default-pathname &rest open-args)
+  "Open a new temporary file and return a stream to it.  This function
+makes sure the pathname of the temporary file is unique.  OPEN-ARGS
+are arguments passed verbatim to OPEN.  If OPEN-ARGS specify
+the :DIRECTION it should be either :OUTPUT (default) or :IO;
+any other value causes an error.  If DEFAULT-PATHNAME is specified and
+not NIL it's used as defaults to produce the pathname of the temporary
+file, otherwise *TMP-FILE-DEFAULTS* is used."
+  (unless default-pathname
+    (setf default-pathname *tmp-file-defaults*))
+  ;; if :DIRECTION is specified check that it's compatible with the
+  ;; purpose of this function, otherwise make it default to :OUTPUT
+  (aif (getf open-args :direction)
+       (unless (member it '(:output :io))
+	 (error "Can't create temporary file with open direction ~A." it))
+       (setf open-args (append '(:direction :output)
+			       open-args)))
+  (do* ((name #1=(temp-file-name default-pathname) #1#)
+	(stream #2=(apply #'open  name
+			  :if-exists nil
+			  :if-does-not-exist :create
+			  open-args) #2#))
+       (stream stream)))
+
+(defmacro with-temp-file ((stream &rest open-temp-args) &body body)
+  "Execute BODY within a dynamic extent where STREAM is bound to
+a STREAM open on a unique temporary file name.  OPEN-TEMP-ARGS are
+passed verbatim to OPEN-TEMP-FILE."
+  `(be ,stream (open-temp-file ,@open-temp-args)
+     (unwind-protect
+	  (progn ,@body)
+       (close ,stream)
+       ;; body may decide to rename the file so we must ignore the errors
+       (ignore-errors
+	 (delete-file (pathname ,stream))))))
+
+(defmacro with-hidden-temp-file ((stream &rest open-args) &body body)
+  "Just like WITH-TEMP-FILE but unlink (delete) the temporary file
+before the execution of BODY.  As such BODY won't be able to
+manipulate the file but through STREAM, and no other program is able
+to see it.  Once STREAM is closed the temporary file blocks are
+automatically relinquished by the operating system.  This works at
+least on Unix filesystems.  I don't know about MS-OSs where the system
+may likely decide to crash, take all your data with it and, in the
+meanwhile, report you to the NSA as terrorist."
+  `(be ,stream (open-temp-file ,@open-args)
+     (unwind-protect
+	  (progn (delete-file (pathname ,stream))
+		 ,@body)
+       (close ,stream))))
+
+(defun insert-in-order (item seq &key (test #'<) key)
+  "Destructively insert ITEM in LIST in order by TEST.  Return
+the new list.  This is a simple wrapper around MERGE."
+  (merge (if seq
+	     (type-of seq)
+	     'list)
+	 (list item) seq test :key key))
+
+(defmacro f++ (x &optional (delta 1))
+  "Same as INCF but hopefully optimised for fixnums."
+  `(setf ,x (+ (the fixnum ,x) (the fixnum ,delta))))
+
+(defun soundex (word &optional (key-length 4))
+  "Knuth's Soundex algorithm.  Returns a string representing the
+sound of a certain word (English).  Different words will thus
+yield the same output string.  To compare two string by the
+sound, simply do:
+
+   (string= (soundex str1) (soundex str2))
+
+Examples:
+
+   (soundex \"Knuth\") => \"K530\"
+   (soundex \"Kant\") => \"K530\"
+   (soundex \"Lloyd\") => \"L300\"
+   (soundex \"Ladd\") => \"L300\""
+  (declare (type string word))
+  (flet ((translate-char (char)
+	   (awhen (position char "BFPVCGJKQSXZDTLMNR")
+	     (elt "111122222222334556" it))))
+    (let ((key (make-string key-length :initial-element #\0))
+	  (word-length (length word)))
+      (setf (elt key 0) (elt word 0))
+      (loop
+	 with previous-sound = (translate-char (char-upcase (elt word 0)))
+	 with j = 1
+	 for i from 1 by 1 below word-length
+	 for c = (char-upcase (elt word i))
+	 while (< j key-length)
+	 do (be sound (translate-char c)
+	      (cond ((not (eq sound previous-sound))
+		     (unless (member c '(#\H #\W))
+		       (setf previous-sound sound))
+		     (when sound
+		       (setf (elt key j) sound)
+		       (incf j))))))
+      key)))
+
+(defun string-soundex= (string1 string2)
+  (let ((l1 (split-at +whitespace+ string1))
+	(l2 (split-at +whitespace+ string2)))
+    (and (= (length l1) (length l2))
+	 (every #'string= (mapcar #'soundex l1) (mapcar #'soundex l2)))))
+
+#+(OR)
+(defun soundex-test ()
+  (let* ((words1 '("Euler" "Gauss" "Hilbert" "Knuth" "Lloyd" "Lukasiewicz" "Wachs"))
+	 (words2 '("Ellery" "Ghosh" "Heilbronn" "Kant" "Ladd" "Lissajous" "Waugh"))
+	 (results '("E460" "G200" "H416" "K530" "L300" "L222" "W200")))
+    (mapc #'(lambda (w1 w2 r)
+	      (let ((r1 (soundex w1))
+		    (r2 (soundex w2)))
+		(format t "~A = ~A, ~A = ~A => ~A~%" w1 r1 w2 r2
+			(if (and (string= r1 r2)
+				 (string= r r1))
+			    "OK"
+			    (format nil "ERROR (expected ~A)" r)))))
+	  words1 words2 results)
+    (values)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; (defstruct cache-slot ()
+;;   ((previous :type (or cache-slot null)
+;; 	     :initarg :previous
+;; 	     :initform nil
+;; 	     :accessor cslot-previous)
+;;    (key :initarg :key
+;; 	:accessor cslot-key)
+;;    (value :initarg :value
+;; 	  :accessor cslot-value)
+;;    (next :type (or cache-slot null)
+;; 	 :initarg :next
+;; 	 :initform nil
+;; 	 :accessor cslot-next)))
+
+;; (defmethod print-object ((object cache-slot) stream)
+;;   (print-unreadable-object (object stream :type t)
+;;     (if (slot-boundp object 'key)
+;; 	(format stream "key=~S, value=~S" (cslot-key object) (cslot-value object))
+;; 	(format stream "NULL"))))
+
+
+(defstruct (double-linked-element (:conc-name dle-))
+  (previous nil :type (or double-linked-element null))
+  value
+  (next nil :type (or double-linked-element null)))
+
+(defmethod print-object ((object double-linked-element) stream)
+  (print-unreadable-object (object stream :type t)
+    (format stream "value=~S" (dle-value object))))
+
+(defun cons-dle (value previous next)
+  (declare (type (or double-linked-element null) previous next))
+  (be new-element (make-double-linked-element :previous previous :next next :value value)
+    (when previous
+      (setf (dle-next previous) new-element))
+    (when next
+      (setf (dle-previous next) new-element))
+    new-element))
+
+(defun dle-remove (dle-object)
+  "Remove the DLE-OBJECT from its current position in the list of
+elements agjusting the pointer of dle-objects before and after this
+one (if any)."
+  (declare (type double-linked-element dle-object))
+  (awhen (dle-next dle-object)
+    (setf (dle-previous it) (dle-previous dle-object)))
+  (awhen (dle-previous dle-object)
+    (setf (dle-next it) (dle-next dle-object))))
+
+(defun dle-map (function dle-object)
+  (when dle-object
+    (make-double-linked-element :value (funcall function (dle-value dle-object))
+				:previous (dle-previous dle-object)
+				:next (dle-map function (dle-next dle-object)))))
+
+(defmacro do-dle ((var dle &optional (result nil)) &body body)
+  "Iterate over a list of DOUBLE-LINKED-ELEMENTs and map body to
+each element's value.  Bind VAR to the value on each iteration."
+  (be cursor (gensym)
+    `(do ((,cursor ,dle (dle-next ,cursor)))
+	 ((not ,cursor) ,result)
+       (be ,var (dle-value ,cursor)
+	 ,@body))))
+
+(defmacro do-dle* ((var dle &optional (result nil)) &body body)
+  "Same as DO-DLE but VAR is a symbol macro, so that BODY can
+modify the element's value."
+  (be cursor (gensym)
+    `(symbol-macrolet ((,var (dle-value ,cursor)))
+       (do ((,cursor ,dle (dle-next ,cursor)))
+	   ((not ,cursor) ,result)
+	 ,@body))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defclass double-linked-list ()
+  ((elements :type double-linked-element
+	     :documentation "The actual list of elements held by this object.")
+   (last-element :type double-linked-element))
+  (:documentation
+   "A double linked list where elements can be added or removed
+from either end."))
+
+(defmethod initialize-instance ((object double-linked-list) &rest rest)
+  (declare (ignorable rest))
+  (call-next-method)
+  (with-slots (last-element elements) object
+    (setf last-element (make-double-linked-element)
+	  elements last-element)))
+
+(defmethod print-object ((object double-linked-list) stream)
+  (print-unreadable-object (object stream :type t)
+    (be elements '()
+      (do-dle (e (slot-value object 'elements))
+	(push e elements))
+      (format stream "elements=~S" (nreverse elements)))))
+
+(defgeneric pop-first (double-linked-list)
+  (:documentation
+   "Pop the first element of a double-linked-list."))
+(defgeneric pop-last (double-linked-list)
+  (:documentation
+   "Pop the last element of a double-linked-list."))
+(defgeneric push-first (item double-linked-list)
+  (:documentation
+   "Push an item in front of a double-linked-list."))
+(defgeneric push-last (item double-linked-list)
+  (:documentation
+   "Append an item to a double-linked-list."))
+(defgeneric list-map (function double-linked-list)
+  (:documentation
+   "Map a function to a double-linked-list."))
+(defgeneric dll-find-cursor (object dll &key test key))
+(defgeneric dll-find (object dll &key test key))
+(defgeneric dll-remove (cursor dll))
+
+(defmethod pop-last ((list double-linked-list))
+  "Drop the last element in the dl list."
+  (with-slots (last-element) list
+    (awhen (dle-previous last-element)
+      (dle-remove it)
+      (dle-value it))))
+
+(defmethod pop-first ((list double-linked-list))
+  "Drop the first element in the dl list."
+  (with-slots (elements) list
+    (when (dle-next elements)
+      (prog1 (dle-value elements)
+	(setf (dle-previous (dle-next elements)) nil
+	      elements (dle-next elements))))))
+
+(defmethod push-first (value (list double-linked-list))
+  (with-slots (elements) list
+    (setf elements (cons-dle value nil elements)))
+  list)
+
+(defmethod push-last (value (list double-linked-list))
+  (with-slots (last-element) list
+    (cons-dle value (dle-previous last-element) last-element))
+  list)
+
+(defmethod list-map (function (list double-linked-list))
+  (labels ((map-dll (dle)
+	     (when (dle-next dle)
+	       (make-double-linked-element
+		:value (funcall function (dle-value dle))
+		:previous (dle-previous dle)
+		:next (map-dll (dle-next dle))))))
+    (map-dll (slot-value list 'elements))))
+
+(defmethod dll-find-cursor (object (list double-linked-list) &key (test #'eql) (key #'identity))
+  (do ((cursor (slot-value list 'elements) (dle-next cursor)))
+      ((not (dle-next cursor)))
+    (be value (dle-value cursor)
+      (when (funcall test (funcall key value) object)
+	(return cursor)))))
+
+(defmethod dll-find (object (list double-linked-list) &key (test #'eql) (key #'identity))
+  (awhen (dll-find-cursor object list :test test :key key)
+    (dle-value it)))
+
+(defmethod dll-remove ((cursor double-linked-element) (list double-linked-list))
+  (with-slots (elements) list
+    (if (dle-previous cursor)
+	(dle-remove cursor)
+	(setf (dle-previous (dle-next elements)) nil
+	      elements (dle-next elements))))
+  list)
+
+(defmacro do-dll ((var list &optional (result nil)) &body body)
+  "Iterate over a dll and map body to each element's
+value.  Bind VAR to the value on each iteration."
+  (be cursor (gensym)
+    `(do ((,cursor (slot-value ,list 'elements) (dle-next ,cursor)))
+	 ((not (dle-next ,cursor)) ,result)
+       (be ,var (dle-value ,cursor)
+	 ,@body))))
+
+(defmacro do-dll* ((var list &optional (result nil)) &body body)
+  "Same as DO-DLL but VAR is a symbol macro, so that BODY can
+modify the element's value."
+  (be cursor (gensym)
+    `(symbol-macrolet ((,var (dle-value ,cursor)))
+       (do ((,cursor (slot-value ,list 'elements) (dle-next ,cursor)))
+	   ((not (dle-next ,cursor)) ,result)
+	 ,@body))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defclass limited-list (double-linked-list)
+  ((max-size :initform nil
+	     :initarg :size
+	     :reader max-size
+	     :type (or integer null)
+	     :documentation "Size limit to which the list is allowed to grow to.  NIL = no limit.")
+   (size :initform 0
+	 :reader size
+	 :type integer
+	 :documentation "Current number of elements in the list."))
+  (:documentation
+   "A double linked list where the maximum number of elements can
+be limited."))
+
+(defun dll-member-p (dle list)
+  (with-slots (elements size) list
+    (do ((e elements (dle-next e)))
+	((not e))
+      (when (eq e dle)
+	(return t)))))
+
+(defmethod dll-remove ((cursor double-linked-element) (list limited-list))
+  (with-slots (size) list
+    (unless (zerop size)
+      (decf size)
+      (call-next-method)))
+  list)
+
+(defmethod pop-first ((list limited-list))
+  (with-slots (size) list
+    (unless (zerop size)
+      (decf size)
+      (call-next-method))))
+
+(defmethod pop-last ((list limited-list))
+  (with-slots (size) list
+    (unless (zerop size)
+      (decf size)
+      (call-next-method))))
+
+(defmethod push-first (value (list limited-list))
+  "Add in front of the list and drop the last element if list is
+full."
+  (declare (ignore value))
+  (prog1 (call-next-method)
+    (with-slots (max-size size last-element) list
+      (if (or (not max-size)
+	      (< size max-size))
+	  (incf size)
+	  (dle-remove (dle-previous last-element))))))
+
+(defmethod push-last (value (list limited-list))
+  "Add at the end of the list and drop the first element if list
+is full."
+  (declare (ignore value))
+  (prog1 (call-next-method)
+    (with-slots (max-size size elements) list
+      (if (or (not max-size)
+	      (< size max-size))
+	(incf size)
+	(setf (dle-previous (dle-next elements)) nil
+	      elements (dle-next elements))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defclass sorted-list (limited-list)
+  ((test :type function
+	 :initarg :test))
+  (:documentation
+   "A double linked list where elements are inserted in a
+sorted order."))
+
+(defgeneric insert (item sorted-list)
+  (:documentation
+   "Insert an item in a sorted-list."))
+
+(defmethod insert (item (sl sorted-list))
+  "Insert ITEM in SL, which is a sorted double linked list,
+before the item for which TEST is true or at the end of the list.
+Returns two values, the modified list and the cursor to the new
+element."
+  (with-slots (max-size size elements test last-element) sl
+    (do ((cursor elements (dle-next cursor)))
+	((or (not (dle-next cursor))
+	     (funcall test item (dle-value cursor)))
+	 (if (dle-previous cursor)
+	     (cons-dle item (dle-previous cursor) cursor)
+	     (setf elements (cons-dle item nil cursor)))
+	 (if (or (not max-size)
+		  (< size max-size))
+	     (incf size)
+	     (dle-remove (dle-previous last-element)))
+	 (values sl (dle-previous cursor))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defclass heap ()
+  ((less-than :type function
+	      :initarg :test
+	      :documentation "The heap invariant.")
+   (data :type array
+	 :documentation "The heap tree representation.")))
+
+(defmethod initialize-instance ((heap heap) &rest args)
+  (declare (ignore args))
+  (call-next-method)
+  (with-slots (data) heap
+    (setf data (make-array 0 :fill-pointer 0 :adjustable t))))
+
+(defgeneric heap-add (heap item))
+
+(defun bubble-up (heap pos)
+  (with-slots (data less-than) heap
+    (loop
+       for current = pos then parent
+       for parent = (truncate (1- current) 2)
+       until (or (zerop current)
+		 (funcall less-than (aref data parent) (aref data current)))
+       do (rotatef (aref data current) (aref data parent)))))
+
+(defmethod heap-add ((heap heap) item)
+  (with-slots (data) heap
+    (vector-push-extend item data)
+    (bubble-up heap (1- (fill-pointer data)))))
+
+(defgeneric heap-size (heap))
+
+(defmethod heap-size ((heap heap))
+  (fill-pointer (slot-value heap 'data)))
+
+(defgeneric heap-empty-p (heap))
+
+(defmethod heap-empty-p ((heap heap))
+  (zerop (heap-size heap)))
+
+
+(defgeneric heap-pop (heap))
+
+(defun percolate-down (heap pos)
+  (with-slots (data less-than) heap
+    (loop
+       with end = (fill-pointer data)
+       for current = pos then child
+       for left-child = (+ 1 (* 2 current))
+       for right-child = (+ 2 (* 2 current))
+       for child = (cond ((>= left-child end)
+			  (return))
+			 ((>= right-child end)
+			  left-child)
+			 ((funcall less-than (aref data left-child) (aref data right-child))
+			  left-child)
+			 (t
+			  right-child))
+       while (funcall less-than (aref data child) (aref data current))
+       do (rotatef (aref data current) (aref data child)))))
+
+(defmethod heap-pop ((heap heap))
+  (assert (not (heap-empty-p heap)))
+  (with-slots (data) heap
+    (be root (aref data 0)
+      (setf (aref data 0) (vector-pop data))
+      (percolate-down heap 0)
+      root)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defstruct (lru-cache-slot (:include double-linked-element)
+			   (:conc-name lruc-slot-))
+  key)
+
+(defmethod print-object ((object lru-cache-slot) stream)
+  (print-unreadable-object (object stream :type t)
+    (format stream "key=~S value=~S" (lruc-slot-key object) (lruc-slot-value object))))
+
+(defvar *default-cache-size* 100
+  "Default size of a LRU cache if it's not specified at instantiation
+time.")
+
+(defclass lru-cache ()
+  ((max-size :initform *default-cache-size*
+	     :initarg :size
+	     :reader max-size
+	     :type (or integer null)
+	     :documentation
+	     "Maximum number of elements that the cache can fit.")
+   (elements-list :type lru-cache-slot
+		  :documentation "The list of elements held by the cache.")
+   (elements-hash :type hash-table
+		  :documentation "The hash table of the elements held bye the cache.")
+   (last-element :type lru-cache-slot)
+   (size :initform 0
+	 :reader size
+	 :type integer
+	 :documentation "Current number of elements in the cache.")
+   (finalizer :initform nil
+	      :initarg :finalizer
+	      :documentation
+	      "Procedure to call when elements are dropped from cache."))
+  (:documentation
+   "An objects cache that keeps the elements used more often and
+drops those that are used less often.  The usage is similar to an
+hash table.  Elements are added to the list up to MAX-SIZE, then
+any new element will drop the less used one in the cache.  Every
+time an element is set or retrieved it goes in front of a list.
+Those which get at the end of the list are dropped when more room
+is required."))
+
+(defmethod initialize-instance ((object lru-cache) &key test &allow-other-keys)
+  (call-next-method)
+  (with-slots (last-element elements-list elements-hash) object
+    (setf last-element (make-lru-cache-slot)
+	  elements-list last-element
+	  elements-hash (if test
+			    (make-hash-table :test test)
+			    (make-hash-table)))))
+
+(defgeneric getcache (key cache)
+  (:documentation
+   "Get an item with KEY from a CACHE."))
+
+(defgeneric (setf getcache) (value key cache)
+  (:documentation
+   "Set or add an item with KEY in a CACHE."))
+
+(defgeneric remcache (key cache)
+  (:documentation
+   "Remove an item with KEY from a CACHE."))
+
+(defun move-in-front-of-cache-list (slot cache)
+  "Relocate slot to the front of the elements list in cache.
+This will stretch its lifespan in the cache."
+  (declare (type lru-cache-slot slot)
+	   (type lru-cache cache))
+  (with-slots (elements-list) cache
+    ;; unless it's already the first
+    (unless (eq slot elements-list)
+      ;; remove the slot from its original place...
+      (dle-remove slot)
+      ;; ... and add it in front of the list
+      (setf (lruc-slot-next slot) elements-list
+	    (lruc-slot-previous slot) nil
+	    (lruc-slot-previous elements-list) slot
+	    elements-list slot))))
+
+(defun drop-last-cache-element (cache)
+  "Drop the last element in the list of the cache object."
+  (declare (type lru-cache cache))
+  (with-slots (last-element elements-hash finalizer) cache
+    (let ((second-last (lruc-slot-previous last-element)))
+      (assert second-last)
+      (when finalizer
+	(funcall finalizer (lruc-slot-value second-last)))
+      (dle-remove second-last)
+      (remhash (lruc-slot-key second-last) elements-hash))))
+
+(defun add-to-cache (slot cache)
+  (declare (type lru-cache-slot slot)
+	   (type lru-cache cache))
+  (move-in-front-of-cache-list slot cache)
+  (with-slots (max-size size elements-hash) cache
+    (setf (gethash (lruc-slot-key slot) elements-hash) slot)
+    (if (and max-size
+	     (< size max-size))
+	(incf size)
+	(drop-last-cache-element cache))))
+
+(defmethod getcache (key (cache lru-cache))
+  (multiple-value-bind (slot found?) (gethash key (slot-value cache 'elements-hash))
+    (when found?
+      (move-in-front-of-cache-list slot cache)
+      (values (lruc-slot-value slot) t))))
+
+(defmethod (setf getcache) (value key (cache lru-cache))
+  (with-slots (elements-hash elements-list) cache
+    (multiple-value-bind (slot found?) (gethash key elements-hash)
+      (if found?
+	  (progn
+	    (move-in-front-of-cache-list slot cache)
+	    (setf (lruc-slot-value slot) value))
+	  (add-to-cache (make-lru-cache-slot :key key :value value) cache))
+      value)))
+
+(defmethod remcache (key (cache lru-cache))
+  (with-slots (elements-hash size elements-list finalizer) cache
+    (multiple-value-bind (slot found?) (gethash key elements-hash)
+      (when found?
+	(remhash key elements-hash)
+	(when finalizer
+	  (funcall finalizer (lruc-slot-value slot)))
+	(when (eq slot elements-list)
+	  (setf elements-list (dle-next slot)))
+	(dle-remove slot)
+	(decf size)
+	t))))
+
+(defmacro cached (cache key value)
+  "If KEY is found in CACHE return the associated object.  Otherwise
+store VALUE for later re-use."
+  (with-gensyms (object my-cache my-key my-value found?)
+    `(let* ((,my-cache ,cache)
+	    (,my-key ,key))
+       (multiple-value-bind (,object ,found?) (getcache ,my-key ,my-cache)
+	 (if ,found?
+	     ,object
+	     (let ((,my-value ,value))
+	       (setf (getcache ,my-key ,my-cache) ,my-value)
+	       ,my-value))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(declaim (inline list->string))
+(defun list->string (list)
+  "Coerce a list of characters into a string."
+  (coerce list 'string))
+
+(defun setuid (id)
+  "Set the Unix real user id."
+  (when (stringp id)
+    (setf id (find-uid id)))
+  #+sbcl (sb-posix:setuid id)
+  #+cmu (unix:unix-setuid id)
+  #+clisp (posix::%setuid id)		; not verified -wcp26/8/09.
+  #-(or cmu sbcl clisp)
+  (error "setuid unsupported under this Lisp implementation"))
+
+(defun seteuid (id)
+  "Set the Unix effective user id."
+  (when (stringp id)
+    (setf id (find-uid id)))
+  #+sbcl (sb-posix:seteuid id)
+  #+cmu (unix:unix-setreuid -1 id)
+  #+clisp (posix::%seteuid id)		; not verified -wcp26/8/09.
+  #-(or cmu sbcl clisp)
+  (error "seteuid unsupported under this Lisp implementation"))
+
+(defun find-uid (name)
+  "Find the user id of NAME.  Return an integer."
+  #+sbcl (awhen (sb-posix:getpwnam name)
+	   (sb-posix:passwd-uid it))
+  #+cmu (awhen (unix:unix-getpwnam name)
+	  (unix:user-info-uid it))
+  #-(or cmu sbcl)
+  (error "Unable to find a UID on this Lisp system."))
+
+#+clisp (ffi:def-call-out %getuid
+	    (:name "getuid")
+	  (:arguments)
+	  (:return-type ffi:int)
+	  (:library "libc.so"))
+
+(defun getuid ()
+  "Return the Unix user id.  This is an integer."
+  #+sbcl (sb-unix:unix-getuid)
+  #+cmu (unix:unix-getuid)
+  #+clisp (%getuid)
+  #-(or cmu sbcl clisp)
+  (error "getuid unsupported under this Lisp implementation"))
+
+(defun super-user-p (&optional id)
+  "Return true if the user ID is zero.  ID defaults to the current
+user id."
+  (zerop (or id (getuid))))
+
+(defmacro with-euid (uid &body forms)
+  "Switch temporarely to Unix user id UID, while performing FORMS."
+  (with-gensyms (ruid)
+    `(be ,ruid (getuid)
+       (seteuid ,uid)
+       (unwind-protect (progn ,@forms)
+	 (seteuid ,ruid)))))
+
+(defun get-logname (&optional uid)
+  "Return the login id of the user.  This is a string and it is not
+the Unix uid, which is a number."
+  (unless uid
+    (setf uid (getuid)))
+  (when (stringp uid)
+    (setf uid (find-uid uid)))
+  (when uid
+    #+sbcl (sb-unix:uid-username uid)
+    #+cmu (unix:user-info-name (unix:unix-getpwuid uid))
+    #+clisp (posix:user-info-login-id (posix:user-info uid))
+    #-(or cmu sbcl clisp)
+    (error "get-logname unsupported under this Lisp implementation")))
+
+(defun get-user-name (&optional uid)
+  "Return the user name, taken from the GCOS field of the /etc/passwd
+file."
+  (unless uid
+    (setf uid (getuid)))
+  (when (stringp uid)
+    (setf uid (find-uid uid)))
+  (when uid
+    (car (split-string-at-char #+cmu (unix:user-info-gecos (unix:unix-getpwuid uid))
+			       #+sbcl (sb-posix:passwd-gecos (sb-posix:getpwuid uid))
+			       #-(or cmu sbcl) (error "can't getpwuid() on this Lisp system.")
+			       #\,))))
+
+(defun get-user-home (&optional uid)
+  (unless uid
+    (setf uid (getuid)))
+  (when (stringp uid)
+    (setf uid (find-uid uid)))
+  (when uid
+    #+cmu (unix:user-info-dir (unix:unix-getpwuid uid))
+    #+sbcl (sb-posix:passwd-dir (sb-posix:getpwuid uid))))
+
+;; Rather stupid, but the mnemonic is worth it
+(declaim (inline alist->plist))
+(defun alist->plist (alist)
+  "Convert an association list into a property list.  The alist
+elements are assumed to be lists of just two elements: the key
+and the value.  If the element list is longer this function
+doesn't work."
+  (mapcan #'identity alist))
+
+(defun plist->alist (plist &optional pairs-p)
+  "Convert a property list into an association list.  The alist
+elements wiil be lists of just two elements: the key and the
+value.  If PAIRS-P is true the alist elements will be pairs."
+  (loop
+     for (key val) on plist by #'cddr
+     collect (if pairs-p
+		 (cons key val)
+		 (list key val))))
+
+(defun string->byte-vector (string &key start end)
+  "Convert a string of characters into a vector of (unsigned-byte
+8) elements."
+  (map '(vector (unsigned-byte 8)) #'char-code
+       (if (or start end)
+	   (subseq string (or start 0) end)
+	   string)))
+
+(defun byte-vector->string (vector &key start end)
+  "Convert a vector of (unsigned-byte 8) elements into a string
+of characters."
+  (map 'string #'code-char
+       (if (or start end)
+	   (subseq vector (or start 0) end)
+	   vector)))
+
+(defun outdated-p (file dependencies)
+  "Check if FILE has been modified before any of its
+DEPENDENCIES."
+  (be epoch (and (probe-file file)
+		 (file-write-date file))
+    ;; if file is missing altogether, we consider it outdated
+    (or (not epoch)
+	(loop
+	   for dep in dependencies
+	   thereis (aand (probe-file dep)
+			 (file-write-date dep)
+			 (> it epoch))))))
+
+(defmacro let-places (places-and-values &body body)
+  "Execute BODY binding temporarily some places to new values and
+restoring the original values of these places on exit of BODY.  The
+syntax of this macro is identical to LET.  The difference is that
+instead of new variable names this macro binds values to existing
+places (variables)."
+  (be tmp-variables (loop for x in places-and-values collect (gensym))
+    `(let ,(mapcar #'(lambda (tmp-var place-and-value)
+		       (list tmp-var (car place-and-value)))
+		   tmp-variables places-and-values)
+       (unwind-protect
+	    (progn
+	      ;; as some assignments could signal an error, we assign
+	      ;; within the unwind-protect block so that we can always
+	      ;; guarantee a consistent state on exit
+	      ,@(mapcar #'(lambda (place-and-value)
+			    `(setf ,(car place-and-value) ,(cadr place-and-value)))
+			places-and-values)
+	      ,@body)
+	 ,@(mapcar #'(lambda (tmp-var place-and-value)
+		       `(setf ,(car place-and-value) ,tmp-var))
+		   tmp-variables
+		   places-and-values)))))
+
+(defmacro let-slots (accessor/new-value-pairs object &body body)
+  "Execute BODY with some OBJECT's slots temporary sets to new
+values as described in ACCESSOR/NEW-VALUE-PAIRS.  The latter
+should be an alist of accessor names and the value to be assigned
+to that slot.  On exit from BODY, those slots are restored to
+their original value.  See LET-PLACES."
+  (with-gensyms (obj)
+    `(be ,obj ,object
+       (let-places ,(mapcar #'(lambda (av)
+				`((,(car av) ,obj) ,(cadr av)))
+			    accessor/new-value-pairs)
+	 ,@body))))
+
+(defvar *decimal-point* #\.)
+(defvar *thousands-comma* #\,)
+
+(defun format-amount (number &key (decimals 2) (rounder #'round)
+		      (comma *thousands-comma*) (comma-stance 3)
+		      (decimal-point *decimal-point*))
+  "Return a string formatted as fixed decimal point number of DECIMALS
+adding commas every COMMA-STANCE places before the decimal point."
+  (declare (type number number)
+	   (type fixnum decimals comma-stance)
+	   (type function rounder)
+	   (type character comma decimal-point)
+	   (optimize (speed 3) (safety 0) (debug 0)))
+  (let* ((int (funcall rounder (* number (expt 10 decimals))))
+	 (negative (< int 0)))
+    (declare (integer int))
+    (when negative
+      (setf int (- int)))
+    (let* ((digits (max (1+ decimals)
+			(1+ (if (zerop int)
+				0
+				(truncate (log int 10))))))
+	   (string-length (+ digits
+			     ;; the minus sign
+			     (if negative 1 0)
+			     ;; the decimal point
+			     (if (zerop decimals) 0 1)
+			     ;; the thousands commas
+			     (1- (ceiling (- digits decimals) comma-stance))))
+	   (string (make-string string-length))
+	   (pos (1- string-length)))
+      (declare (type fixnum pos digits))
+      (labels ((add-char (char)
+		 (setf (schar string pos) char)
+		 (decf pos))
+	       (add-digit ()
+		 (add-char (digit-char (mod int 10)))
+		 (setf int (truncate int 10))))
+	(unless (zerop decimals)
+	  (loop
+	     for i fixnum from 0 below decimals
+	     do (add-digit))
+	  (add-char decimal-point))
+	(loop
+	   for i fixnum from 1
+	   do (add-digit)
+	   while (>= pos (if negative 1 0))
+	   when (zerop (mod i comma-stance))
+	   do (add-char comma))
+	(when negative
+	  (add-char #\-)))
+      string)))
+
+(defun parse-amount (string &key (start 0) end)
+  "Parse STRING as if it was formatted with FORMAT-AMOUNT and return
+the parsed number.  Return NIL if STRING is malformed.  Leading or
+trailing spaces must be removed from the string in advance."
+  (loop
+     with amount = 0
+     with decimals = nil
+     with negative = (when (and (not (zerop (length string)))
+				(char= #\- (char string 0)))
+		       (incf start)
+		       t)
+     for i from start below (or end (length string))
+     for c = (char string i)
+     do (cond ((char= c *decimal-point*)
+	       (if decimals
+		   (return nil)
+		   (setf decimals 0)))
+	      ((char= c *thousands-comma*))
+	      (t
+	       (be d (digit-char-p c)
+		 (cond ((not d)
+			(return nil))
+		       (decimals
+			(incf decimals)
+			(incf amount (/ d (expt 10 decimals))))
+		       (t
+			(setf amount (+ d (* amount 10))))))))
+     finally (return (if negative
+			 (- amount)
+			 amount))))
+
+(defmacro with-package (name &body body)
+  `(let ((*package* (find-package ,name)))
+     ,@body))
+
+(defun bytes-simple-string (n &optional imply-bytes)
+  "Return a string describing N using a unit of measure multiple
+of a byte that is most apporpriate for the magnitude of N.  A
+kilobyte is 1024 not 1000 bytes, everything follows."
+  (let* ((kilo 1024)
+	 (mega (* kilo kilo))
+	 (giga (* kilo mega))
+	 (tera (* mega mega))
+	 (peta (* kilo tera)))
+    (apply #'format nil "~,1F~A"
+	   (cond ((> n (* 2 peta))
+		  (list (/ n peta) (if imply-bytes "P" "PB")))
+		 ((> n (* 2 tera))
+		  (list (/ n tera) (if imply-bytes "T" "TB")))
+		 ((> n (* 2 giga))
+		  (list (/ n giga) (if imply-bytes "G" "GB")))
+		 ((> n (* 2 mega))
+		  (list (/ n mega) (if imply-bytes "M" "MB")))
+		 ((> n (* 2 kilo))
+		  (list (/ n kilo) (if imply-bytes "K" "KB")))
+		 (t (list n (if imply-bytes "" " bytes")))))))
+
+;; WARNING: This function may or may not work on your Lisp system.  It
+;; all depends on how the OPEN function has been implemented regarding
+;; the :IF-EXISTS option.  This function requires that OPEN be
+;; implemented in a way so that the checking of the existence of file
+;; and its open attempt be atomic.  If the Lisp OPEN first checks that
+;; the file exists and then tries to open it, this function won't be
+;; reliable.  CMUCL seems to use the O_EXCL open() flag in the right
+;; way.  So at least on CMUCL this function will work.  Same goes for
+;; SBCL.
+(defun make-lock-files (pathnames &key (sleep-time 7) retries (suspend 13) expiration)
+  "Create semaphore files.  If it can't create all the specified
+files in the specified order, it waits SLEEP-TIME seconds and
+retries the last file that didn't succeed.  You can specify the
+number of RETRIES to do until failure is returned.  If the number
+of retries is NIL this function will retry forever.
+
+If it tries RETRIES times without success, this function signal
+an error and removes all the lock files it created until then.
+
+All files created by lock file will be read-only.
+
+If you specify a EXPIRATION then an existing lock file will be
+removed by force after EXPIRATION seconds have passed since the
+lock file was last modified/created (most likely by some other
+program that unexpectedly died without cleaning up its lock
+files).  After a lock file has been removed by force, a
+suspension of SUSPEND seconds is taken into account, in order to
+prevent the inadvertent immediate removal of any newly created
+lock file by another program."
+  (be locked '()
+    (flet ((lock (file)
+	     (when (and expiration
+			(> (get-universal-time)
+			   (+ (file-write-date file) expiration)))
+	       (delete-file file)
+	       (when suspend
+		 (sleep suspend)))
+	     (do ((i 0 (1+ i))
+		  (done nil))
+		 (done)
+	       (unless (or (not retries)
+			   (< i retries))
+		 (error "Can't create lock file ~S: tried ~A time~:P." file retries))
+	       (with-open-file (out file :direction :output :if-exists nil)
+		 (cond (out
+			(format out "Lock file created on ~A~%" (time-string (get-universal-time)))
+			(setf done t))
+		       (sleep-time
+			(sleep sleep-time)))))))
+      (unwind-protect
+	   (progn
+	     (dolist (file pathnames)
+	       (lock file)
+	       (push file locked))
+	     (setf locked '()))
+	(mapc #'delete-file locked)))))
+
+(defmacro with-lock-files ((lock-files &rest lock-args) &body body)
+  "Execute BODY after creating LOCK-FILES.  Remove the lock files
+on exit.  LOCK-ARGS are passed to MAKE-LOCK-FILES."
+  (with-gensyms (files)
+    `(be ,files (list ,@lock-files)
+       (make-lock-files ,files ,@lock-args)
+       (unwind-protect (progn ,@body)
+	 (mapc #'delete-file ,files)))))
+
+(defun getpid ()
+  #+cmu (unix:unix-getpid)
+  #+sbcl (sb-unix:unix-getpid)
+  #+clisp (ext:process-id)
+  #-(or cmu sbcl clisp)
+   (error "getpid unsupported under this Lisp implementation"))
+
+(defmacro on-error (form &body error-forms)
+  "Execute FORM and in case of error execute ERROR-FORMS too.
+This does _not_ stop the error from propagating."
+  (be done-p (gensym)
+    `(be ,done-p nil
+       (unwind-protect
+	    (prog1
+		,form
+	      (setf ,done-p t))
+	 (unless ,done-p
+	   ,@error-forms)))))
+
+(defun floor-to (x aim)
+  "Round X down to the nearest multiple of AIM."
+  (* (floor x aim) aim))
+
+(defun round-to (x aim)
+  "Round X to the nearest multiple of AIM."
+  (* (round x aim) aim))
+
+(defun ceiling-to (x aim)
+  "Round X up to the nearest multiple of AIM."
+  (* (ceiling x aim) aim))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defstruct queue
+  first
+  last)
+
+(defgeneric queue-append (queue objects))
+(defgeneric queue-pop (queue))
+(defgeneric queue-empty-p (queue))
+
+(defmethod queue-append ((queue queue) (objects list))
+  (cond ((null (queue-first queue))
+	 (setf (queue-first queue) objects
+	       (queue-last queue) (last objects)))
+	(t
+	 (setf (cdr (queue-last queue)) objects
+	       (queue-last queue) (last objects))))
+  queue)
+
+(defmethod queue-append ((queue queue) object)
+  (queue-append queue (list object)))
+
+(defmethod queue-pop ((queue queue))
+  (prog1 (car (queue-first queue))
+    (setf (queue-first queue) (cdr (queue-first queue)))))
+
+(defmethod queue-empty-p ((queue queue))
+  (null (queue-first queue)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun package-locked-p (package)
+  #+sbcl (sb-ext:package-locked-p package)
+  #+cmu (ext:package-definition-lock package)
+  #+clisp (ext:package-lock package)
+  #-(or sbcl cmu clisp) (error "Don't know how to check whether a package might be locked."))
+
+(defun forget-documentation (packages)
+  "Remove documentation from all known symbols in PACKAGES.  If
+PACKAGES is NIL remove documentations from all packages.  This may not
+make sense if your Lisp image has been built so that existing objects
+don't get garbage collected.  It may work for your own code, though.
+Locked packages are left alone.  If you need to do those too, unlock
+them first."
+  (flet ((forget (symbol)
+	   (dolist (type '(compiler-macro function method-combination setf structure type variable))
+	     (when (ignore-errors (documentation symbol type))
+	       (setf (documentation symbol type) nil)))))
+    (setf packages (mapcar #'(lambda (pkg)
+			       (if (packagep pkg)
+				   (package-name pkg)
+				   (package-name (find-package pkg))))
+			   packages))
+    (setf packages
+	  ;; don't try to modify locked packages
+	  (remove-if #'package-locked-p
+		     (mapcar #'find-package
+			     (or packages
+				 (list-all-packages)))))
+    (dolist (package packages)
+      (with-package-iterator (next package :internal :external)
+	(loop
+	   (multiple-value-bind (more? symbol) (next)
+	     (unless more?
+	       (return))
+	     (forget symbol)))))
+    #+(OR) (do-all-symbols (symbol)
+	     (when (member (symbol-package symbol) packages)
+	       (forget symbol))))
+  (values))
+
+(defun load-compiled (pathname &optional compiled-pathname)
+  "Make sure to compile PATHNAME before loading it.  Don't compile if
+the compiled version is more recent than its source."
+  ;; be tolerant if we didn't get a type
+  (unless (probe-file pathname)
+    (setf pathname (merge-pathnames pathname (make-pathname :type "lisp"))))
+  (if (probe-file pathname)
+      (progn
+	(setf compiled-pathname (or compiled-pathname
+				    (compile-file-pathname pathname)))
+	(when (or (not (probe-file compiled-pathname))
+		  (< (file-write-date compiled-pathname)
+		     (file-write-date pathname)))
+	  (compile-file pathname))
+	(load compiled-pathname))
+      (error "Can't load ~A as it doesn't exist." pathname)))
+
+;; Just a silly mnemonic for those used to lesser languages
+(defmacro swap (x y)
+  "Swap values of places X and Y."
+  `(rotatef ,x ,y))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defmacro show (&rest things)
+  "Debugging macro to show the name and content of variables.  You can
+also specify forms, not just variables."
+  (let ((*print-pretty* nil))
+    `(let ((*print-circle* t))
+       (format t ,(format nil "~~&~{~A=~~:W~~%~}" things)
+	       ,@things)
+       (finish-output)
+       (values))))
+
+(defmacro memoize-function (name &key test)
+  "Make function NAME memoized.  TEST is passed to MAKE-HASH-TABLE."
+  `(setf (get ',name 'results-hash-table)
+	 (make-hash-table ,@(when test (list :test test)))))
+
+(defmacro defun-memoized (name args &body forms)
+  "Define function NAME and make it memoizable.  Then the MEMOIZED
+macro can be used to call this function and memoize its results.  The
+function NAME must accept only one argument and return just one
+argument; more complicated cases are not considered.  The hash table
+test function is the default 'EQL."
+  `(eval-when (:load-toplevel :compile-toplevel)
+     (defun ,name ,args ,@forms)
+     (memoize-function ,name)))
+
+(defmacro memoized (function arg)
+  "If necessary call FUNCTION passing ARG so that its return value is
+memoized.  The next time this form is executed with the same argument
+value, the memoized result is returned instead of executing FUNCTION."
+  (with-gensyms (table key result not-found)
+    `(be* ,key ,arg
+	  ,table (get ',function 'results-hash-table)
+	  ,not-found (list nil)
+	  ,result (gethash ,key ,table ,not-found)
+       (if (eq ,not-found ,result)
+	   (setf (gethash ,key ,table)
+		 (,function ,key))
+	   ,result))))
+
+
+(defmacro save-file-excursion ((stream &optional position) &body forms)
+  "Execute FORMS returning, on exit, STREAM to the position it was
+before FORMS.  Optionally POSITION can be set to the starting offset."
+  (unless position
+    (setf position (gensym)))
+  `(be ,position (file-position ,stream)
+     (unwind-protect (progn ,@forms)
+       (file-position ,stream ,position))))
+
+(defun circular-list (&rest elements)
+  "Return a circular list of ELEMENTS."
+  (setf (cdr (last elements)) elements))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun getenv (var)
+  "Return the string associate to VAR in the system environment."
+  #+cmu (cdr (assoc (if (symbolp var)
+			var
+			(intern var :keyword))
+		    ext:*environment-list*))
+  #+sbcl (sb-ext:posix-getenv (string var))
+  #+lispworks (hcl:getenv var)
+  #+clisp (ext:getenv (string var))
+  #-(or cmu sbcl lispworks clisp)
+  (error "GETENV not implemented for your Lisp system."))
+
+#+clisp (ffi:def-call-out %setenv
+	    (:name "setenv")
+	  (:arguments (name ffi:c-string) (value ffi:c-string) (overwrite ffi:int))
+	  (:return-type ffi:int)
+	  (:library "libc.so"))
+
+#+clisp (ffi:def-call-out %unsetenv
+	    (:name "unsetenv")
+	  (:arguments (name ffi:c-string))
+	  (:return-type ffi:int)
+	  (:library "libc.so"))
+
+(defun setenv (name value &optional (overwrite t))
+  (typecase value
+    (string)
+    (pathname
+     (setf value (native-namestring value)))
+    (t
+     (setf value (format nil "~A" value))))
+  #+sbcl (unless (zerop (sb-posix:setenv name value (if overwrite 1 0)))
+	   (error "unable to setenv ~A: errno=~A." name
+		  (sb-alien:get-errno)))
+  #+cmu (be key (keywordify name)
+	  (aif (assoc key
+		      ext:*environment-list*)
+	       (when overwrite
+		 (setf (cdr it) value))
+	       (setf ext:*environment-list*
+		     (cons (cons key value)
+			   ext:*environment-list*))))
+  #-(or cmu sbcl) (unless (zerop (%setenv name value (if overwrite 1 0)))
+		    (error "unable to setenv ~A." name)))
+
+(defun unsetenv (name)
+  #+sbcl (unless (zerop (sb-posix:unsetenv name))
+	   (error "unable to unsetenv ~A: errno=~A." name
+		  (sb-alien:get-errno)))
+  #+cmu (be key (keywordify name)
+	  (setf ext:*environment-list*
+		(delete-if #'(lambda (e)
+			       (eq (car e) key))
+			   ext:*environment-list*)))
+  #-(or cmu sbcl) (unless (zerop (%unsetenv name))
+		    (error "unable to unsetenv ~A." name)))
+
+(defun (setf getenv) (value name)
+  (if value
+      (setenv name value t)
+      (unsetenv name)))
+
+;; in CMUCL it's much easier (see below)
+#-cmu
+(defmacro with-system-environment ((&rest var-and-values) &body body)
+  (be gensym-alist (mapcar #'(lambda (vv)
+			       (list (gensym) (string (car vv)) (cadr vv)))
+			   var-and-values)
+      `(let ,(mapcar #'(lambda (vv)
+			 (destructuring-bind (varsym var value) vv
+			   (declare (ignore value))
+			   `(,varsym (getenv ,var))))
+		     gensym-alist)
+	 (unwind-protect
+	      (progn
+		,@(mapcar #'(lambda (vv)
+			      (destructuring-bind (varsym var value) vv
+				(declare (ignore varsym))
+				`(setenv ,var ,value)))
+			  gensym-alist)
+		,@body)
+	   ,@(mapcar #'(lambda (vv)
+			 (destructuring-bind (varsym var value) vv
+			   (declare (ignore value))
+			   `(if ,varsym
+				(setenv ,var ,varsym)
+				(unsetenv ,var))))
+		     gensym-alist)))))
+
+#+cmu
+(defmacro with-system-environment ((&rest var-and-values) &body body)
+  `(let ((ext:*environment-list*
+	  (append (list ,@(mapcar #'(lambda (vv)
+				      (destructuring-bind (variable value) vv
+					`(cons ,(keywordify variable)
+					       ,value)))
+				  var-and-values))
+		  ext:*environment-list*)))
+     ,@body))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun last-member (item list &key key (test #'eq))
+  "Return the last sublist in LIST that is prefixed by ITEM."
+  (loop
+     with l = list and result = nil
+     for l2 = (member item l :key key :test test)
+     while l2
+     do (setf result l2
+	      l (cdr l2))
+     finally (return result)))
+
+
+(defun glob->regex (string)
+  "Convert a shell glob expression into a regular expression string."
+  (with-output-to-string (out)
+    ;; globs are always anchored to beginning and end
+    (write-char #\^ out)
+    (loop
+       for i from 0 below (length string)
+       do (be c (char string i)
+	    (cond ((char= c #\\)
+		   (setf c (char string (incf i))))
+		  ((find c  ".+()|^$")
+		   (write-char #\\ out))
+		  ((char= c #\*)
+		   (write-char #\. out))
+		  ((char= c #\?)
+		   (setf c #\.)))
+	    (write-char c out)))
+    (write-char #\$ out)))
diff --git a/third_party/lisp/sclf/serial.lisp b/third_party/lisp/sclf/serial.lisp
new file mode 100644
index 000000000000..936c61606386
--- /dev/null
+++ b/third_party/lisp/sclf/serial.lisp
@@ -0,0 +1,62 @@
+ ;;; serial.lisp --- serialisation of CLOS objects
+
+ ;;; Copyright (C) 2009 by Walter C. Pelissero
+
+ ;;; Author: Walter C. Pelissero <walter@pelissero.de>
+ ;;; Project: sclf
+
+#+cmu (ext:file-comment "$Module: serial.lisp $")
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public License
+;;; as published by the Free Software Foundation; either version 2.1
+;;; of the License, or (at your option) any later version.
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free
+;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+;;; 02111-1307 USA
+
+(in-package :sclf)
+
+(defclass printable-object-mixin () ())
+
+(defmacro reconstruct-object (class &rest args)
+  `(apply #'make-instance ',class ',args))
+
+(defun print-readable-instance (object &optional stream)
+  (unless stream
+    (setf stream *standard-output*))
+  (be class (class-of object)
+    (pprint-logical-block (stream (copy-list (class-slots class)) :prefix "#.(" :suffix ")")
+      (flet ((spc ()
+	       (write-char #\space stream)))
+	(write 'reconstruct-object :stream stream)
+	(spc)
+	(write (class-name class) :stream stream :escape t :readably t :pretty t)
+	(pprint-exit-if-list-exhausted)
+	(spc)
+	(loop
+	   (be* slot (pprint-pop)
+		slot-name (slot-definition-name slot)
+		initarg (car (slot-definition-initargs slot))
+	     (when (and initarg
+			(slot-boundp object slot-name))
+	       (write initarg :stream stream)
+	       (spc)
+	       (when *print-pretty*
+		 (pprint-newline :miser stream))
+	       (write (slot-value object slot-name)
+		      :stream stream)
+	       (pprint-exit-if-list-exhausted)
+	       (if *print-pretty*
+		   (pprint-newline :linear stream)
+		   (spc)))))))))
+
+(defmethod print-object ((object printable-object-mixin) stream)
+  (if *print-readably*
+      (print-readable-instance object stream)
+      (call-next-method)))
diff --git a/third_party/lisp/sclf/sysproc.lisp b/third_party/lisp/sclf/sysproc.lisp
new file mode 100644
index 000000000000..85c2517e0002
--- /dev/null
+++ b/third_party/lisp/sclf/sysproc.lisp
@@ -0,0 +1,295 @@
+;;;  sysproc.lisp --- system processes
+
+;;;  Copyright (C) 2008, 2009, 2010 by Walter C. Pelissero
+
+;;;  Author: Walter C. Pelissero <walter@pelissero.de>
+;;;  Project: sclf
+
+#+cmu (ext:file-comment "$Module: sysproc.lisp $")
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public License
+;;; as published by the Free Software Foundation; either version 2.1
+;;; of the License, or (at your option) any later version.
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free
+;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+;;; 02111-1307 USA
+
+(in-package :sclf)
+
+(defvar *bourne-shell* "/bin/sh")
+
+(defvar *run-verbose* nil
+  "If true system commands are displayed before execution and standard
+error is not discarded.")
+
+;;
+;; SIGINFO is missing in both CMUCL and SBCL
+;;
+
+#+cmu
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defconstant unix::siginfo 29)
+  (defvar siginfo (unix::make-unix-signal :siginfo unix::siginfo "Information"))
+  (export '(unix::siginfo) "UNIX")
+  (pushnew siginfo unix::*unix-signals*))
+
+#+sbcl (in-package :sb-posix)
+#+sbcl
+(eval-when (:execute :compile-toplevel :load-toplevel)
+  (unless (find-symbol "SIGINFO" :sb-posix)
+    (sb-ext:with-unlocked-packages (:sb-posix)
+      (defvar siginfo 29)
+      (export '(SIGINFO)))))
+#+sbcl (in-package :sclf)
+
+(defun signal-number (signal-name)
+  (ecase signal-name
+    ((:abrt :abort)
+     #+cmu unix:sigabrt
+     #+sbcl sb-posix:sigabrt)
+    ((:alrm :alarm)
+     #+cmu unix:sigalrm
+     #+sbcl sb-posix:sigalrm)
+    ((:bus :bus-error)
+     #+cmu unix:sigbus
+     #+sbcl sb-posix:sigbus)
+    ((:chld :child)
+     #+cmu unix:sigchld
+     #+sbcl sb-posix:sigchld)
+    ((:cont :continue)
+     #+cmu unix:sigcont
+     #+sbcl sb-posix:sigcont)
+    #+freebsd((:emt :emulate-instruction)
+	      #+cmu unix:sigemt
+	      #+sbcl sb-posix:sigemt)
+    ((:fpe :floating-point-exception)
+     #+cmu unix:sigfpe
+     #+sbcl sb-posix:sigfpe)
+    ((:hup :hangup)
+     #+cmu unix:sighup
+     #+sbcl sb-posix:sighup)
+    ((:ill :illegal :illegal-instruction)
+     #+cmu unix:sigill
+     #+sbcl sb-posix:sigill)
+    ((:int :interrupt)
+     #+cmu unix:sigint
+     #+sbcl sb-posix:sigint)
+    ((:io :input-output)
+     #+cmu unix:sigio
+     #+sbcl sb-posix:sigio)
+    (:kill
+     #+cmu unix:sigkill
+     #+sbcl sb-posix:sigkill)
+    ((:pipe :broke-pipe)
+     #+cmu unix:sigpipe
+     #+sbcl sb-posix:sigpipe)
+    ((:prof :profiler)
+     #+cmu unix:sigprof
+     #+sbcl sb-posix:sigprof)
+    (:quit
+     #+cmu unix:sigquit
+     #+sbcl sb-posix:sigquit)
+    ((:segv :segmentation-violation)
+     #+cmu unix:sigsegv
+     #+sbcl sb-posix:sigsegv)
+    (:stop
+     #+cmu unix:sigstop
+     #+sbcl sb-posix:sigstop)
+    ((:sys :system-call)
+     #+cmu unix:sigsys
+     #+sbcl sb-posix:sigsys)
+    ((:term :terminate)
+     #+cmu unix:sigterm
+     #+sbcl sb-posix:sigterm)
+    ((:trap)
+     #+cmu unix:sigtrap
+     #+sbcl sb-posix:sigtrap)
+    ((:tstp :terminal-stop)
+     #+cmu unix:sigtstp
+     #+sbcl sb-posix:sigtstp)
+    ((:ttin :tty-input)
+     #+cmu unix:sigttin
+     #+sbcl sb-posix:sigttin)
+    ((:ttou :tty-output)
+     #+cmu unix:sigttou
+     #+sbcl sb-posix:sigttou)
+    ((:urg :urgent)
+     #+cmu unix:sigurg
+     #+sbcl sb-posix:sigurg)
+    ((:usr1 :user1)
+     #+cmu unix:sigusr1
+     #+sbcl sb-posix:sigusr1)
+    ((:usr2 :user2)
+     #+cmu unix:sigusr2
+     #+sbcl sb-posix:sigusr2)
+    ((:vtalrm :virtual-timer-alarm)
+     #+cmu unix:sigvtalrm
+     #+sbcl sb-posix:sigvtalrm)
+    ((:winch :window-change :window-size-change)
+     #+cmu unix:sigwinch
+     #+sbcl sb-posix:sigwinch)
+    ((:xcpu :exceeded-cpu)
+     #+cmu unix:sigxcpu
+     #+sbcl sb-posix:sigxcpu)
+    ((:xfsz :exceeded-file-size)
+     #+cmu unix:sigxfsz
+     #+sbcl sb-posix:sigxfsz)
+    ;; oddly this is not defined by neither CMUCL nor SBCL
+    (:info 29)))
+
+(defun sysproc-kill (process signal)
+  (when (keywordp signal)
+    (setf signal (signal-number signal)))
+  #+cmu (ext:process-kill process signal)
+  #+sbcl (sb-ext:process-kill process signal)
+  #-(or sbcl cmu) (error "Don't know how to kill a process"))
+
+(defun sysproc-exit-code (process)
+  #+cmu (ext:process-exit-code process)
+  #+sbcl (sb-ext:process-exit-code process)
+  #-(or sbcl cmu) (error "Don't know how to get a process exit code"))
+
+(defun sysproc-wait (process)
+  #+cmu (ext:process-wait process)
+  #+sbcl (sb-ext:process-wait process)
+  #-(or sbcl cmu) (error "Don't know how to wait a process"))
+
+(defun sysproc-input (process)
+  #+cmu (ext:process-input process)
+  #+sbcl (sb-ext:process-input process)
+  #-(or sbcl cmu) (error "Don't know how to get the process input"))
+
+(defun sysproc-output (process)
+  #+cmu (ext:process-output process)
+  #+sbcl (sb-ext:process-output process)
+  #-(or sbcl cmu) (error "Don't know how to get the process output"))
+
+(defun sysproc-alive-p (process)
+  #+cmu (ext:process-alive-p process)
+  #+sbcl (sb-ext:process-alive-p process)
+  #-(or sbcl cmu) (error "Don't know how to test wether a process might be running"))
+
+(defun sysproc-pid (process)
+  #+cmu (ext:process-pid process)
+  #+sbcl (sb-ext:process-pid process)
+  #-(or sbcl cmu) (error "Don't know how to get the id of a process"))
+
+(defun sysproc-p (thing)
+  #+sbcl (sb-ext:process-p thing)
+  #+cmu (ext:process-p thing)
+  #-(or sbcl cmu) (error "Don't know how to figure out whether something is a system process"))
+
+(defun run-program (program arguments &key (wait t) pty input output error)
+  "Run PROGRAM with ARGUMENTS (a list) and return a process object."
+  ;; convert arguments to strings
+  (setf arguments
+	(mapcar #'(lambda (item)
+		    (typecase item
+		      (string item)
+		      (pathname (native-namestring item))
+		      (t (format nil "~A" item))))
+		arguments))
+  (when *run-verbose*
+    (unless error
+      (setf error t))
+    (format t "~&; run-pipe ~A~{ ~S~}~%" program arguments))
+  #+cmu (ext:run-program program arguments
+			 :wait wait
+			 :pty pty
+			 :input input
+			 :output output
+			 :error (or error *run-verbose*))
+  #+sbcl (sb-ext:run-program program arguments
+			     :search t
+			     :wait wait
+			     :pty pty
+			     :input input
+			     :output output
+			     :error (or error *run-verbose*))
+  #-(or sbcl cmu)
+  (error "Unsupported Lisp system."))
+
+(defun run-pipe (direction program arguments &key error)
+  "Run PROGRAM with a list of ARGUMENTS and according to DIRECTION
+return the input and output streams and process object of that
+process."
+  (be process (run-program program arguments
+			   :wait nil
+			   :pty nil
+			   :input (when (member direction '(:output :input-output :io))
+				    :stream)
+			   :output (when (member direction '(:input :input-output :io))
+				     :stream)
+			   :error error)
+    (values (sysproc-output process)
+	    (sysproc-input process)
+	    process))
+  #-(or sbcl cmu)
+  (error "Unsupported Lisp system."))
+
+(defun exit-code (process)
+  (sysproc-wait process)
+  (sysproc-exit-code process))
+
+(defun run-shell-command (fmt &rest args)
+  "Run a Bourne Shell command.  Return the exit status of the command."
+  (run-program *bourne-shell* (list "-c" (apply #'format nil fmt args))))
+
+(defun run-async-shell-command (fmt &rest args)
+  "Run a Bourne Shell command asynchronously. Return a process
+object if provided by your Lisp implementation."
+  (run-program *bourne-shell* (list "-c" (apply #'format nil fmt args))
+	       :wait nil))
+
+(defmacro with-open-pipe ((in out program arguments &key (process (gensym)) error pty) &body forms)
+  "Run BODY with IN and OUT bound respectively to an input and an
+output stream connected to a system process created by running PROGRAM
+with ARGUMENTS.  If IN or OUT are NIL, then don't create that stream."
+  (with-gensyms (prg args)
+    `(be* ,prg ,program
+	  ,args ,arguments
+	  ,process (run-program ,prg ,args
+				:output ,(case in
+					       ((t nil) in)
+					       (t :stream))
+				:input ,(case out
+					      ((t nil) out)
+					      (t :stream))
+				:wait nil
+				:pty ,pty
+				,@(when error `(:error ,error)))
+       (if ,process
+	   (let (,@(case in
+			 ((t nil))
+			 (t `((,in (sysproc-output ,process)))))
+		 ,@(case out
+			 ((t nil))
+			 (t `((,out (sysproc-input ,process))))))
+	     (unwind-protect
+		  (progn
+		    ,@forms)
+	       ,@(case in
+		       ((t nil))
+		       (t `((close ,in))))
+	       ,@(case out
+		       ((t nil))
+		       (t `((close ,out))))
+	       (when (sysproc-alive-p ,process)
+		 (sysproc-kill ,process :term))))
+	   (error "unable to run ~A~{ ~A~}." ,prg ,args)))))
+
+
+(defun sysproc-set-signal-callback (signal handler)
+  "Arrange HANDLER function to be called when receiving the system
+signal SIGNAL."
+  (when (keywordp signal)
+    (setf signal (signal-number signal)))
+  #+cmu (system:enable-interrupt signal handler)
+  #+sbcl (sb-sys:enable-interrupt signal handler)
+  #-(or cmu sbcl) (error "Don't know how to set a system signal callback."))
diff --git a/third_party/lisp/sclf/time.lisp b/third_party/lisp/sclf/time.lisp
new file mode 100644
index 000000000000..ca1e1902a92c
--- /dev/null
+++ b/third_party/lisp/sclf/time.lisp
@@ -0,0 +1,311 @@
+;;;  time.lisp --- time primitives
+
+;;;  Copyright (C) 2006, 2007, 2009 by Walter C. Pelissero
+
+;;;  Author: Walter C. Pelissero <walter@pelissero.de>
+;;;  Project: sclf
+
+#+cmu (ext:file-comment "$Module: time.lisp $")
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public License
+;;; as published by the Free Software Foundation; either version 2.1
+;;; of the License, or (at your option) any later version.
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free
+;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+;;; 02111-1307 USA
+
+(in-package :sclf)
+
+(defun year (epoch &optional time-zone)
+  "Return the year of EPOCH."
+  (sixth (multiple-value-list (decode-universal-time epoch time-zone))))
+
+(defun month (epoch &optional time-zone)
+  "Return the month of EPOCH."
+  (fifth (multiple-value-list (decode-universal-time epoch time-zone))))
+
+(defun day (epoch &optional time-zone)
+  "Return the day of EPOCH."
+  (fourth (multiple-value-list (decode-universal-time epoch time-zone))))
+
+(defun week-day (epoch &optional time-zone)
+  "Return the day of the week of EPOCH."
+  (seventh (multiple-value-list (decode-universal-time epoch time-zone))))
+
+(defun hour (epoch &optional time-zone)
+  "Return the hour of EPOCH."
+  (third (multiple-value-list (decode-universal-time epoch time-zone))))
+
+(defun minute (epoch &optional time-zone)
+  "Return the minute of EPOCH."
+  (second (multiple-value-list (decode-universal-time epoch time-zone))))
+
+(defun leap-year-p (year)
+  "Return true if YEAR is a leap year."
+  (and (zerop (mod year 4))
+       (or (not (zerop (mod year 100)))
+	   (zerop (mod year 400)))))
+
+(defun last-day-of-month (month year)
+  "Return the last day of the month as integer."
+  (be last (elt #(31 28 31 30 31 30 31 31 30 31 30 31) (1- month))
+    (if (and (= last 28)
+	     (leap-year-p year))
+	(1+ last)
+	last)))
+
+(defun add-months (months epoch &optional time-zone)
+  "Add MONTHS to EPOCH, which is a universal time.  MONTHS can be
+negative."
+  (multiple-value-bind (ss mm hh day month year) (decode-universal-time epoch time-zone)
+    (multiple-value-bind (y m) (floor (+ month months -1) 12)
+      (let ((new-month (1+ m))
+	    (new-year (+ year y)))
+	(encode-universal-time ss mm hh
+			       (min day (last-day-of-month new-month (year epoch)))
+			       new-month
+			       new-year
+			       time-zone)))))
+
+(defun add-days (days epoch)
+  "Add DAYS to EPOCH, which is an universal time.  DAYS can be
+negative."
+  (+ (* 60 60 24 days) epoch))
+
+;; The following two functions are based on Thomas Russ <tar@isi.edu>
+;; code which didn't carry any copyright notice, so I assume it was in
+;; the public domain.
+
+(defun iso-time-string (time &key time-zone with-timezone-p basic)
+  "Return an ISO 8601 string representing TIME.  The time zone is
+included if WITH-TIMEZONE-P is true."
+  (flet ((format-timezone (zone)
+	   (if (zerop zone)
+               "Z"
+               (multiple-value-bind (h m) (truncate (abs zone) 1.0)
+                 ;; Sign of time zone is reversed in ISO 8601 relative
+                 ;; to Common Lisp convention!
+                 (format nil "~:[+~;-~]~2,'0D:~2,'0D"
+                         (> zone 0) h (round m))))))
+    (multiple-value-bind (second minute hour day month year dow dst zone)
+	(decode-universal-time time time-zone)
+      (declare (ignore dow dst))
+      (if basic
+	  (format nil "~4,'0D~2,'0D~2,'0DT~2,'0D~2,'0D~2,'0D~[~*~;~A~]"
+		  year month day hour minute second
+		  with-timezone-p (format-timezone zone))
+	  (format nil "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0D~:[~*~;~A~]"
+		  year month day hour minute second
+		  with-timezone-p (format-timezone zone))))))
+
+(defun parse-iso-time-string (time-string)
+  "Parse an ISO 8601 formated string and return the universal time.
+It can parse the basic and the extended format, but may not be able to
+cover all the cases."
+  (labels ((parse-delimited-string (string delimiter n)
+	     ;; Parses a delimited string and returns a list of
+	     ;; n integers found in that string.
+	     (let ((answer (make-list n :initial-element 0)))
+	       (loop
+		  for i upfrom 0
+		  for start = 0 then (1+ end)
+		  for end = (position delimiter string :start (1+ start))
+		  do (setf (nth i answer)
+			   (parse-integer (subseq string start end)))
+		  when (null end) return t)
+	       (values-list answer)))
+	   (parse-fixed-field-string (string field-sizes)
+	     ;; Parses a string with fixed length fields and returns
+	     ;; a list of integers found in that string.
+	     (let ((answer (make-list (length field-sizes) :initial-element 0)))
+	       (loop
+		  with len = (length string)
+		  for start = 0 then (+ start field-size)
+		  for field-size in field-sizes
+		  for i upfrom 0
+		  while (< start len)
+		  do (setf (nth i answer)
+			   (parse-integer (subseq string start (+ start field-size)))))
+	       (values-list answer)))
+	   (parse-iso8601-date (date-string)
+	     (let ((hyphen-pos (position #\- date-string)))
+	       (if hyphen-pos
+		   (parse-delimited-string date-string #\- 3)
+		   (parse-fixed-field-string date-string '(4 2 2)))))
+	   (parse-iso8601-timeonly (time-string)
+	     (let* ((colon-pos (position #\: time-string))
+		    (zone-pos (or (position #\- time-string)
+				  (position #\+ time-string)))
+		    (timeonly-string (subseq time-string 0 zone-pos))
+		    (zone-string (when zone-pos (subseq time-string (1+ zone-pos))))
+		    (time-zone nil))
+	       (when zone-pos
+		 (multiple-value-bind (zone-h zone-m)
+		     (parse-delimited-string zone-string #\: 2)
+		   (setq time-zone (+ zone-h (/ zone-m 60)))
+		   (when (char= (char time-string zone-pos) #\-)
+		     (setq time-zone (- time-zone)))))
+	       (multiple-value-bind (hh mm ss)
+		   (if colon-pos
+		       (parse-delimited-string timeonly-string #\: 3)
+		       (parse-fixed-field-string timeonly-string '(2 2 2)))
+		 (values hh mm ss time-zone)))))
+    (let ((time-separator (position #\T time-string)))
+      (multiple-value-bind (year month date)
+	  (parse-iso8601-date
+	   (subseq time-string 0 time-separator))
+	(if time-separator
+	    (multiple-value-bind (hh mm ss zone)
+		(parse-iso8601-timeonly
+		 (subseq time-string (1+ time-separator)))
+	      (if zone
+		  ;; Sign of time zone is reversed in ISO 8601
+		  ;; relative to Common Lisp convention!
+		  (encode-universal-time ss mm hh date month year (- zone))
+		  (encode-universal-time ss mm hh date month year)))
+	    (encode-universal-time 0 0 0 date month year))))))
+
+(defun time-string (time &optional time-zone)
+  "Return a string representing TIME in the form:
+  Tue Jan 25 12:55:40 2005"
+  (multiple-value-bind (ss mm hh day month year week-day)
+      (decode-universal-time time time-zone)
+    (format nil "~A ~A ~A ~D:~2,'0D:~2,'0D ~A"
+	    (subseq (week-day->string week-day) 0 3)
+	    (subseq (month->string month) 0 3)
+	    day
+	    hh mm ss
+	    year)))
+
+(defun beginning-of-month (month year &optional time-zone)
+  (encode-universal-time 0 0 0 1 month year time-zone))
+
+(defun end-of-month (month year &optional time-zone)
+  (1- (add-months 1 (encode-universal-time 0 0 0 1 month year time-zone))))
+
+(defun beginning-of-first-week (year &optional time-zone)
+  "Return the epoch of the first week of YEAR.  As the first week
+of the year needs to have Thursday in this YEAR, the returned
+time can actually fall in the previous year."
+  (let* ((Jan-1st (encode-universal-time 0 0 0 1 1 year time-zone))
+	 (start (- 4 (week-day (add-days 4 Jan-1st)))))
+    (add-days start Jan-1st)))
+
+(defun beginning-of-week (week year &optional time-zone)
+  "Return the epoch of the beginning of WEEK of YEAR."
+  (add-days (* (1- week) 7) (beginning-of-first-week year time-zone)))
+
+(defun end-of-week (week year &optional time-zone)
+  "Return the epoch of the beginning of WEEK of YEAR."
+  (1- (beginning-of-week (1+ week) year time-zone)))
+
+(defun end-of-last-week (year &optional time-zone)
+  "Return the epoch of the last week of YEAR.  As the last week
+of the year needs to have Thursday in this YEAR, the returned
+time can fall in the next year."
+  (1- (beginning-of-first-week (1+ year) time-zone)))
+
+(defun seconds-from-beginning-of-the-year (time &optional time-zone)
+  (- time (encode-universal-time 0 0 0 1 1 (year time) time-zone)))
+
+(defun day-of-the-year (time &optional time-zone)
+  "Return the day within the year of TIME starting from 1 up to
+365 (or 366)."
+  (1+ (truncate (seconds-from-beginning-of-the-year time time-zone)
+		(* 60 60 24))))
+
+(defun week (time &optional time-zone)
+  "Return the number of the week and the year TIME referes to.
+Week is an integer from 1 to 52.  Due to the way the first week
+of the year is calculated a day in one year could actually be in
+the last week of the previous or next year."
+  (let* ((year (year time))
+	 (start (beginning-of-first-week year time-zone))
+	 (days-from-start (truncate (- time start) (* 60 60 24)))
+	 (weeks (truncate days-from-start 7))
+	 (week-number (mod weeks 52)))
+    (values (1+ week-number)
+	    (cond ((< weeks 0)
+		   (1- year))
+		  ((> weeks 51)
+		   (1+ year))
+		  (t year)))))
+
+(defun week-day->string (day &optional sunday-first)
+  "Return the weekday string corresponding to DAY number."
+  (elt (if sunday-first
+	   #("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday")
+	   #("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday"))
+       day))
+
+(defconst +month-names+  #("January" "February" "March" "April" "May" "June" "July"
+			   "August" "September" "October" "November" "December"))
+
+(defun month->string (month)
+  "Return the month string corresponding to MONTH number."
+  (elt +month-names+ (1- month)))
+
+(defun month-string->number (month)
+  (1+ (position month +month-names+ :test #'string-equal)))
+
+(defun print-time-span (span &optional stream)
+  "Print in English the time SPAN expressed in seconds."
+  (let* ((minute 60)
+	 (hour (* minute 60))
+	 (day (* hour 24))
+	 (seconds span))
+    (macrolet ((split (divisor)
+		 `(when (>= seconds ,divisor)
+		    (prog1 (truncate seconds ,divisor)
+		      (setf seconds (mod seconds ,divisor))))))
+      (let* ((days (split day))
+	     (hours (split hour))
+	     (minutes (split minute)))
+	(format stream "~{~A~^ ~}" (remove nil
+					   (list
+					    (when days
+					      (format nil "~D day~:P" days))
+					    (when hours
+					      (format nil "~D hour~:P" hours))
+					    (when minutes
+					      (format nil "~D minute~:P" minutes))
+					    (when (or (> seconds 0)
+						      (= span 0))
+					      (format nil "~D second~:P" seconds)))))))))
+
+(defun next-week-day (epoch week-day &optional time-zone)
+  "Return the universal time of the next WEEK-DAY starting from epoch."
+  (add-days (mod (- week-day (week-day epoch time-zone)) 7)
+	    epoch))
+
+(defun next-monday (epoch &optional time-zone)
+  "Return the universal time of the next Monday starting from
+EPOCH."
+  (next-week-day epoch 0 time-zone))
+
+(defun full-weeks-in-span (start end &optional time-zone)
+  "Return the number of full weeks in time span START to END.  A
+full week starts on Monday and ends on Sunday."
+  (be first-monday (next-monday start time-zone)
+    (truncate (- end first-monday) (* 7 24 60 60))))
+
+(defconst +unix-lisp-time-difference+
+  (encode-universal-time 0 0 0 1 1 1970 0)
+  "Time difference between Unix epoch and Common Lisp epoch.  The
+former is 1st January 1970, while the latter is the beginning of the
+XX century.")
+
+(defun universal->unix-time (time)
+  (- time +unix-lisp-time-difference+))
+
+(defun unix->universal-time (time)
+  (+ time +unix-lisp-time-difference+))
+
+(defun get-unix-time ()
+  (universal->unix-time (get-universal-time)))
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..13a63bab1aba
--- /dev/null
+++ b/third_party/lisp/trivial-features.nix
@@ -0,0 +1,16 @@
+{ depot, ... }:
+
+let src = builtins.fetchGit {
+  url = "https://github.com/trivial-features/trivial-features.git";
+  rev = "f6e8dd7268ae0137dbde4be469101a7f735f6416"; # 2021-02-28
+};
+in depot.nix.buildLisp.library {
+  name = "trivial-features";
+  srcs = [
+    {
+      sbcl = src + "/src/tf-sbcl.lisp";
+      ecl = src + "/src/tf-ecl.lisp";
+      ccl = src + "/src/tf-openmcl.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/trivial-indent.nix b/third_party/lisp/trivial-indent.nix
new file mode 100644
index 000000000000..65d98604d78c
--- /dev/null
+++ b/third_party/lisp/trivial-indent.nix
@@ -0,0 +1,17 @@
+
+{ depot, pkgs, ... }:
+
+let
+  src = pkgs.fetchFromGitHub {
+    owner = "Shinmera";
+    repo = "trivial-indent";
+    rev = "2d016941751647c6cc5bd471751c2cf68861c94a";
+    sha256 = "1sj90nqz17w4jq0ixz00gb9g5g6d2s7l8r17zdby27gxxh51w266";
+  };
+in depot.nix.buildLisp.library {
+  name = "trivial-indent";
+
+  srcs = map (f: src + ("/" + f)) [
+    "indent.lisp"
+  ];
+}
diff --git a/third_party/lisp/trivial-ldap.nix b/third_party/lisp/trivial-ldap.nix
new file mode 100644
index 000000000000..c8a27431c687
--- /dev/null
+++ b/third_party/lisp/trivial-ldap.nix
@@ -0,0 +1,26 @@
+{ depot, pkgs, ... }:
+
+let src = pkgs.fetchFromGitHub {
+    owner = "rwiker";
+    repo = "trivial-ldap";
+    rev = "3b8f1ff85f29ea63e6ab2d0d27029d68b046faf8";
+    sha256 = "1zaa4wnk5y5ff211pkg6dl27j4pjwh56hq0246slxsdxv6kvp1z9";
+  };
+in depot.nix.buildLisp.library {
+  name = "trivial-ldap";
+
+  deps = with depot.third_party.lisp; [
+    usocket
+    cl-plus-ssl
+    cl-yacc
+  ];
+
+  srcs = map (f: src + ("/" + f)) [
+    "package.lisp"
+    "trivial-ldap.lisp"
+  ];
+
+  brokenOn = [
+    "ecl" # dynamic cffi
+  ];
+}
diff --git a/third_party/lisp/trivial-mimes.nix b/third_party/lisp/trivial-mimes.nix
new file mode 100644
index 000000000000..ce45993d05e9
--- /dev/null
+++ b/third_party/lisp/trivial-mimes.nix
@@ -0,0 +1,30 @@
+{ depot, pkgs, ... }:
+
+let
+  src = pkgs.fetchFromGitHub {
+    owner = "Shinmera";
+    repo = "trivial-mimes";
+    rev = "a741fc2f567a4f86b853fd4677d75e62c03e51d9";
+    sha256 = "00kcm17q5plpzdj1qwg83ldhxksilgpcdkf3m9azxcdr968xs9di";
+  };
+
+  mime-types = pkgs.runCommand "mime-types.lisp" {} ''
+    substitute ${src}/mime-types.lisp $out \
+      --replace /etc/mime.types ${src}/mime.types \
+      --replace "(asdf:system-source-directory :trivial-mimes)" '"/bogus-dir"'
+      # We want to prevent an ASDF lookup at build time since this will
+      # generally fail — we are not using ASDF after all.
+  '';
+
+in depot.nix.buildLisp.library {
+  name = "trivial-mimes";
+
+  deps = [
+    {
+      sbcl = depot.nix.buildLisp.bundled "uiop";
+      default = depot.nix.buildLisp.bundled "asdf";
+    }
+  ];
+
+  srcs = [ mime-types ];
+}
diff --git a/third_party/lisp/uax-15.nix b/third_party/lisp/uax-15.nix
new file mode 100644
index 000000000000..a13e5c1690d3
--- /dev/null
+++ b/third_party/lisp/uax-15.nix
@@ -0,0 +1,45 @@
+{ depot, pkgs, ... }:
+
+let
+  inherit (pkgs) runCommand;
+  inherit (depot.nix.buildLisp) bundled;
+
+  src = pkgs.fetchFromGitHub {
+    owner = "sabracrolleton";
+    repo = "uax-15";
+    rev = "a62fc7253663fac6467fc6b6bb69a73a0e8dfaa0";
+    sha256 = "028kc3yfi29qjxs2nyr7dbrr2rcrr8lwpvbxvrq3g8bcwamc4jz4";
+  };
+
+  # src = ../../../uax-15;
+
+in depot.nix.buildLisp.library {
+  name = "uax-15";
+
+  deps = with depot.third_party.lisp; [
+    split-sequence
+    cl-ppcre
+    (bundled "asdf")
+  ];
+
+  srcs = [
+    "${src}/uax-15.asd"
+    "${src}/src/package.lisp"
+    "${src}/src/utilities.lisp"
+    "${src}/src/trivial-utf-16.lisp"
+    (runCommand "precomputed-tables.lisp" {} ''
+      substitute ${src}/src/precomputed-tables.lisp precomputed-tables.lisp \
+        --replace "(asdf:system-source-directory (asdf:find-system 'uax-15 nil))" \
+                  '"${src}/"'
+
+      sed -i precomputed-tables.lisp \
+        -e '17i(defvar *canonical-decomp-map*)' \
+        -e '17i(defvar *compatible-decomp-map*)' \
+        -e '17i(defvar *canonical-combining-class*)'
+
+      cp precomputed-tables.lisp $out
+    '')
+    "${src}/src/normalize-backend.lisp"
+    "${src}/src/uax-15.lisp"
+  ];
+}
diff --git a/third_party/lisp/unix-opts.nix b/third_party/lisp/unix-opts.nix
new file mode 100644
index 000000000000..389de25eff4f
--- /dev/null
+++ b/third_party/lisp/unix-opts.nix
@@ -0,0 +1,17 @@
+# unix-opts is a portable command line argument parser
+{ depot, pkgs, ...}:
+
+let
+  src = pkgs.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..dc4281c795c0
--- /dev/null
+++ b/third_party/lisp/usocket.nix
@@ -0,0 +1,51 @@
+# Usocket is a portable socket library
+{ depot, pkgs, ... }:
+
+let
+  inherit (depot.nix) buildLisp;
+
+  src = pkgs.fetchFromGitHub {
+    owner = "usocket";
+    repo = "usocket";
+    rev = "fdf4fd1e0051ce83340ccfbbc8a43a462bb19cf2";
+    sha256 = "0x746wr2324l6bn7skqzgkzcbj5kd0zp2ck0c8rldrw0rzabg826";
+  };
+in buildLisp.library {
+  name = "usocket";
+  deps = with depot.third_party.lisp; [
+    (buildLisp.bundled "asdf")
+    {
+      ecl = buildLisp.bundled "sb-bsd-sockets";
+      sbcl = 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"
+  ] ++ [
+    { sbcl = "${src}/backend/sbcl.lisp"; }
+
+    # ECL actually has two files, it supports the SBCL backend,
+    # but usocket also has some ECL specific code
+    { ecl = "${src}/backend/sbcl.lisp"; }
+    { ecl = "${src}/backend/ecl.lisp"; }
+
+    # Same for CCL
+    { ccl = "${src}/backend/openmcl.lisp"; }
+    { ccl = "${src}/backend/clozure.lisp"; }
+  ]);
+}