chore: remove sclf from the tree r/4275

SCLF is quite a big utility library (almost 3€ LOC) with limited
portability (CMUCL, SBCL and CLISP to an extent). Continuing to maintain
it is an unnecessary burden, as depot only uses a fraction of it which
is now inlined into the respective users (mime4cl and mblog).

In the future trimming down ex-sclf.lisp may make sense either by
refactoring the code that uses it or by moving interesting utilities
into e.g. klatre.

Change-Id: I2e73825b6bfa372e97847f25c30731a5aad4a1b5
Reviewed-on: https://cl.tvl.fyi/c/depot/+/5922
Tested-by: BuildkiteCI
Autosubmit: sterni <sternenseemann@systemli.org>
Reviewed-by: sterni <sternenseemann@systemli.org>

22 files changed, 472 insertions, 3645 deletions

diff --git a/third_party/lisp/mime4cl/default.nix b/third_party/lisp/mime4cl/default.nix
index 9d3d6253f4..349ef397f7 100644
--- a/third_party/lisp/mime4cl/default.nix
+++ b/third_party/lisp/mime4cl/default.nix
@@ -7,12 +7,12 @@ depot.nix.buildLisp.library {
 
   deps = [
     depot.third_party.lisp.babel
-    depot.third_party.lisp.sclf
     depot.third_party.lisp.npg
     depot.third_party.lisp.trivial-gray-streams
   ];
 
   srcs = [
+    ./ex-sclf.lisp
     ./package.lisp
     ./endec.lisp
     ./streams.lisp
@@ -34,6 +34,7 @@ depot.nix.buildLisp.library {
         ;; override auto discovery which doesn't work in store
         (defvar *sample1-file* (pathname "${./test/sample1.msg}"))
       '')
+      ./test/temp-file.lisp
       ./test/endec.lisp
       ./test/address.lisp
       ./test/mime.lisp
diff --git a/third_party/lisp/mime4cl/ex-sclf.lisp b/third_party/lisp/mime4cl/ex-sclf.lisp
new file mode 100644
index 0000000000..8a288cced8
--- /dev/null
+++ b/third_party/lisp/mime4cl/ex-sclf.lisp
@@ -0,0 +1,393 @@
+;;; ex-sclf.lisp --- subset of sclf used by mime4cl
+
+;;;  Copyright (C) 2005-2010 by Walter C. Pelissero
+;;;  Copyright (C) 2022 The TVL Authors
+
+;;;  Author: sternenseemann <sternenseemann@systemli.org>
+;;;  Project: mime4cl
+;;;
+;;;  mime4cl uses sclf for miscellaneous utility functions. sclf's portability
+;;;  is quite limited. Since mime4cl is the only thing in TVL's depot depending
+;;;  on sclf, it made more sense to strip down sclf to the extent mime4cl needed
+;;;  in order to lessen the burden of porting it to other CL implementations
+;;;  later.
+;;;
+;;;  Eventually it probably makes sense to drop the utilities we don't like and
+;;;  merge the ones we do like into depot's own utility package, klatre.
+
+#+cmu (ext:file-comment "$Module: ex-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
+
+(defpackage :mime4cl-ex-sclf
+  (:use :common-lisp)
+  (:export
+   #:be
+   #:be*
+
+   #:aif
+   #:awhen
+   #:aand
+   #:it
+
+   #:gcase
+
+   #:with-gensyms
+
+   #:split-at
+   #:split-string-at-char
+   #:+whitespace+
+   #:whitespace-p
+   #:string-concat
+   #:s+
+   #:string-starts-with
+   #:string-trim-whitespace
+   #:string-left-trim-whitespace
+   #:string-right-trim-whitespace
+
+   #:queue
+   #:make-queue
+   #:queue-append
+   #:queue-pop
+   #:queue-empty-p
+
+   #:save-file-excursion
+   #:read-file
+
+   #:unix-file-stat
+   #:unix-stat
+   #:file-size
+
+   #:promise
+   #:make-promise
+   #:lazy
+   #:force
+   #:forced-p
+   #:deflazy
+
+   #:f++
+
+   #:week-day->string
+   #:month->string))
+
+(in-package :mime4cl-ex-sclf)
+
+;; MACRO UTILS
+
+(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))
+
+;; CONTROL FLOW
+
+(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 aif (test then &optional else)
+  `(be it ,test
+       (if it
+           ,then
+           ,else)))
+
+(defmacro awhen (test &body then)
+  `(be it ,test
+       (when it
+         ,@then)))
+
+(defmacro aand (&rest args)
+  (cond ((null args) t)
+        ((null (cdr args)) (car args))
+        (t `(aif ,(car args) (aand ,@(cdr args))))))
+
+(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)))))
+
+;; SEQUENCES
+
+(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 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))))
+
+;; STRINGS
+
+(defvar +whitespace+ '(#\return #\newline #\tab #\space #\page))
+
+(defun whitespace-p (char)
+  (member char +whitespace+))
+
+(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 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 s+ (&rest strings)
+  "Return a string which is made of the concatenation of STRINGS."
+  (apply #'concatenate 'string strings))
+
+(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))
+
+(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))))
+
+;; QUEUE
+
+(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)))
+
+;; STREAMS
+
+(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 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)))
+
+;; FILES
+
+(defun native-namestring (pathname)
+  #+sbcl (sb-ext:native-namestring pathname)
+  #-sbcl (let (#+cmu (lisp::*ignore-wildcards* t))
+           (namestring pathname)))
+
+(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
+       ;; TODO(sterni): ECL, CCL
+       (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))))
+
+;; 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)))
+
+;; LAZY
+
+(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))))
+
+;; FIXNUMS
+
+(defmacro f++ (x &optional (delta 1))
+  "Same as INCF but hopefully optimised for fixnums."
+  `(setf ,x (+ (the fixnum ,x) (the fixnum ,delta))))
+
+;; TIME
+
+(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))
+
+(defvar +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)))
diff --git a/third_party/lisp/mime4cl/mime.lisp b/third_party/lisp/mime4cl/mime.lisp
index 5639aab236..eec7f87dfa 100644
--- a/third_party/lisp/mime4cl/mime.lisp
+++ b/third_party/lisp/mime4cl/mime.lisp
@@ -702,7 +702,7 @@ body."
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(defconst +known-encodings+ '(:7BIT :8BIT :BINARY :QUOTED-PRINTABLE :BASE64)
+(defvar +known-encodings+ '(:7BIT :8BIT :BINARY :QUOTED-PRINTABLE :BASE64)
   "List of known content encodings.")
 
 (defun keywordify-encoding (string)
diff --git a/third_party/lisp/mime4cl/package.lisp b/third_party/lisp/mime4cl/package.lisp
index 5586bdc390..31cd85d54e 100644
--- a/third_party/lisp/mime4cl/package.lisp
+++ b/third_party/lisp/mime4cl/package.lisp
@@ -23,13 +23,7 @@
 
 (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)
+  (:use :common-lisp :npg :mime4cl-ex-sclf :trivial-gray-streams)
   (:import-from :babel :octets-to-string)
   (:import-from :babel-encodings :get-character-encoding)
   (:export #:*lazy-mime-decode*
diff --git a/third_party/lisp/mime4cl/test/endec.lisp b/third_party/lisp/mime4cl/test/endec.lisp
index 5e8d43a7d4..4ff89d5eac 100644
--- a/third_party/lisp/mime4cl/test/endec.lisp
+++ b/third_party/lisp/mime4cl/test/endec.lisp
@@ -139,9 +139,9 @@ line")
   (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*)
+    (let ((*tmp-file-defaults* (make-pathname :defaults #.(or *load-pathname* *compile-file-pathname*)
                                                    :type "encoded-data")))
-      (sclf:with-temp-file (tmp nil :direction :io)
+      (with-temp-file (tmp nil :direction :io)
         (let* ((meg (* 1024 1024))
                (buffer (make-sequence '(vector (unsigned-byte 8)) meg))
                (encoder-class (ecase decoder-class
diff --git a/third_party/lisp/mime4cl/test/package.lisp b/third_party/lisp/mime4cl/test/package.lisp
index 6da1fc8fa2..965680448f 100644
--- a/third_party/lisp/mime4cl/test/package.lisp
+++ b/third_party/lisp/mime4cl/test/package.lisp
@@ -23,5 +23,5 @@
 
 (defpackage :mime4cl-tests
   (:use :common-lisp
-        :rtest :mime4cl)
+        :rtest :mime4cl :mime4cl-ex-sclf)
   (:export))
diff --git a/third_party/lisp/mime4cl/test/temp-file.lisp b/third_party/lisp/mime4cl/test/temp-file.lisp
new file mode 100644
index 0000000000..3e6765806c
--- /dev/null
+++ b/third_party/lisp/mime4cl/test/temp-file.lisp
@@ -0,0 +1,72 @@
+;;; temp-file.lisp --- temporary file creation
+
+;;;  Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010 by Walter C. Pelissero
+;;;  Copyright (C) 2022 The TVL Authors
+
+;;;  Author: Walter C. Pelissero <walter@pelissero.de>
+;;;  Project: mime4cl
+;;;
+;;;  Code taken from SCLF
+
+#+cmu (ext:file-comment "$Module: temp-file.lisp $")
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public License
+;;; as published by the Free Software Foundation; either version 2.1
+;;; of the License, or (at your option) any later version.
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free
+;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+;;; 02111-1307 USA
+
+(in-package :mime4cl-tests)
+
+(defvar *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))))))
diff --git a/third_party/lisp/sclf/.skip-subtree b/third_party/lisp/sclf/.skip-subtree
deleted file mode 100644
index 5051f60d6b..0000000000
--- a/third_party/lisp/sclf/.skip-subtree
+++ /dev/null
@@ -1 +0,0 @@
-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
deleted file mode 100644
index f16dd105d7..0000000000
--- a/third_party/lisp/sclf/OWNERS
+++ /dev/null
@@ -1,3 +0,0 @@
-inherited: true
-owners:
-  - sterni
diff --git a/third_party/lisp/sclf/README b/third_party/lisp/sclf/README
deleted file mode 100644
index 2a1c2c3c5c..0000000000
--- a/third_party/lisp/sclf/README
+++ /dev/null
@@ -1,6 +0,0 @@
-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
deleted file mode 100644
index fb07f8f764..0000000000
--- a/third_party/lisp/sclf/default.nix
+++ /dev/null
@@ -1,28 +0,0 @@
-# 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
deleted file mode 100644
index 3e479c4ac2..0000000000
--- a/third_party/lisp/sclf/directory.lisp
+++ /dev/null
@@ -1,404 +0,0 @@
-;;;  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
deleted file mode 100644
index 34bae82ebb..0000000000
--- a/third_party/lisp/sclf/lazy.lisp
+++ /dev/null
@@ -1,134 +0,0 @@
-;;;  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
deleted file mode 100644
index a0732c0294..0000000000
--- a/third_party/lisp/sclf/mp/README
+++ /dev/null
@@ -1,6 +0,0 @@
-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
deleted file mode 100644
index 1bdbba7989..0000000000
--- a/third_party/lisp/sclf/mp/cmu.lisp
+++ /dev/null
@@ -1,115 +0,0 @@
-;;;
-;;; 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
deleted file mode 100644
index a2cf497ff9..0000000000
--- a/third_party/lisp/sclf/mp/sbcl.lisp
+++ /dev/null
@@ -1,235 +0,0 @@
-;;;
-;;; 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
deleted file mode 100644
index 565ab301c7..0000000000
--- a/third_party/lisp/sclf/package.lisp
+++ /dev/null
@@ -1,258 +0,0 @@
-;;;  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
deleted file mode 100644
index a9754b7569..0000000000
--- a/third_party/lisp/sclf/sclf.asd
+++ /dev/null
@@ -1,58 +0,0 @@
-;;;  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
deleted file mode 100644
index dfbc2078c8..0000000000
--- a/third_party/lisp/sclf/sclf.lisp
+++ /dev/null
@@ -1,1717 +0,0 @@
-;;;  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
deleted file mode 100644
index 41d32e4c49..0000000000
--- a/third_party/lisp/sclf/serial.lisp
+++ /dev/null
@@ -1,62 +0,0 @@
- ;;; 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
deleted file mode 100644
index 1dd559ebe3..0000000000
--- a/third_party/lisp/sclf/sysproc.lisp
+++ /dev/null
@@ -1,295 +0,0 @@
-;;;  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
deleted file mode 100644
index 71b943aa43..0000000000
--- a/third_party/lisp/sclf/time.lisp
+++ /dev/null
@@ -1,311 +0,0 @@
-;;;  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)))