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.nix28
-rw-r--r--third_party/lisp/anaphora.nix13
-rw-r--r--third_party/lisp/asdf-flv/.gitattributes2
-rw-r--r--third_party/lisp/asdf-flv/.gitignore3
-rw-r--r--third_party/lisp/asdf-flv/Makefile77
-rw-r--r--third_party/lisp/asdf-flv/README.md7
-rw-r--r--third_party/lisp/asdf-flv/asdf-flv.lisp64
-rw-r--r--third_party/lisp/asdf-flv/default.nix13
-rw-r--r--third_party/lisp/asdf-flv/net.didierverna.asdf-flv.asd43
-rw-r--r--third_party/lisp/asdf-flv/package.lisp28
-rw-r--r--third_party/lisp/babel.nix31
-rw-r--r--third_party/lisp/bordeaux-threads.nix24
-rw-r--r--third_party/lisp/cffi.nix34
-rw-r--r--third_party/lisp/chipz.nix26
-rw-r--r--third_party/lisp/chunga.nix22
-rw-r--r--third_party/lisp/cl-ansi-text.nix16
-rw-r--r--third_party/lisp/cl-base64.nix14
-rw-r--r--third_party/lisp/cl-colors.nix16
-rw-r--r--third_party/lisp/cl-colors2.nix18
-rw-r--r--third_party/lisp/cl-date-time-parser.nix21
-rw-r--r--third_party/lisp/cl-fad.nix27
-rw-r--r--third_party/lisp/cl-json.nix29
-rw-r--r--third_party/lisp/cl-plus-ssl.nix50
-rw-r--r--third_party/lisp/cl-ppcre.nix27
-rw-r--r--third_party/lisp/cl-prevalence.nix25
-rw-r--r--third_party/lisp/cl-smtp.nix24
-rw-r--r--third_party/lisp/cl-unicode.nix80
-rw-r--r--third_party/lisp/cl-who.nix13
-rw-r--r--third_party/lisp/cl-yacc.nix17
-rw-r--r--third_party/lisp/closer-mop.nix19
-rw-r--r--third_party/lisp/closure-common.nix36
-rw-r--r--third_party/lisp/closure-html/default.nix65
-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/defclass-std.nix16
-rw-r--r--third_party/lisp/drakma.nix34
-rw-r--r--third_party/lisp/easy-routes.nix30
-rw-r--r--third_party/lisp/fiveam.nix29
-rw-r--r--third_party/lisp/flexi-streams.nix33
-rw-r--r--third_party/lisp/global-vars.nix7
-rw-r--r--third_party/lisp/hunchentoot.nix62
-rw-r--r--third_party/lisp/ironclad.nix163
-rw-r--r--third_party/lisp/iterate.nix12
-rw-r--r--third_party/lisp/lass.nix35
-rw-r--r--third_party/lisp/let-plus.nix15
-rw-r--r--third_party/lisp/lisp-binary.nix37
-rw-r--r--third_party/lisp/local-time.nix22
-rw-r--r--third_party/lisp/marshal.nix13
-rw-r--r--third_party/lisp/md5.nix16
-rw-r--r--third_party/lisp/metabang-bind.nix16
-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.lisp300
-rw-r--r--third_party/lisp/mime4cl/default.nix50
-rw-r--r--third_party/lisp/mime4cl/endec.lisp697
-rw-r--r--third_party/lisp/mime4cl/mime.lisp1075
-rw-r--r--third_party/lisp/mime4cl/mime4cl-tests.asd55
-rw-r--r--third_party/lisp/mime4cl/mime4cl.asd49
-rw-r--r--third_party/lisp/mime4cl/package.lisp110
-rw-r--r--third_party/lisp/mime4cl/streams.lisp355
-rw-r--r--third_party/lisp/mime4cl/test/address.lisp123
-rw-r--r--third_party/lisp/mime4cl/test/endec.lisp166
-rw-r--r--third_party/lisp/mime4cl/test/mime.lisp54
-rw-r--r--third_party/lisp/mime4cl/test/package.lisp27
-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.nix13
-rw-r--r--third_party/lisp/nibbles.nix26
-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.nix15
-rw-r--r--third_party/lisp/parse-number.nix9
-rw-r--r--third_party/lisp/parseq.nix13
-rw-r--r--third_party/lisp/physical-quantities.nix24
-rw-r--r--third_party/lisp/postmodern.nix94
-rw-r--r--third_party/lisp/prove.nix29
-rw-r--r--third_party/lisp/puri.nix10
-rw-r--r--third_party/lisp/quasiquote_2/README.md258
-rw-r--r--third_party/lisp/quasiquote_2/default.nix17
-rw-r--r--third_party/lisp/quasiquote_2/macros.lisp15
-rw-r--r--third_party/lisp/quasiquote_2/package.lisp11
-rw-r--r--third_party/lisp/quasiquote_2/quasiquote-2.0.asd30
-rw-r--r--third_party/lisp/quasiquote_2/quasiquote-2.0.lisp340
-rw-r--r--third_party/lisp/quasiquote_2/readers.lisp77
-rw-r--r--third_party/lisp/quasiquote_2/tests-macro.lisp21
-rw-r--r--third_party/lisp/quasiquote_2/tests.lisp143
-rw-r--r--third_party/lisp/rfc2388.nix12
-rw-r--r--third_party/lisp/routes.nix39
-rw-r--r--third_party/lisp/s-sysdeps.nix18
-rw-r--r--third_party/lisp/s-xml/0001-fix-definition-order-in-xml.lisp.patch26
-rw-r--r--third_party/lisp/s-xml/default.nix25
-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.nix15
-rw-r--r--third_party/lisp/trivial-backtrace.nix15
-rw-r--r--third_party/lisp/trivial-features.nix13
-rw-r--r--third_party/lisp/trivial-garbage.nix9
-rw-r--r--third_party/lisp/trivial-gray-streams.nix13
-rw-r--r--third_party/lisp/trivial-indent.nix10
-rw-r--r--third_party/lisp/trivial-ldap.nix28
-rw-r--r--third_party/lisp/trivial-mimes.nix26
-rw-r--r--third_party/lisp/uax-15.nix43
-rw-r--r--third_party/lisp/unix-opts.nix12
-rw-r--r--third_party/lisp/usocket-server.nix19
-rw-r--r--third_party/lisp/usocket.nix46
131 files changed, 13744 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.nix b/third_party/lisp/alexandria.nix
new file mode 100644
index 000000000000..b522e2d142c1
--- /dev/null
+++ b/third_party/lisp/alexandria.nix
@@ -0,0 +1,28 @@
+# Alexandria is one of the foundational Common Lisp libraries that
+# pretty much everything depends on.
+{ depot, pkgs, ... }:
+
+let src = with pkgs; srcOnly lispPackages.alexandria;
+in depot.nix.buildLisp.library {
+  name = "alexandria";
+
+  srcs = map (f: src + ("/alexandria-1/" + f)) [
+    "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/anaphora.nix b/third_party/lisp/anaphora.nix
new file mode 100644
index 000000000000..c079943e6725
--- /dev/null
+++ b/third_party/lisp/anaphora.nix
@@ -0,0 +1,13 @@
+{ depot, pkgs, ... }:
+
+let src = with pkgs; srcOnly lispPackages.anaphora;
+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..ae7c5dd23d18
--- /dev/null
+++ b/third_party/lisp/babel.nix
@@ -0,0 +1,31 @@
+# Babel is an encoding conversion library for Common Lisp.
+{ depot, pkgs, ... }:
+
+let src = with pkgs; srcOnly lispPackages.babel;
+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..8a2e09950887
--- /dev/null
+++ b/third_party/lisp/bordeaux-threads.nix
@@ -0,0 +1,24 @@
+# This library is meant to make writing portable multi-threaded apps
+# in Common Lisp simple.
+{ depot, pkgs, ... }:
+
+let
+  src = with pkgs; srcOnly lispPackages.bordeaux-threads;
+  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..de1d0c2e8ed7
--- /dev/null
+++ b/third_party/lisp/cffi.nix
@@ -0,0 +1,34 @@
+# CFFI purports to be the Common Foreign Function Interface.
+{ depot, pkgs, ... }:
+
+with depot.nix;
+let src = with pkgs; srcOnly lispPackages.cffi;
+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/chipz.nix b/third_party/lisp/chipz.nix
new file mode 100644
index 000000000000..59e9914ee1d1
--- /dev/null
+++ b/third_party/lisp/chipz.nix
@@ -0,0 +1,26 @@
+# Common Lisp library for decompressing deflate, zlib, gzip, and bzip2 data
+{ depot, pkgs, ... }:
+
+let src = with pkgs; srcOnly lispPackages.chipz;
+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..d3f50bcb1af8
--- /dev/null
+++ b/third_party/lisp/chunga.nix
@@ -0,0 +1,22 @@
+# Portable chunked streams for Common Lisp
+{ depot, pkgs, ... }:
+
+let src = with pkgs; srcOnly lispPackages.chunga;
+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..0e3401524755
--- /dev/null
+++ b/third_party/lisp/cl-ansi-text.nix
@@ -0,0 +1,16 @@
+# Enables ANSI colors for printing.
+{ depot, pkgs, ... }:
+
+let src = with pkgs; srcOnly lispPackages.cl-ansi-text;
+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..08055a047119
--- /dev/null
+++ b/third_party/lisp/cl-base64.nix
@@ -0,0 +1,14 @@
+# Base64 encoding for Common Lisp
+{ depot, pkgs, ... }:
+
+let src = with pkgs; srcOnly lispPackages.cl-base64;
+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-colors.nix b/third_party/lisp/cl-colors.nix
new file mode 100644
index 000000000000..b51e4d46a747
--- /dev/null
+++ b/third_party/lisp/cl-colors.nix
@@ -0,0 +1,16 @@
+{ depot, pkgs, ... }:
+
+let src = with pkgs; srcOnly lispPackages.cl-colors;
+in depot.nix.buildLisp.library {
+  name = "cl-colors";
+  deps = [
+    depot.third_party.lisp.alexandria
+    depot.third_party.lisp.let-plus
+  ];
+  srcs = [
+    "${src}/package.lisp"
+    "${src}/colors.lisp"
+    "${src}/colornames.lisp"
+    "${src}/hexcolors.lisp"
+  ];
+}
diff --git a/third_party/lisp/cl-colors2.nix b/third_party/lisp/cl-colors2.nix
new file mode 100644
index 000000000000..34201bc2faa0
--- /dev/null
+++ b/third_party/lisp/cl-colors2.nix
@@ -0,0 +1,18 @@
+{ depot, pkgs, ... }:
+
+let src = with pkgs; srcOnly lispPackages.cl-colors2;
+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-x11.lisp"
+    "colornames-svg.lisp"
+    "hexcolors.lisp"
+  ];
+}
diff --git a/third_party/lisp/cl-date-time-parser.nix b/third_party/lisp/cl-date-time-parser.nix
new file mode 100644
index 000000000000..e53cb2dfce42
--- /dev/null
+++ b/third_party/lisp/cl-date-time-parser.nix
@@ -0,0 +1,21 @@
+{ depot, pkgs, ... }:
+
+depot.nix.buildLisp.library {
+  name = "cl-date-time-parser";
+
+  srcs = [
+    (pkgs.fetchurl {
+      url = "https://raw.githubusercontent.com/tkych/cl-date-time-parser/00d6fc70b599f460fdf13cf0cf7e6bf843312410/date-time-parser.lisp";
+      sha256 = "0zrkv1q3sx5ksijxhw45ixf1hy5b9biii6i6v41h12q6pbkfqz69";
+    })
+  ];
+
+  deps = [
+    depot.third_party.lisp.alexandria
+    depot.third_party.lisp.anaphora
+    depot.third_party.lisp.split-sequence
+    depot.third_party.lisp.cl-ppcre
+    depot.third_party.lisp.local-time
+    depot.third_party.lisp.parse-float
+  ];
+}
diff --git a/third_party/lisp/cl-fad.nix b/third_party/lisp/cl-fad.nix
new file mode 100644
index 000000000000..9350abe2e3a3
--- /dev/null
+++ b/third_party/lisp/cl-fad.nix
@@ -0,0 +1,27 @@
+# Portable pathname library
+{ depot, pkgs, ... }:
+
+with depot.nix;
+
+let src = with pkgs; srcOnly lispPackages.cl-fad;
+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..0230f274afc0
--- /dev/null
+++ b/third_party/lisp/cl-json.nix
@@ -0,0 +1,29 @@
+# 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..dc0a95944fe7
--- /dev/null
+++ b/third_party/lisp/cl-plus-ssl.nix
@@ -0,0 +1,50 @@
+# Common Lisp bindings to OpenSSL
+{ depot, pkgs, ... }:
+
+with depot.nix;
+
+let
+  src = pkgs.fetchgit {
+    url = "https://github.com/cl-plus-ssl/cl-plus-ssl.git";
+    rev = "29081992f6d7b4e3aa2c5eeece4cd92b745071f4";
+    hash = "sha256:16lyrixl98b7vy29dbbzkbq0xaz789350dajrr1gdny5i55rkjq0";
+  };
+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..561e306191ca
--- /dev/null
+++ b/third_party/lisp/cl-ppcre.nix
@@ -0,0 +1,27 @@
+# cl-ppcre is a Common Lisp regular expression library.
+{ depot, pkgs, ... }:
+
+let src = with pkgs; srcOnly lispPackages.cl-ppcre;
+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..188cbc686d28
--- /dev/null
+++ b/third_party/lisp/cl-prevalence.nix
@@ -0,0 +1,25 @@
+# cl-prevalence is an implementation of object prevalence for CL (i.e.
+# an in-memory database)
+{ depot, pkgs, ... }:
+
+let src = with pkgs; srcOnly lispPackages.cl-prevalence;
+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..7ab9bea59ff5
--- /dev/null
+++ b/third_party/lisp/cl-smtp.nix
@@ -0,0 +1,24 @@
+{ depot, pkgs, ... }:
+
+let src = with pkgs; srcOnly lispPackages.cl-smtp;
+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..815d99c2dc8e
--- /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..601b09f118db
--- /dev/null
+++ b/third_party/lisp/cl-who.nix
@@ -0,0 +1,13 @@
+{ depot, pkgs, ... }:
+
+let src = with pkgs; srcOnly lispPackages.cl-who;
+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..b40d5d0601b2
--- /dev/null
+++ b/third_party/lisp/cl-yacc.nix
@@ -0,0 +1,17 @@
+{ 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..145b9cfd4325
--- /dev/null
+++ b/third_party/lisp/closer-mop.nix
@@ -0,0 +1,19 @@
+# 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 = with pkgs; srcOnly lispPackages.closer-mop;
+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..7f7f79f8551b
--- /dev/null
+++ b/third_party/lisp/closure-common.nix
@@ -0,0 +1,36 @@
+{ depot, pkgs, ... }:
+
+let
+  src = with pkgs; srcOnly lispPackages.closure-common;
+  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..1886ea2ec9a2
--- /dev/null
+++ b/third_party/lisp/closure-html/default.nix
@@ -0,0 +1,65 @@
+{ depot, pkgs, ... }:
+
+let
+  src = pkgs.applyPatches {
+    name = "closure-html-source";
+    src = pkgs.lispPackages.closure-html.src;
+
+    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/defclass-std.nix b/third_party/lisp/defclass-std.nix
new file mode 100644
index 000000000000..c31ddb3c5b74
--- /dev/null
+++ b/third_party/lisp/defclass-std.nix
@@ -0,0 +1,16 @@
+# A shortcut macro to write DEFCLASS forms quickly
+# Seems to be unmaintained (since early 2021)
+{ depot, pkgs, ... }:
+
+let src = with pkgs; srcOnly lispPackages.defclass-std;
+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..607f438d7e72
--- /dev/null
+++ b/third_party/lisp/drakma.nix
@@ -0,0 +1,34 @@
+# Drakma is an HTTP client for Common Lisp.
+{ depot, pkgs, ... }:
+
+let src = with pkgs; srcOnly lispPackages.drakma;
+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..5caf8261fa1c
--- /dev/null
+++ b/third_party/lisp/easy-routes.nix
@@ -0,0 +1,30 @@
+{ 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.nix b/third_party/lisp/fiveam.nix
new file mode 100644
index 000000000000..500e980a819a
--- /dev/null
+++ b/third_party/lisp/fiveam.nix
@@ -0,0 +1,29 @@
+# FiveAM is a Common Lisp testing framework.
+#
+# Imported from https://github.com/sionescu/fiveam.git
+
+{ depot, pkgs, ... }:
+
+let src = with pkgs; srcOnly lispPackages.fiveam;
+in depot.nix.buildLisp.library {
+  name = "fiveam";
+
+  deps = with depot.third_party.lisp; [
+    alexandria
+    asdf-flv
+    trivial-backtrace
+  ];
+
+  srcs = map (f: src + ("/src/" + f)) [
+    "package.lisp"
+    "utils.lisp"
+    "check.lisp"
+    "fixture.lisp"
+    "classes.lisp"
+    "random.lisp"
+    "test.lisp"
+    "explain.lisp"
+    "suite.lisp"
+    "run.lisp"
+  ];
+}
diff --git a/third_party/lisp/flexi-streams.nix b/third_party/lisp/flexi-streams.nix
new file mode 100644
index 000000000000..a6a06d4ad057
--- /dev/null
+++ b/third_party/lisp/flexi-streams.nix
@@ -0,0 +1,33 @@
+# Flexible bivalent streams for Common Lisp
+{ depot, pkgs, ... }:
+
+let src = with pkgs; srcOnly lispPackages.flexi-streams;
+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"
+    "mac.lisp"
+    "iso-8859.lisp"
+    "enc-cn-tbl.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..a3d27a09b6a0
--- /dev/null
+++ b/third_party/lisp/global-vars.nix
@@ -0,0 +1,7 @@
+{ depot, pkgs, ... }:
+
+let src = with pkgs; srcOnly lispPackages.global-vars;
+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..e2480cd349f1
--- /dev/null
+++ b/third_party/lisp/hunchentoot.nix
@@ -0,0 +1,62 @@
+# Hunchentoot is a web framework for Common Lisp.
+{ depot, pkgs, ... }:
+
+let
+  src = with pkgs; srcOnly lispPackages.hunchentoot;
+
+  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..324c5da265d8
--- /dev/null
+++ b/third_party/lisp/ironclad.nix
@@ -0,0 +1,163 @@
+{ depot, pkgs, ... }:
+
+let
+  inherit (pkgs) runCommand;
+  inherit (depot.nix.buildLisp) bundled;
+  src = with pkgs; srcOnly lispPackages.ironclad;
+  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 = map getSrc [
+    # {
+    #   # 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";
+    # }
+    "package.lisp"
+    "conditions.lisp"
+    "generic.lisp"
+    "macro-utils.lisp"
+    "util.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"
+
+    "ciphers/cipher.lisp"
+    "ciphers/padding.lisp"
+    "ciphers/make-cipher.lisp"
+    "ciphers/modes.lisp"
+
+    # subsystem def ironclad/ciphers
+    "ciphers/aes.lisp"
+    "ciphers/arcfour.lisp"
+    "ciphers/aria.lisp"
+    "ciphers/blowfish.lisp"
+    "ciphers/camellia.lisp"
+    "ciphers/cast5.lisp"
+    "ciphers/chacha.lisp"
+    "ciphers/des.lisp"
+    "ciphers/idea.lisp"
+    "ciphers/kalyna.lisp"
+    "ciphers/kuznyechik.lisp"
+    "ciphers/misty1.lisp"
+    "ciphers/rc2.lisp"
+    "ciphers/rc5.lisp"
+    "ciphers/rc6.lisp"
+    "ciphers/salsa20.lisp"
+    "ciphers/keystream.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/xchacha.lisp"
+    "ciphers/xor.lisp"
+    "ciphers/xsalsa20.lisp"
+    "ciphers/xtea.lisp"
+
+    "digests/digest.lisp"
+    # subsystem def ironclad/digests
+    "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"
+
+    "macs/mac.lisp"
+    # subsystem def ironclad/macs
+    "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"
+
+    "prng/prng.lisp"
+    "prng/os-prng.lisp"
+    "prng/generator.lisp"
+    "prng/fortuna.lisp"
+
+    "math.lisp"
+
+    "octet-stream.lisp"
+
+    "aead/aead.lisp"
+    # subsystem def ironclad/aead
+    "aead/eax.lisp"
+    "aead/etm.lisp"
+    "aead/gcm.lisp"
+
+    "kdf/kdf.lisp"
+    # subsystem def ironclad/kdfs
+    "kdf/argon2.lisp"
+    "kdf/bcrypt.lisp"
+    "kdf/hmac.lisp"
+    "kdf/pkcs5.lisp"
+    "kdf/password-hash.lisp"
+    "kdf/scrypt.lisp"
+
+    "public-key/public-key.lisp"
+    "public-key/pkcs1.lisp"
+    "public-key/elliptic-curve.lisp"
+    # subsystem def ironclad/public-keys
+    "public-key/dsa.lisp"
+    "public-key/rsa.lisp"
+    "public-key/elgamal.lisp"
+    "public-key/curve25519.lisp"
+    "public-key/curve448.lisp"
+    "public-key/ed25519.lisp"
+    "public-key/ed448.lisp"
+    "public-key/secp256k1.lisp"
+    "public-key/secp256r1.lisp"
+    "public-key/secp384r1.lisp"
+    "public-key/secp521r1.lisp"
+  ];
+}
diff --git a/third_party/lisp/iterate.nix b/third_party/lisp/iterate.nix
new file mode 100644
index 000000000000..b7d60265ac37
--- /dev/null
+++ b/third_party/lisp/iterate.nix
@@ -0,0 +1,12 @@
+# iterate is an iteration construct for Common Lisp, similar to the
+# LOOP macro.
+{ depot, pkgs, ... }:
+
+let src = with pkgs; srcOnly lispPackages.iterate;
+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..00f66c1fe314
--- /dev/null
+++ b/third_party/lisp/lass.nix
@@ -0,0 +1,35 @@
+{ 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/let-plus.nix b/third_party/lisp/let-plus.nix
new file mode 100644
index 000000000000..bd7f31dfa0de
--- /dev/null
+++ b/third_party/lisp/let-plus.nix
@@ -0,0 +1,15 @@
+{ depot, pkgs, ... }:
+
+let src = with pkgs; srcOnly lispPackages.let-plus;
+in depot.nix.buildLisp.library {
+  name = "let-plus";
+  deps = [
+    depot.third_party.lisp.alexandria
+    depot.third_party.lisp.anaphora
+  ];
+  srcs = [
+    "${src}/package.lisp"
+    "${src}/let-plus.lisp"
+    "${src}/extensions.lisp"
+  ];
+}
diff --git a/third_party/lisp/lisp-binary.nix b/third_party/lisp/lisp-binary.nix
new file mode 100644
index 000000000000..8deba4546fe6
--- /dev/null
+++ b/third_party/lisp/lisp-binary.nix
@@ -0,0 +1,37 @@
+# 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..1358408d387c
--- /dev/null
+++ b/third_party/lisp/local-time.nix
@@ -0,0 +1,22 @@
+# Library for manipulating dates & times
+{ depot, pkgs, ... }:
+
+let
+  inherit (depot.nix) buildLisp;
+  src = with pkgs; srcOnly lispPackages.local-time;
+in
+buildLisp.library {
+  name = "local-time";
+  deps = [
+    depot.third_party.lisp.cl-fad
+    {
+      scbl = buildLisp.bundled "uiop";
+      default = buildLisp.bundled "asdf";
+    }
+  ];
+
+  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..73a1664a0162
--- /dev/null
+++ b/third_party/lisp/marshal.nix
@@ -0,0 +1,13 @@
+{ depot, pkgs, ... }:
+
+let src = with pkgs; srcOnly lispPackages.marshal;
+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..8c3e255f166b
--- /dev/null
+++ b/third_party/lisp/md5.nix
@@ -0,0 +1,16 @@
+# MD5 hash implementation
+{ depot, pkgs, ... }:
+
+with depot.nix;
+
+let src = with pkgs; srcOnly lispPackages.md5;
+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/metabang-bind.nix b/third_party/lisp/metabang-bind.nix
new file mode 100644
index 000000000000..fc046d08951a
--- /dev/null
+++ b/third_party/lisp/metabang-bind.nix
@@ -0,0 +1,16 @@
+{ depot, pkgs, ... }:
+
+let
+  getSrcs = builtins.map (p: "${pkgs.srcOnly pkgs.lispPackages.metabang-bind}/${p}");
+in
+
+depot.nix.buildLisp.library {
+  name = "metabang-bind";
+
+  srcs = getSrcs [
+    "dev/packages.lisp"
+    "dev/macros.lisp"
+    "dev/bind.lisp"
+    "dev/binding-forms.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..944156916c0f
--- /dev/null
+++ b/third_party/lisp/mime4cl/address.lisp
@@ -0,0 +1,300 @@
+;;;  address.lisp --- e-mail address parser
+
+;;;  Copyright (C) 2007, 2008, 2009 by Walter C. Pelissero
+;;;  Copyright (C) 2022 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
+
+;;;  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..9d3d6253f480
--- /dev/null
+++ b/third_party/lisp/mime4cl/default.nix
@@ -0,0 +1,50 @@
+# 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.babel
+    depot.third_party.lisp.sclf
+    depot.third_party.lisp.npg
+    depot.third_party.lisp.trivial-gray-streams
+  ];
+
+  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..020c212e5ec4
--- /dev/null
+++ b/third_party/lisp/mime4cl/endec.lisp
@@ -0,0 +1,697 @@
+;;;  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-part (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-part 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))))
+
+(defun decode-RFC2047 (text)
+  "Decode TEXT into a fully decoded string. Whenever a non ASCII part is
+  encountered, try to decode it using babel, otherwise signal an error."
+  (flet ((decode-part (part)
+           (etypecase part
+             (cons (babel:octets-to-string
+                    (car part)
+                    :encoding (babel-encodings:get-character-encoding
+                               (intern (string-upcase (cdr part)) 'keyword))))
+             (string part))))
+    (apply #'concatenate
+           (cons 'string
+                 (mapcar #'decode-part (mime:parse-RFC2047-text text))))))
diff --git a/third_party/lisp/mime4cl/mime.lisp b/third_party/lisp/mime4cl/mime.lisp
new file mode 100644
index 000000000000..5639aab23641
--- /dev/null
+++ b/third_party/lisp/mime4cl/mime.lisp
@@ -0,0 +1,1075 @@
+;;;  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."))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun mime-message-header-values (name message &key decode)
+  "Return all values of the header with NAME in MESSAGE, optionally decoding
+  it according to RFC2047 if :DECODE is T."
+  (loop ;; A header may occur multiple times
+        for header in (mime-message-headers message)
+        ;; MIME Headers should be case insensitive
+        ;; https://stackoverflow.com/a/6143644
+        when (string-equal (car header) name)
+        collect (if decode
+                    (decode-RFC2047 (cdr header))
+                    (cdr header))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(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..f3b429eafbf7
--- /dev/null
+++ b/third_party/lisp/mime4cl/mime4cl-tests.asd
@@ -0,0 +1,55 @@
+;;;  mime4cl-tests.asd --- system description for the regression tests
+
+;;;  Copyright (C) 2006, 2007, 2010 by Walter C. Pelissero
+;;;  Copyright (C) 2022 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
+
+#-(or sbcl)
+(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..6528f115d47a
--- /dev/null
+++ b/third_party/lisp/mime4cl/mime4cl.asd
@@ -0,0 +1,49 @@
+;;;  mime4cl.asd --- system definition
+
+;;;  Copyright (C) 2005-2007, 2010 by Walter C. Pelissero
+;;;  Copyright (C) 2022 by The TVL Authors
+
+;;;  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)
+
+(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 :trivial-gray-streams)
+    :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..5586bdc390e5
--- /dev/null
+++ b/third_party/lisp/mime4cl/package.lisp
@@ -0,0 +1,110 @@
+;;;  package.lisp --- package declaration
+
+;;;  Copyright (C) 2005-2007, 2010 by Walter C. Pelissero
+;;;  Copyright (C) 2022 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 :cl-user)
+
+(defpackage :mime4cl
+  (:nicknames :mime)
+  (:use :common-lisp :npg :sclf :trivial-gray-streams)
+  ;; 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)
+  (:import-from :babel :octets-to-string)
+  (:import-from :babel-encodings :get-character-encoding)
+  (: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-message-header-values
+           #: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..dcac6ac34192
--- /dev/null
+++ b/third_party/lisp/mime4cl/streams.lisp
@@ -0,0 +1,355 @@
+;;; streams.lisp --- En/De-coding Streams
+
+;;; Copyright (C) 2012 by Walter C. Pelissero
+;;; Copyright (C) 2021-2022 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 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))
+  (file-position (slot-value stream 'real-stream)))
+
+(defmethod (setf stream-file-position) (newval (stream coder-stream-mixin))
+  (file-position (slot-value stream 'real-stream) newval))
+
+(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))
+   (current-offset :type 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
+    (file-position stream start-offset)))
+
+(defmethod (setf stream-file-position) (newval (stream delimited-input-stream))
+  (with-slots (current-offset real-stream) stream
+    (setf current-offset newval)
+    (call-next-method)))
+
+(defmethod stream-file-position ((stream delimited-input-stream))
+  (slot-value stream 'current-offset))
+
+;; Calling file-position with SBCL on every read is quite expensive, since
+;; it will invoke lseek each time. This is so expensive that it's faster to
+;; /compute/ the amount the stream got advanced by.
+;; file-position's behavior however, is quite flexible and it behaves differently
+;; not only for different implementation, but also different streams in SBCL.
+;; Thus, we should ideally go back to file-position and try to reduce the amount
+;; of calls by using read-sequence.
+;; TODO(sterni): make decoders use read-sequence and drop offset tracking code
+(macrolet ((def-stream-read (name read-fun update-offset-form)
+             `(defmethod ,name ((stream delimited-input-stream))
+               (with-slots (real-stream end-offset current-offset) stream
+                 (let ((el (if (or (not end-offset)
+                                   (< current-offset end-offset))
+                               (or (,read-fun real-stream nil)
+                                   :eof)
+                               :eof)))
+                   (setf current-offset ,update-offset-form)
+                   el)))))
+
+  ;; Assume we are using an encoding where < 128 is one byte, in all other cases
+  ;; it's hard to guess how much file-position will increase
+  (def-stream-read stream-read-char read-char
+    (if (or (eq el :eof) (< (char-code el) 128))
+        (1+ current-offset)
+        (file-position real-stream)))
+
+  (def-stream-read stream-read-byte read-byte (1+ current-offset)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(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..a3653985c40e
--- /dev/null
+++ b/third_party/lisp/mime4cl/test/address.lisp
@@ -0,0 +1,123 @@
+;;;  address.lisp --- tests for the e-mail address parser
+
+;;;  Copyright (C) 2007, 2009 by Walter C. Pelissero
+;;;  Copyright (C) 2022 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-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..5e8d43a7d4f8
--- /dev/null
+++ b/third_party/lisp/mime4cl/test/endec.lisp
@@ -0,0 +1,166 @@
+;;;  endec.lisp --- test suite for the MIME encoder/decoder functions
+
+;;;  Copyright (C) 2006, 2007, 2009, 2010 by Walter C. Pelissero
+;;;  Copyright (C) 2022 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-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..8d9397859994
--- /dev/null
+++ b/third_party/lisp/mime4cl/test/mime.lisp
@@ -0,0 +1,54 @@
+;;; mime.lisp --- MIME regression tests
+
+;;; Copyright (C) 2012 by Walter C. Pelissero
+;;; Copyright (C) 2021-2022 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-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..6da1fc8fa29f
--- /dev/null
+++ b/third_party/lisp/mime4cl/test/package.lisp
@@ -0,0 +1,27 @@
+;;;  package.lisp --- package description for the regression tests
+
+;;;  Copyright (C) 2006, 2009 by Walter C. Pelissero
+;;;  Copyright (C) 2022 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
+
+(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..06160debbe9b
--- /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..d38fbcb9469a
--- /dev/null
+++ b/third_party/lisp/moptilities.nix
@@ -0,0 +1,13 @@
+# Compatibility layer for minor MOP implementation differences
+{ depot, pkgs, ... }:
+
+let src = with pkgs; srcOnly lispPackages.moptilities;
+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..b71f439c939a
--- /dev/null
+++ b/third_party/lisp/nibbles.nix
@@ -0,0 +1,26 @@
+{ depot, pkgs, ... }:
+
+let
+  inherit (depot.nix.buildLisp) bundled;
+  src = with pkgs; srcOnly lispPackages.nibbles;
+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..a45ac614f716
--- /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..9ebd45a169ce
--- /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..1e35186d6c8c
--- /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..783f071fc5d9
--- /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..c15d26fe394e
--- /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..e90824108ed1
--- /dev/null
+++ b/third_party/lisp/parse-float.nix
@@ -0,0 +1,15 @@
+{ depot, pkgs, ... }:
+
+let src = with pkgs; srcOnly lispPackages.parse-float;
+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..61b0b1fddbda
--- /dev/null
+++ b/third_party/lisp/parse-number.nix
@@ -0,0 +1,9 @@
+{ depot, pkgs, ... }:
+
+let src = with pkgs; srcOnly lispPackages.parse-number;
+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..23c67c2d9c30
--- /dev/null
+++ b/third_party/lisp/parseq.nix
@@ -0,0 +1,13 @@
+{ depot, pkgs, ... }:
+
+let src = with pkgs; srcOnly lispPackages.parseq;
+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..d594ff1a1cf7
--- /dev/null
+++ b/third_party/lisp/physical-quantities.nix
@@ -0,0 +1,24 @@
+{ depot, pkgs, ... }:
+
+let src = with pkgs; srcOnly lispPackages.physical-quantities;
+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..25e0625c20bc
--- /dev/null
+++ b/third_party/lisp/postmodern.nix
@@ -0,0 +1,94 @@
+{ depot, pkgs, ... }:
+
+let
+  inherit (depot.nix.buildLisp) bundled;
+  src = with pkgs; srcOnly lispPackages.postmodern;
+
+  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"
+      "config.lisp"
+      "oid.lisp"
+      "errors.lisp"
+      "data-types.lisp"
+      "sql-string.lisp"
+      "trivial-utf-8.lisp"
+      "strings-utf-8.lisp"
+      "communicate.lisp"
+      "messages.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"
+      "config.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"
+      "config.lisp"
+      "connect.lisp"
+      "json-encoder.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/prove.nix b/third_party/lisp/prove.nix
new file mode 100644
index 000000000000..af481499207f
--- /dev/null
+++ b/third_party/lisp/prove.nix
@@ -0,0 +1,29 @@
+{ depot, pkgs, ... }:
+
+let src = with pkgs; srcOnly lispPackages.prove;
+in depot.nix.buildLisp.library {
+  name = "prove";
+
+  deps = [
+    depot.third_party.lisp.alexandria
+    depot.third_party.lisp.cl-ansi-text
+    depot.third_party.lisp.cl-colors
+    depot.third_party.lisp.cl-ppcre
+    (depot.nix.buildLisp.bundled "asdf")
+  ];
+
+  srcs = [
+    "${src}/src/color.lisp"
+    "${src}/src/output.lisp"
+    "${src}/src/asdf.lisp"
+    "${src}/src/report.lisp"
+    "${src}/src/reporter.lisp"
+    "${src}/src/reporter/fiveam.lisp"
+    "${src}/src/reporter/list.lisp"
+    "${src}/src/reporter/dot.lisp"
+    "${src}/src/reporter/tap.lisp"
+    "${src}/src/suite.lisp"
+    "${src}/src/test.lisp"
+    "${src}/src/prove.lisp"
+  ];
+}
diff --git a/third_party/lisp/puri.nix b/third_party/lisp/puri.nix
new file mode 100644
index 000000000000..f7146ba93f1f
--- /dev/null
+++ b/third_party/lisp/puri.nix
@@ -0,0 +1,10 @@
+# Portable URI library
+{ depot, pkgs, ... }:
+
+let src = with pkgs; srcOnly lispPackages.puri;
+in depot.nix.buildLisp.library {
+  name = "puri";
+  srcs = [
+    (src + "/src.lisp")
+  ];
+}
diff --git a/third_party/lisp/quasiquote_2/README.md b/third_party/lisp/quasiquote_2/README.md
new file mode 100644
index 000000000000..2d590a0564ae
--- /dev/null
+++ b/third_party/lisp/quasiquote_2/README.md
@@ -0,0 +1,258 @@
+quasiquote-2.0
+==============
+
+Why should it be hard to write macros that write other macros?
+Well, it shouldn't!
+
+quasiquote-2.0 defines slightly different rules for quasiquotation,
+that make writing macro-writing macros very smooth experience.
+
+NOTE: quasiquote-2.0 does horrible things to shared structure!!!
+(it does a lot of COPY-TREE's, so shared-ness is destroyed).
+So, it's indeed a tool to construct code (where it does not matter much if the
+structure is shared or not) and not the data (or, at least, not the data with shared structure)
+
+
+```lisp
+(quasiquote-2.0:enable-quasiquote-2.0)
+
+(defmacro define-my-macro (name args &body body)
+  `(defmacro ,name ,args
+     `(sample-thing-to-expand-to
+        ,,@body))) ; note the difference from usual way
+
+(define-my-macro foo (x y)
+  ,x ; now here injections of quotation constructs work
+  ,y)
+
+(define-my-macro bar (&body body)
+  ,@body) ; splicing is also easy
+```
+
+The "injections" in macros FOO and BAR work as naively expected, as if I had written
+```lisp
+(defmacro foo (x y)
+  `(sample-thing-to-expand-to ,x ,y))
+
+(defmacro bar (&body body)
+  `(sample-thing-to-expand-to ,@body))
+
+(macroexpand-1 '(foo a b))
+
+  '(SAMPLE-THING-TO-EXPAND-TO A B)
+
+(macroexpand-1 '(bar a b c))
+
+  '(SAMPLE-THING-TO-EXPAND-TO A B C)
+```
+
+
+So, how is this effect achieved?
+
+
+DIG, INJECT and SPLICE
+-------------------------
+
+The transformations of backquote occur at macroexpansion-time and not at read-time.
+It is totally possible not to use any special reader syntax, but just
+underlying macros directly!
+
+At the core is a macro DIG, which expands to the code that generates the
+expression according to the rules, which are roughly these:
+  * each DIG increases "depth" by one (hence the name)
+  * each INJECT or SPLICE decreases "depth" by one
+  * if depth is 0, evaluation is turned on
+  * if depth if not zero (even if it's negative!) evaluation is off
+  * SPLICE splices the form, similarly to ordinary `,@`, INJECT simply injects, same as `,`
+
+```lisp
+;; The example using macros, without special reader syntax
+
+(dig ; depth is 1 here
+  (a b
+     (dig ; depth is 2 here
+       ((inject c) ; this inject is not evaluated, because depth is nonzero
+        (inject (d ;depth becomes 1 here again
+                (inject e) ; and this inject is evaluated, because depth becomes zero
+                ))
+        (inject 2 f) ; this inject with level specification is evaluated, because it
+                     ; decreases depth by 2
+        ))))
+
+
+;; the same example using ENABLE-QUASIQUOTE-2.0 syntax is written as
+`(a b `(,c ,(d ,e) ,,f)) ; note double comma acts different than usually
+```
+
+
+The ENABLE-QUASIQUOTE-2.0 macro just installs reader that reads
+`FORM as (DIG FORM), ,FORM as (INJECT FORM) and ,@FORM as (SPLICE FORM).
+You can just as well type DIG's, INJECT's and SPLICE's directly, 
+(in particular, when writing utility functions that generate macro-generating code)
+or roll your own convenient reader syntax (pull requests are welcome).
+
+So, these two lines (with ENABLE-QUASIQUOTE-2.0) read the same
+```lisp
+`(a (,b `,,c) d)
+
+(dig (a ((inject b) (dig (inject 2 c))) d))
+```
+
+You may notice the (INJECT 2 ...) form appearing, which is described below.
+
+
+At "level 1", i.e. when only \` , and ,@ are used, and not, say \`\` ,, ,', ,,@ ,',@
+this behaves exactly as usual quasiquotation.
+
+
+The optional N argument
+--------------
+
+All quasiquote-2.0 operators accept optional "depth" argument,
+which goes before the form for human readability.
+
+Namely, (DIG N FORM) increases depth by N instead of one and
+(INJECT N FORM) decreases depth by N instead of one.
+
+```lisp
+(DIG 2 (INJECT 2 A))
+
+; gives the same result as
+
+(DIG (INJECT A))
+```
+
+
+In fact, with ENABLE-QUASIQUOTE-2.0, say, ,,,,,FORM (5 quotes) reads as (INJECT 5 FORM)
+and ,,,,,@FORM as (SPLICE 5 FORM)
+
+
+More examples
+-------------
+
+For fairly complicated example, which uses ,,,@ and OINJECT (see below),
+ see DEFINE-BINOP-DEFINER macro
+in CG-LLVM (https://github.com/mabragor/cg-llvm/src/basics.lisp),
+desire to write which was the initial impulse for this project.
+
+
+For macro, that is not a macro-writing macro, yet benefits from
+ability to inject using `,` and `,@`, consider JOINING-WITH-COMMA-SPACE macro
+(also from CG-LLVM)
+
+```lisp
+(defmacro joining-with-comma-space (&body body)
+  ;; joinl just joins strings in the list with specified string
+  `(joinl ", " (mapcar #'emit-text-repr
+		       (remove-if-not #'identity  `(,,@body)))))
+
+;; the macro can be then used uniformly over strings and lists of strings
+(defun foo (x y &rest z)
+  (joining-with-comma-space ,x ,y ,@z))
+
+(foo "a" "b" "c" "d")
+  ;; produces
+  "a, b, c, d"
+```
+
+
+ODIG and OINJECT and OSPLICE
+----------------------------
+
+Sometimes you don't want DIG's macroexpansion to look further into the structure of
+some INJECT or SPLICE or DIG in its subform,
+if the depth does not match. In these cases you need "opaque" versions of
+DIG, INJECT and SPLICE, named, respectively, ODIG, OINJECT and OSPLICE.
+
+```lisp
+;; here injection of B would occur
+(defun foo (b)
+  (dig (dig (inject (a (inject b))))))
+
+;; and here not, because macroexpansion does not look into OINJECT form
+(defun bar (b)
+  (dig (dig (oinject (a (inject b))))))
+
+(foo 1)
+
+  '(DIG (INJECT (A 1)))
+
+(bar 1)
+
+  '(DIG (OINJECT (A (INJECT B))))
+```
+
+MACRO-INJECT and MACRO-SPLICE
+-----------------------------
+
+Sometimes you just want to abstract-out some common injection patterns...
+That is, you want macros, that expand into common injection patterns.
+However, you want this only sometimes, and only in special circumstances.
+So it won't do, if INJECT and SPLICE just expanded something, whenever it
+turned out to be macro. For that, use MACRO-INJECT and MACRO-SPLICE.
+
+```lisp
+;; with quasiquote-2.0 syntax turned on
+(defmacro inject-n-times (form n)
+  (make-list n :initial-element `(inject ,form)))
+
+(let (x 0)
+  `(dig (a (macro-inject (inject-n-times (incf x) 3)))))
+;; yields
+'(a (1 2 3))
+
+;;and same with MACRO-SPLICE
+(let (x 0)
+  `(dig (a (macro-splice (inject-n-times (incf x) 3)))))
+;; yields
+'(a 1 2 3)
+```
+
+OMACRO-INJECT and OMACRO-SPLICE are, as usual, opaque variants of MACRO-INJECT and MACRO-SPLICE.
+
+Both MACRO-INJECT and MACRO-SPLICE expand their subform exactly once (using MACROEXPAND-1),
+before plugging it into list.
+If you want to expand as much as it's possible, use MACRO-INJECT-ALL and MACRO-SPLICE-ALL,
+which expand using MACROEXPAND before injecting/splicing, respectively.
+That implies, that while subform of MACRO-INJECT and MACRO-SPLICE is checked to be
+macro-form, the subform of MACRO-INJECT-ALL is not.
+
+
+Terse syntax of the ENABLE-QUASIQUOTE-2.0
+-----------------------------------------
+
+Of course, typing all those MACRO-INJECT-ALL, or OMACRO-SPLICE-ALL or whatever explicitly
+every time you want this special things is kind of clumsy. For that, default reader
+of quasiquote-2.0 provides extended syntax
+
+```lisp
+',,,,!oma@x
+
+;; reads as
+'(OMACRO-SPLICE-ALL 4 X)
+```
+
+That is, the regexp of the syntax is
+[,]+![o][m][a][@]<whatever>
+
+As usual, number of commas determine the anti-depth of the injector, exclamation mark
+turns on the syntax, if `o` is present, opaque version of injector will be used,
+if `m` is present, macro-expanding version of injector will be used and if
+`a` is present, macro-all version of injector will be used.
+
+Note: it's possible to write ,!ax, which will read as (INJECT-ALL X), but
+this will not correspond to the actual macro name.
+
+Note: it was necessary to introduce special escape-char for extended syntax,
+since usual idioms like `,args` would otherwise be completely screwed.
+
+
+TODO
+----
+
+* WITH-QUASIQUOTE-2.0 read-macro-token for local enabling of ` and , overloading
+* wrappers for convenient definition of custom overloading schemes
+* some syntax for opaque operations
+
+P.S. Name "quasiquote-2.0" comes from "patronus 2.0" spell from www.hpmor.com
+     and has nothing to do with being "the 2.0" version of quasiquote.
\ No newline at end of file
diff --git a/third_party/lisp/quasiquote_2/default.nix b/third_party/lisp/quasiquote_2/default.nix
new file mode 100644
index 000000000000..521c384787fe
--- /dev/null
+++ b/third_party/lisp/quasiquote_2/default.nix
@@ -0,0 +1,17 @@
+# Quasiquote more suitable for macros that define other macros
+{ depot, ... }:
+
+depot.nix.buildLisp.library {
+  name = "quasiquote-2.0";
+
+  deps = [
+    depot.third_party.lisp.iterate
+  ];
+
+  srcs = [
+    ./package.lisp
+    ./quasiquote-2.0.lisp
+    ./macros.lisp
+    ./readers.lisp
+  ];
+}
diff --git a/third_party/lisp/quasiquote_2/macros.lisp b/third_party/lisp/quasiquote_2/macros.lisp
new file mode 100644
index 000000000000..6ebeb47d081e
--- /dev/null
+++ b/third_party/lisp/quasiquote_2/macros.lisp
@@ -0,0 +1,15 @@
+
+(in-package #:quasiquote-2.0)
+
+(defmacro define-dig-like-macro (name)
+  `(defmacro ,name (n-or-form &optional (form nil form-p) &environment env)
+     (if (not form-p)
+	 `(,',name 1 ,n-or-form)
+	 (let ((*env* env))
+	   (transform-dig-form `(,',name ,n-or-form ,form))))))
+
+
+(define-dig-like-macro dig)
+(define-dig-like-macro odig)
+
+
diff --git a/third_party/lisp/quasiquote_2/package.lisp b/third_party/lisp/quasiquote_2/package.lisp
new file mode 100644
index 000000000000..9b140ef84c32
--- /dev/null
+++ b/third_party/lisp/quasiquote_2/package.lisp
@@ -0,0 +1,11 @@
+;;;; package.lisp
+
+(defpackage #:quasiquote-2.0
+  (:use #:cl #:iterate)
+  (:export #:%codewalk-dig-form #:transform-dig-form
+	   #:dig #:inject #:splice #:odig #:oinject #:osplice
+	   #:macro-inject #:omacro-inject #:macro-splice #:omacro-splice
+	   #:macro-inject-all #:omacro-inject-all #:macro-splice-all #:omacro-splice-all
+	   #:enable-quasiquote-2.0 #:disable-quasiquote-2.0))
+
+
diff --git a/third_party/lisp/quasiquote_2/quasiquote-2.0.asd b/third_party/lisp/quasiquote_2/quasiquote-2.0.asd
new file mode 100644
index 000000000000..3acfd32b80e6
--- /dev/null
+++ b/third_party/lisp/quasiquote_2/quasiquote-2.0.asd
@@ -0,0 +1,30 @@
+;;;; quasiquote-2.0.asd
+
+(defpackage :quasiquote-2.0-system
+  (:use :cl :asdf))
+
+(in-package quasiquote-2.0-system)
+
+(asdf:defsystem #:quasiquote-2.0
+  :serial t
+  :description "Writing macros that write macros. Effortless."
+  :author "Alexandr Popolitov <popolit@gmail.com>"
+  :license "MIT"
+  :version "0.3"
+  :depends-on (#:iterate)
+  :components ((:file "package")
+               (:file "quasiquote-2.0")
+	       (:file "macros")
+	       (:file "readers")))
+
+(defsystem :quasiquote-2.0-tests
+  :description "Tests for QUASIQUOTE-2.0"
+  :licence "MIT"
+  :depends-on (:quasiquote-2.0 :fiveam)
+  :components ((:file "tests")
+	       (:file "tests-macro")
+	       ))
+
+(defmethod perform ((op test-op) (sys (eql (find-system :quasiquote-2.0))))
+  (load-system :quasiquote-2.0)
+  (funcall (intern "RUN-TESTS" :quasiquote-2.0)))
diff --git a/third_party/lisp/quasiquote_2/quasiquote-2.0.lisp b/third_party/lisp/quasiquote_2/quasiquote-2.0.lisp
new file mode 100644
index 000000000000..10043fe0ecbc
--- /dev/null
+++ b/third_party/lisp/quasiquote_2/quasiquote-2.0.lisp
@@ -0,0 +1,340 @@
+;;;; quasiquote-2.0.lisp
+
+(in-package #:quasiquote-2.0)
+
+(defparameter *env* nil)
+
+(defmacro nonsense-error (str)
+  `(error ,(concatenate 'string
+			str
+			" appears as a bare, non DIG-enclosed form. "
+			"For now I don't know how to make sense of this.")))
+
+(defmacro define-nonsense-when-bare (name)
+  `(defmacro ,name (n-or-form &optional form)
+     (declare (ignore n-or-form form))
+     (nonsense-error ,(string name))))
+
+(define-nonsense-when-bare inject)
+(define-nonsense-when-bare oinject)
+(define-nonsense-when-bare splice)
+(define-nonsense-when-bare osplice)
+(define-nonsense-when-bare macro-inject)
+
+(defparameter *depth* 0)
+
+
+(defparameter *injectors* nil)
+
+(defparameter *void-elt* nil)
+(defparameter *void-filter-needed* nil)
+
+;; (defmacro with-injector-parsed (form)
+;;   `(let ((kwd (intern (string 
+
+(defun reset-injectors ()
+  (setf *injectors* nil))
+
+(defparameter *known-injectors* '(inject splice oinject osplice
+				  macro-inject omacro-inject
+				  macro-splice omacro-splice
+				  macro-inject-all omacro-inject-all
+				  macro-splice-all omacro-splice-all))
+
+(defun injector-form-p (form)
+  (and (consp form)
+       (find (car form) *known-injectors* :test #'eq)))
+
+(defun injector-level (form)
+  (if (equal 2 (length form))
+      1
+      (cadr form)))
+
+(defun injector-subform (form)
+  (if (equal 2 (length form))
+      (values (cdr form) '(cdr))
+      (values (cddr form) '(cddr))))
+
+(defparameter *opaque-injectors* '(odig oinject osplice omacro-inject))
+
+(defun transparent-p (form)
+  (not (find (car form) *opaque-injectors* :test #'eq)))
+
+(defun look-into-injector (form path)
+  (let ((*depth* (- *depth* (injector-level form))))
+    (multiple-value-bind (subform subpath) (injector-subform form)
+      (search-all-active-sites subform (append subpath path) nil))))
+
+(defparameter *known-diggers* '(dig odig))
+
+(defun dig-form-p (form)
+  (and (consp form)
+       (find (car form) *known-diggers* :test #'eq)))
+
+(defun look-into-dig (form path)
+  (let ((*depth* (+ *depth* (injector-level form))))
+    (multiple-value-bind (subform subpath) (injector-subform form)
+      (search-all-active-sites subform (append subpath path) nil))))
+
+(defun handle-macro-1 (form)
+  (if (atom form)
+      (error "Sorry, symbol-macros are not implemented for now")
+      (let ((fun (macro-function (car form) *env*)))
+	(if (not fun)
+	    (error "The subform of MACRO-1 injector is supposed to be macro, perhaps, something went wrong..."))
+	(macroexpand-1 form *env*))))
+
+(defun handle-macro-all (form)
+  (if (atom form)
+      (error "Sorry, symbol-macros are not implemented for now")
+      (macroexpand form *env*)))
+
+
+(defparameter *macro-handlers* `((macro-inject . ,#'handle-macro-1)
+				 (omacro-inject . ,#'handle-macro-1)
+				 (macro-splice . ,#'handle-macro-1)
+				 (omacro-splice . ,#'handle-macro-1)
+				 (macro-inject-all . ,#'handle-macro-all)
+				 (omacro-inject-all . ,#'handle-macro-all)
+				 (macro-splice-all . ,#'handle-macro-all)
+				 (omacro-splice-all . ,#'handle-macro-all)))
+
+(defun get-macro-handler (sym)
+  (or (cdr (assoc sym *macro-handlers*))
+      (error "Don't know how to handle this macro injector: ~a" sym)))
+
+	
+
+(defun macroexpand-macroinjector (place)
+  (if (not (splicing-injector (car place)))
+      (progn (setf (car place) (funcall (get-macro-handler (caar place))
+					(car (injector-subform (car place)))))
+	     nil)
+      (let ((new-forms (funcall (get-macro-handler (caar place))
+				(car (injector-subform (car place))))))
+	(cond ((not new-forms)
+	       (setf *void-filter-needed* t
+		     (car place) *void-elt*))
+	      ((atom new-forms) (error "We need to splice the macroexpansion, but got atom: ~a" new-forms))
+	      (t (setf (car place) (car new-forms))
+		 (let ((tail (cdr place)))
+		   (setf (cdr place) (cdr new-forms)
+			 (cdr (last new-forms)) tail))))
+	t)))
+	    
+
+(defun search-all-active-sites (form path toplevel-p)
+  ;; (format t "SEARCH-ALL-ACTIVE-SITES: got form ~a~%" form)
+  (if (not form)
+      nil
+      (if toplevel-p
+	  (cond ((atom (car form)) :just-quote-it!)
+		((injector-form-p (car form)) (if (equal *depth* (injector-level (car form)))
+						  :just-form-it!
+						  (if (transparent-p (car form))
+						      (look-into-injector (car form) (cons 'car path)))))
+		((dig-form-p (car form))
+		 ;; (format t "Got dig form ~a~%" form)
+		 (if (transparent-p (car form))
+		     (look-into-dig (car form) (cons 'car path))))
+		(t (search-all-active-sites (car form) (cons 'car path) nil)
+		   (search-all-active-sites (cdr form) (cons 'cdr path) nil)))
+	  (when (consp form)
+	    (cond ((dig-form-p (car form))
+		   ;; (format t "Got dig form ~a~%" form)
+		   (if (transparent-p (car form))
+		       (look-into-dig (car form) (cons 'car path))))
+		  ((injector-form-p (car form))
+		   ;; (format t "Got injector form ~a ~a ~a~%" form *depth* (injector-level (car form)))
+		   (if (equal *depth* (injector-level (car form)))
+		       (if (macro-injector-p (car form))
+			   (progn (macroexpand-macroinjector form)
+				  (return-from search-all-active-sites
+				    (search-all-active-sites form path nil)))
+			   (progn (push (cons form (cons 'car path)) *injectors*)
+				  nil))
+		       (if (transparent-p (car form))
+			   (look-into-injector (car form) (cons 'car path)))))
+		  (t (search-all-active-sites (car form) (cons 'car path) nil)))
+	    (search-all-active-sites (cdr form) (cons 'cdr path) nil)))))
+
+	  
+	      
+(defun codewalk-dig-form (form)
+  (reset-injectors)
+  (let ((it (search-all-active-sites form nil t)))
+    (values (nreverse *injectors*) it)))
+
+(defun %codewalk-dig-form (form)
+  (if (not (dig-form-p form))
+      (error "Supposed to be called on dig form")
+      (let ((*depth* (+ (injector-level form) *depth*)))
+	(codewalk-dig-form (injector-subform form)))))
+
+(defun path->setfable (path var)
+  (let ((res var))
+    ;; First element is artifact of extra CAR-ing
+    (dolist (spec (cdr (reverse path)))
+      (setf res (list spec res)))
+    res))
+
+(defun tree->cons-code (tree)
+  (if (atom tree)
+      `(quote ,tree)
+      `(cons ,(tree->cons-code (car tree))
+	     ,(tree->cons-code (cdr tree)))))
+
+(defparameter *known-splicers* '(splice osplice
+				 macro-splice omacro-splice
+				 macro-splice-all omacro-splice-all))
+
+(defun splicing-injector (form)
+  (and (consp form)
+       (find (car form) *known-splicers* :test #'eq)))
+
+(defparameter *known-macro-injectors* '(macro-inject omacro-inject
+					macro-splice omacro-splice
+					macro-inject-all omacro-inject-all
+					macro-splice-all omacro-splice-all
+					))
+
+(defun macro-injector-p (form)
+  (and (consp form)
+       (find (car form) *known-macro-injectors* :test #'eq)))
+
+(defun filter-out-voids (lst void-sym)
+  (let (caars cadrs cdars cddrs)
+    ;; search for all occurences of VOID
+    (labels ((rec (x)
+	       (if (consp x)
+		   (progn (cond ((consp (car x))
+				 (cond ((eq void-sym (caar x)) (push x caars))
+				       ((eq void-sym (cdar x)) (push x cdars))))
+				((consp (cdr x))
+				 (cond ((eq void-sym (cadr x)) (push x cadrs))
+				       ((eq void-sym (cddr x)) (push x cddrs)))))
+			  (rec (car x))
+			  (rec (cdr x))))))
+      (rec lst))
+    (if (or cdars cddrs)
+	(error "Void sym found on CDR position, which should not have happened"))
+    ;; destructively transform LST
+    (dolist (elt caars)
+      (setf (car elt) (cdar elt)))
+    (dolist (elt cadrs)
+      (setf (cdr elt) (cddr elt)))
+    ;; check that we indeed filtered-out all VOIDs
+    (labels ((rec (x)
+	       (if (not (atom x))
+		   (progn (rec (car x))
+			  (rec (cdr x)))
+		   (if (eq void-sym x)
+		       (error "Not all VOIDs were filtered")))))
+      (rec lst))
+    lst))
+
+(defun transform-dig-form (form)
+  (let ((the-form (copy-tree form)))
+    (let ((*void-filter-needed* nil)
+	  (*void-elt* (gensym "VOID")))
+      (multiple-value-bind (site-paths cmd) (%codewalk-dig-form the-form)
+	(cond ((eq cmd :just-quote-it!)
+	       `(quote ,(car (injector-subform the-form))))
+	      ((eq cmd :just-form-it!)
+	       (car (injector-subform (car (injector-subform the-form)))))
+	      (t (let ((cons-code (if (not site-paths)
+				      (tree->cons-code (car (injector-subform the-form)))
+				      (really-transform-dig-form the-form site-paths))))
+		   (if (not *void-filter-needed*)
+		       cons-code
+		       `(filter-out-voids ,cons-code ',*void-elt*)))))))))
+
+(defmacro make-list-form (o!-n form)
+  (let ((g!-n (gensym "N"))
+	(g!-i (gensym "I"))
+	(g!-res (gensym "RES")))
+    `(let ((,g!-n ,o!-n)
+	   (,g!-res nil))
+       (dotimes (,g!-i ,g!-n)
+	 (push ,form ,g!-res))
+       (nreverse ,g!-res))))
+
+(defun mk-splicing-injector-let (x)
+  `(let ((it ,(car (injector-subform x))))
+     (assert (listp it))
+     (copy-list it)))
+
+
+
+(defun mk-splicing-injector-setf (path g!-list g!-splicee)
+  (assert (eq 'car (car path)))
+  (let ((g!-rest (gensym "REST")))
+    `(let ((,g!-rest ,(path->setfable (cons 'cdr (cdr path)) g!-list)))
+       (assert (or (not ,g!-rest) (consp ,g!-rest)))
+       (if (not ,g!-splicee)
+	   (setf ,(path->setfable (cdr path) g!-list)
+		 ,g!-rest)
+	   (progn (setf ,(path->setfable (cdr path) g!-list) ,g!-splicee)
+		  (setf (cdr (last ,g!-splicee)) ,g!-rest))))))
+
+
+(defun really-transform-dig-form (the-form site-paths)
+  (let ((gensyms (make-list-form (length site-paths) (gensym "INJECTEE"))))
+    (let ((g!-list (gensym "LIST")))
+      (let ((lets nil)
+	    (splicing-setfs nil)
+	    (setfs nil))
+	(do ((site-path site-paths (cdr site-path))
+	     (gensym gensyms (cdr gensym)))
+	    ((not site-path))
+	  (destructuring-bind (site . path) (car site-path)
+	    (push `(,(car gensym) ,(if (not (splicing-injector (car site)))
+				       (car (injector-subform (car site)))
+				       (mk-splicing-injector-let (car site))))
+		  lets)
+	    (if (not (splicing-injector (car site)))
+		(push `(setf ,(path->setfable path g!-list) ,(car gensym)) setfs)
+		(push (mk-splicing-injector-setf path g!-list (car gensym)) splicing-setfs))
+	    (setf (car site) nil)))
+	`(let ,(nreverse lets)
+	   (let ((,g!-list ,(tree->cons-code (car (injector-subform the-form)))))
+	     ,@(nreverse setfs)
+	     ;; we apply splicing setf in reverse order for them not to bork the paths of each other
+	     ,@splicing-setfs
+	     ,g!-list))))))
+
+
+;; There are few types of recursive injection that may happen:
+;;   * compile-time injection:
+;;     (dig (inject (dig (inject a)))) -- this type will be handled automatically by subsequent macroexpansions
+;;   * run-time injection:
+;;     (dig (dig (inject 2 a)))
+;;     and A is '(dig (inject 3 'foo)) -- this one we guard against ? (probably, first we just ignore it
+;;     -- do not warn about it, and then it wont really happen.
+;;   * macroexpanded compile-time injection:
+;;     (dig (inject (my-macro a b c))),
+;;     where MY-MACRO expands into, say (splice (list 'a 'b 'c))
+;;     This is *not* handled automatically, and therefore we must do it by hand.
+
+      
+;; OK, now how to implement splicing ?
+;;   (dig (a (splice (list b c)) d))
+;; should transform into code that yields
+;;   (a b c d)
+;; what this code is?
+;;   (let ((#:a (copy-list (list b c))))
+;;     (let ((#:res (cons 'a nil 'd)))
+;;       ;; all non-splicing injects go here, as they do not spoil the path-structure
+;;       (setf (cdr #:res) #:a)
+;;       (setf (cdr (last #:a)) (cdr (cdr #:res)))
+;;       #:res)))
+
+
+;; How this macroexpansion should work in general?
+;;   * We go over the cons-tree, keeping track of the depth level, which is
+;;   controlled by DIG's
+;;   * Once we find the INJECT with matching level, we remember the place, where
+;;     this happens
+;;   * We have two special cases:
+;;     * cons-tree is an atom
+;;     * cons-tree is just a single INJECT
diff --git a/third_party/lisp/quasiquote_2/readers.lisp b/third_party/lisp/quasiquote_2/readers.lisp
new file mode 100644
index 000000000000..7c4c5a30c98e
--- /dev/null
+++ b/third_party/lisp/quasiquote_2/readers.lisp
@@ -0,0 +1,77 @@
+
+
+(in-package #:quasiquote-2.0)
+
+(defun read-n-chars (stream char)
+  (let (new-char
+	(n 0))
+    (loop
+       (setf new-char (read-char stream nil :eof t))
+       (if (not (char= new-char char))
+	   (progn (unread-char new-char stream)
+		  (return n))
+	   (incf n)))))
+
+(defmacro define-dig-reader (name symbol)
+  `(defun ,name (stream char)
+     (let ((depth (1+ (read-n-chars stream char))))
+       (if (equal 1 depth)
+	   (list ',symbol (read stream t nil t))
+	   (list ',symbol
+		 depth
+		 (read stream t nil t))))))
+
+(define-dig-reader dig-reader dig)
+(define-dig-reader odig-reader odig)
+
+(defun expect-char (char stream)
+  (let ((new-char (read-char stream t nil t)))
+    (if (char= char new-char)
+	t
+	(unread-char new-char stream))))
+
+(defun guess-injector-name (opaque-p macro-p all-p splicing-p)
+  (intern (concatenate 'string
+		       (if opaque-p "O" "")
+		       (if macro-p "MACRO-" "")
+		       (if splicing-p "SPLICE" "INJECT")
+		       (if all-p "-ALL" ""))
+	  "QUASIQUOTE-2.0"))
+
+(defun inject-reader (stream char)
+  (let ((anti-depth (1+ (read-n-chars stream char)))
+	(extended-syntax (expect-char #\! stream)))
+    (let ((injector-name (if (not extended-syntax)
+			     (guess-injector-name nil nil nil (expect-char #\@ stream))
+			     (guess-injector-name (expect-char #\o stream)
+						  (expect-char #\m stream)
+						  (expect-char #\a stream)
+						  (expect-char #\@ stream)))))
+      `(,injector-name ,@(if (not (equal 1 anti-depth)) `(,anti-depth))
+		       ,(read stream t nil t)))))
+
+
+
+(defvar *previous-readtables* nil)
+
+(defun %enable-quasiquote-2.0 ()
+  (push *readtable*
+        *previous-readtables*)
+  (setq *readtable* (copy-readtable))
+  (set-macro-character #\` #'dig-reader)
+  (set-macro-character #\, #'inject-reader)
+  (values))
+
+(defun %disable-quasiquote-2.0 ()
+  (if *previous-readtables*
+      (setf *readtable* (pop *previous-readtables*))
+      (setf *readtable* (copy-readtable nil)))
+  (values))
+
+(defmacro enable-quasiquote-2.0 ()
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+     (%enable-quasiquote-2.0)))
+(defmacro disable-quasiquote-2.0 ()
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+     (%disable-quasiquote-2.0)))
+  
diff --git a/third_party/lisp/quasiquote_2/tests-macro.lisp b/third_party/lisp/quasiquote_2/tests-macro.lisp
new file mode 100644
index 000000000000..df6c43e21d77
--- /dev/null
+++ b/third_party/lisp/quasiquote_2/tests-macro.lisp
@@ -0,0 +1,21 @@
+
+(in-package #:quasiquote-2.0-tests)
+
+(in-suite quasiquote-2.0)
+
+(enable-quasiquote-2.0)
+
+(defmacro define-sample-macro (name args &body body)
+  `(defmacro ,name ,args
+     `(sample-thing-to-macroexpand-to
+       ,,@body)))
+
+(define-sample-macro sample-macro-1 (x y)
+  ,x ,y)
+
+(define-sample-macro sample-macro-2 (&body body)
+  ,@body)
+
+(test macro-defined-macroexpansions
+  (is (equal '(sample-thing-to-macroexpand-to a b) (macroexpand-1 '(sample-macro-1 a b))))
+  (is (equal '(sample-thing-to-macroexpand-to a b c) (macroexpand-1 '(sample-macro-2 a b c)))))
\ No newline at end of file
diff --git a/third_party/lisp/quasiquote_2/tests.lisp b/third_party/lisp/quasiquote_2/tests.lisp
new file mode 100644
index 000000000000..6c8ab08cc1af
--- /dev/null
+++ b/third_party/lisp/quasiquote_2/tests.lisp
@@ -0,0 +1,143 @@
+(in-package :cl-user)
+
+(defpackage :quasiquote-2.0-tests
+  (:use :cl :quasiquote-2.0 :fiveam)
+  (:export #:run-tests))
+
+(in-package :quasiquote-2.0-tests)
+
+(def-suite quasiquote-2.0)
+(in-suite quasiquote-2.0)
+
+(defun run-tests ()
+  (let ((results (run 'quasiquote-2.0)))
+    (fiveam:explain! results)
+    (unless (fiveam:results-status results)
+      (error "Tests failed."))))
+
+(test basic
+  (is (equal '(nil :just-quote-it!) (multiple-value-list (%codewalk-dig-form '(dig nil)))))
+  (is (equal '(nil :just-form-it!) (multiple-value-list (%codewalk-dig-form '(dig (inject a))))))
+  (is (equal '(nil :just-form-it!) (multiple-value-list (%codewalk-dig-form '(dig 2 (inject 2 a))))))
+  (is (equal '(((((inject b) c (inject d)) car cdr car) (((inject d)) car cdr cdr cdr car)) nil)
+	     (multiple-value-list (%codewalk-dig-form '(dig (a (inject b) c (inject d)))))))
+  (is (equal '(nil nil)
+	     (multiple-value-list (%codewalk-dig-form '(dig (dig (a (inject b) c (inject d))))))))
+  (is (equal '(((((inject 2 d)) car cdr cdr cdr car cdr car)) nil)
+	     (multiple-value-list (%codewalk-dig-form '(dig (dig (a (inject b) c (inject 2 d)))))))))
+  
+(test transform
+  (is (equal '(quote a) (transform-dig-form '(dig a))))
+  (is (equal '(quote a) (transform-dig-form '(dig 2 a))))
+  (is (equal 'a (transform-dig-form '(dig (inject a)))))
+  (is (equal 'a (transform-dig-form '(dig 2 (inject 2 a))))))
+
+(defun foo (b d)
+  (dig (a (inject b) c (inject d))))
+
+(defun foo1-transparent (x)
+  (declare (ignorable x))
+  (dig (dig (a (inject (b (inject x) c))))))
+
+(defun foo1-opaque (x)
+  (declare (ignorable x))
+  (dig (dig (a (oinject (b (inject x) c))))))
+
+(defun foo-recursive (x y)
+  (dig (a (inject (list x (dig (c (inject y))))))))
+  
+
+(test foos
+  (is (equal '(a 1 c 2) (foo 1 2)))
+  (is (equal '(a 100 c 200) (foo 100 200))))
+
+(test opaque-vs-transparent
+  (is (equal '(quote a) (transform-dig-form '(odig a))))
+  (is (equal '(quote a) (transform-dig-form '(odig 2 a))))
+  (is (equal 'a (transform-dig-form '(odig (inject a)))))
+  (is (equal 'a (transform-dig-form '(odig 2 (inject 2 a)))))
+  (is (equal '(odig (inject 2 a)) (eval (transform-dig-form '(dig (odig (inject 2 a)))))))
+  (is (equal '(dig (a (inject (b 3 c)))) (foo1-transparent 3)))
+  (is (equal '(dig (a (oinject (b (inject x) c)))) (foo1-opaque 3))))
+
+(test recursive-compile-time
+  (is (equal '(a (1 (c 2))) (foo-recursive 1 2))))
+	     
+
+(test splicing
+  (is (equal '(a b c d) (eval (transform-dig-form '(dig (a (splice '(b c)) d))))))
+  (is (equal '(b c d) (eval (transform-dig-form '(dig ((splice '(b c)) d))))))
+  (is (equal '(a b c) (eval (transform-dig-form '(dig (a (splice '(b c))))))))
+  (is (equal '(a b) (eval (transform-dig-form '(dig (a (splice nil) b))))))
+  (is (equal '(b) (eval (transform-dig-form '(dig ((splice nil) b))))))
+  (is (equal '(a) (eval (transform-dig-form '(dig (a (splice nil)))))))
+  (is (equal '() (eval (transform-dig-form '(dig ((splice nil)))))))
+  (is (equal '(a b) (eval (transform-dig-form '(dig ((splice '(a b)))))))))
+
+
+(test are-they-macro
+  (is (not (equal '(dig (a b)) (macroexpand-1 '(dig (a b))))))
+  (is (not (equal '(odig (a b)) (macroexpand-1 '(odig (a b)))))))
+
+
+(defmacro triple-var (x)
+  `((inject ,x) (inject ,x) (inject ,x)))
+
+(test correct-order-of-effects
+  (is (equal '(a 1 2 3) (let ((x 0))
+			  (dig (a (inject (incf x)) (inject (incf x)) (inject (incf x)))))))
+  (is (equal '(a (((1))) 2)
+	     (let ((x 0))
+	       (dig (a ((((inject (incf x))))) (inject (incf x))))))))
+
+(test macro-injects
+  (is (equal '(a (3 3 3)) (let ((x 3))
+			    (dig (a (macro-inject (triple-var x)))))))
+  (is (equal '(a (1 2 3)) (let ((x 0))
+			    (dig (a (macro-inject (triple-var (incf x))))))))
+  (macrolet ((frob (form n)
+	       (mapcar (lambda (x)
+			 `(inject ,x))
+		       (make-list n :initial-element form)))
+	     (frob1 (form)
+	       `(frob ,form 4)))
+    (is (equal '(a (1 2 3 4 5))
+	       (let ((x 0))
+		 (dig (a (macro-inject (frob (incf x) 5)))))))
+    (is (equal '(a 1 2 3 4 5)
+	       (let ((x 0))
+		 (dig (a (macro-splice (frob (incf x) 5)))))))
+    (is (equal '(a)
+	       (let ((x 0))
+		 (declare (ignorable x))
+		 (dig (a (macro-splice (frob (incf x) 0)))))))
+    (is (equal '(a frob (incf x) 4)
+	       (let ((x 0))
+		 (declare (ignorable x))
+		 (dig (a (macro-splice (frob1 (incf x))))))))
+    (is (equal '(a 1 2 3 4)
+	       (let ((x 0))
+		 (dig (a (macro-splice-all (frob1 (incf x))))))))))
+    
+	       
+(quasiquote-2.0:enable-quasiquote-2.0)
+
+(test reader
+  (is (equal '(inject x) ',x))
+  (is (equal '(inject 3 x) ',,,x))
+  (is (equal '(splice x) ',@x))
+  (is (equal '(splice 3 x) ',,,@x))
+  (is (equal '(omacro-splice-all 4 x) ',,,,!oma@x))
+  (is (equal '(inject 4 oma@x) ',,,,oma@x)))
+
+(test macro-splices
+  (macrolet ((splicer (x)
+	       ``(splice ,x)))
+    (is (equal '(a 1 2 3) (let ((x '(1 2 3)))
+			    `(a ,!m(splicer x)))))))
+
+(test repeated-splices
+  (is (equal '(a) `(a ,@nil ,@nil ,@nil ,@nil)))
+  (is (equal '(a b c d e f g) `(a ,@(list 'b 'c) ,@(list 'd 'e) ,@nil ,@(list 'f 'g)))))
+
+  
\ No newline at end of file
diff --git a/third_party/lisp/rfc2388.nix b/third_party/lisp/rfc2388.nix
new file mode 100644
index 000000000000..b82a490c9d71
--- /dev/null
+++ b/third_party/lisp/rfc2388.nix
@@ -0,0 +1,12 @@
+# Implementation of RFC2388 (multipart/form-data)
+{ depot, pkgs, ... }:
+
+let src = with pkgs; srcOnly lispPackages.rfc2388;
+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..fc7d4e306713
--- /dev/null
+++ b/third_party/lisp/routes.nix
@@ -0,0 +1,39 @@
+{ 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..9c4da4a02b25
--- /dev/null
+++ b/third_party/lisp/s-sysdeps.nix
@@ -0,0 +1,18 @@
+# A Common Lisp abstraction layer over platform dependent functionality.
+{ depot, pkgs, ... }:
+
+let src = with pkgs; srcOnly lispPackages.s-sysdeps;
+in depot.nix.buildLisp.library {
+  name = "s-sysdeps";
+
+  srcs = [
+    "${src}/src/package.lisp"
+    "${src}/src/sysdeps.lisp"
+  ];
+
+  deps = with depot.third_party.lisp; [
+    bordeaux-threads
+    usocket
+    usocket-server
+  ];
+}
diff --git a/third_party/lisp/s-xml/0001-fix-definition-order-in-xml.lisp.patch b/third_party/lisp/s-xml/0001-fix-definition-order-in-xml.lisp.patch
new file mode 100644
index 000000000000..9e5838c3c545
--- /dev/null
+++ b/third_party/lisp/s-xml/0001-fix-definition-order-in-xml.lisp.patch
@@ -0,0 +1,26 @@
+From 789dc38399f4039b114de28384c149721d66b030 Mon Sep 17 00:00:00 2001
+From: Vincent Ambo <mail@tazj.in>
+Date: Thu, 16 Dec 2021 00:48:04 +0300
+Subject: [PATCH] fix definition order in xml.lisp
+
+---
+ src/xml.lisp | 3 +++
+ 1 file changed, 3 insertions(+)
+
+diff --git a/src/xml.lisp b/src/xml.lisp
+index 39c9b63..3232491 100644
+--- a/src/xml.lisp
++++ b/src/xml.lisp
+@@ -19,6 +19,9 @@
+ 
+ ;;; error reporting
+ 
++(defvar *ignore-namespaces* nil
++  "When t, namespaces are ignored like in the old version of S-XML")
++
+ (define-condition xml-parser-error (error)
+   ((message :initarg :message :reader xml-parser-error-message)
+    (args :initarg :args :reader xml-parser-error-args)
+-- 
+2.34.0
+
diff --git a/third_party/lisp/s-xml/default.nix b/third_party/lisp/s-xml/default.nix
new file mode 100644
index 000000000000..486e1c1ac8d3
--- /dev/null
+++ b/third_party/lisp/s-xml/default.nix
@@ -0,0 +1,25 @@
+# XML serialiser for Common Lisp.
+{ depot, pkgs, ... }:
+
+let
+  src = pkgs.applyPatches {
+    name = "s-xml-source";
+    src = pkgs.lispPackages.s-xml.src;
+
+    patches = [
+      ./0001-fix-definition-order-in-xml.lisp.patch
+    ];
+  };
+in
+depot.nix.buildLisp.library {
+  name = "s-xml";
+
+  srcs = map (f: src + ("/src/" + f)) [
+    "package.lisp"
+    "xml.lisp"
+    "dom.lisp"
+    "lxml-dom.lisp"
+    "sxml-dom.lisp"
+    "xml-struct-dom.lisp"
+  ];
+}
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..3e479c4ac279
--- /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..34bae82ebb64
--- /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..1bdbba79896f
--- /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..a2cf497ff9bf
--- /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..565ab301c7e8
--- /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..a9754b756900
--- /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..dfbc2078c829
--- /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..41d32e4c49fd
--- /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..1dd559ebe3a2
--- /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..71b943aa431a
--- /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..4e8f723c3182
--- /dev/null
+++ b/third_party/lisp/split-sequence.nix
@@ -0,0 +1,15 @@
+# split-sequence is a library for, well, splitting sequences apparently.
+{ depot, pkgs, ... }:
+
+let src = with pkgs; srcOnly lispPackages.split-sequence;
+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.nix b/third_party/lisp/trivial-backtrace.nix
new file mode 100644
index 000000000000..27949e8be1e4
--- /dev/null
+++ b/third_party/lisp/trivial-backtrace.nix
@@ -0,0 +1,15 @@
+# Imported from http://common-lisp.net/project/trivial-backtrace/trivial-backtrace.git
+{ depot, pkgs, ... }:
+
+let src = with pkgs; srcOnly lispPackages.trivial-backtrace;
+in depot.nix.buildLisp.library {
+  name = "trivial-backtrace";
+
+  srcs = map (f: src + ("/dev/" + f)) [
+    "packages.lisp"
+    "utilities.lisp"
+    "backtrace.lisp"
+    "map-backtrace.lisp"
+    "fallback.lisp"
+  ];
+}
diff --git a/third_party/lisp/trivial-features.nix b/third_party/lisp/trivial-features.nix
new file mode 100644
index 000000000000..02abac54a853
--- /dev/null
+++ b/third_party/lisp/trivial-features.nix
@@ -0,0 +1,13 @@
+{ depot, pkgs, ... }:
+
+let src = with pkgs; srcOnly lispPackages.trivial-features;
+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..74224df60d91
--- /dev/null
+++ b/third_party/lisp/trivial-garbage.nix
@@ -0,0 +1,9 @@
+# trivial-garbage provides a portable API to finalizers, weak
+# hash-tables and weak pointers
+{ depot, pkgs, ... }:
+
+let src = with pkgs; srcOnly lispPackages.trivial-garbage;
+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..62a30f1e94f3
--- /dev/null
+++ b/third_party/lisp/trivial-gray-streams.nix
@@ -0,0 +1,13 @@
+# Portability library for CL gray streams.
+{ depot, pkgs, ... }:
+
+let src = with pkgs; srcOnly lispPackages.trivial-gray-streams;
+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..70a6e19d48a9
--- /dev/null
+++ b/third_party/lisp/trivial-indent.nix
@@ -0,0 +1,10 @@
+{ depot, pkgs, ... }:
+
+let src = with pkgs; srcOnly lispPackages.trivial-indent;
+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..c85fe2accbb9
--- /dev/null
+++ b/third_party/lisp/trivial-ldap.nix
@@ -0,0 +1,28 @@
+{ 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..b097a3d0ee67
--- /dev/null
+++ b/third_party/lisp/trivial-mimes.nix
@@ -0,0 +1,26 @@
+{ depot, pkgs, ... }:
+
+let
+  src = with pkgs; srcOnly lispPackages.trivial-mimes;
+
+  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..f98c029d3688
--- /dev/null
+++ b/third_party/lisp/uax-15.nix
@@ -0,0 +1,43 @@
+{ depot, pkgs, ... }:
+
+let
+  inherit (pkgs) runCommand;
+  inherit (depot.nix.buildLisp) bundled;
+  src = with pkgs; srcOnly lispPackages.uax-15;
+in
+depot.nix.buildLisp.library {
+  name = "uax-15";
+
+  deps = with depot.third_party.lisp; [
+    split-sequence
+    cl-ppcre
+    (bundled "asdf")
+  ];
+
+  srcs = [
+    "${src}/src/package.lisp"
+    "${src}/src/utilities.lisp"
+    "${src}/src/trivial-utf-16.lisp"
+
+    # uax-15 has runtime data files that need to have their references
+    # replaced with store paths.
+    #
+    # additionally there are some wonky variable usages of variables
+    # that are never defined, for which we patch in defvar statements.
+    (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 '10i(defvar *canonical-decomp-map*)' \
+        -e '10i(defvar *compatible-decomp-map*)' \
+        -e '10i(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..248296113263
--- /dev/null
+++ b/third_party/lisp/unix-opts.nix
@@ -0,0 +1,12 @@
+# unix-opts is a portable command line argument parser
+{ depot, pkgs, ... }:
+
+
+let src = with pkgs; srcOnly lispPackages.unix-opts;
+in depot.nix.buildLisp.library {
+  name = "unix-opts";
+
+  srcs = [
+    "${src}/unix-opts.lisp"
+  ];
+}
diff --git a/third_party/lisp/usocket-server.nix b/third_party/lisp/usocket-server.nix
new file mode 100644
index 000000000000..5d6d04535f0c
--- /dev/null
+++ b/third_party/lisp/usocket-server.nix
@@ -0,0 +1,19 @@
+# Universal socket library for Common Lisp (server side)
+{ depot, pkgs, ... }:
+
+let
+  inherit (depot.nix) buildLisp;
+  src = with pkgs; srcOnly lispPackages.usocket-server;
+in
+buildLisp.library {
+  name = "usocket-server";
+
+  deps = with depot.third_party.lisp; [
+    usocket
+    bordeaux-threads
+  ];
+
+  srcs = [
+    "${src}/server.lisp"
+  ];
+}
diff --git a/third_party/lisp/usocket.nix b/third_party/lisp/usocket.nix
new file mode 100644
index 000000000000..589a3a0cfc92
--- /dev/null
+++ b/third_party/lisp/usocket.nix
@@ -0,0 +1,46 @@
+# Usocket is a portable socket library
+{ depot, pkgs, ... }:
+
+let
+  inherit (depot.nix) buildLisp;
+  src = with pkgs; srcOnly lispPackages.usocket;
+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"; }
+  ]);
+}