Squashed 'third_party/lisp/alexandria/' content from commit fc2a2f5c

git-subtree-dir: third_party/lisp/alexandria
git-subtree-split: fc2a2f5c34147bb4e3e4a350b04220de0263710f

29 files changed, 6252 insertions, 0 deletions

diff --git a/.boring b/.boring
new file mode 100644
index 000000000000..dfa9e6dd7bb4
--- /dev/null
+++ b/.boring
@@ -0,0 +1,13 @@
+# Boring file regexps:
+~$
+^_darcs
+^\{arch\}
+^.arch-ids
+\#
+\.dfsl$
+\.ppcf$
+\.fasl$
+\.x86f$
+\.fas$
+\.lib$
+^public_html
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 000000000000..e832e9471833
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,4 @@
+*.fasl
+*~
+\#*
+*.patch
diff --git a/AUTHORS b/AUTHORS
new file mode 100644
index 000000000000..b550ea503248
--- /dev/null
+++ b/AUTHORS
@@ -0,0 +1,9 @@
+
+ACTA EST FABULA PLAUDITE
+
+Nikodemus Siivola 
+Attila Lendvai
+Marco Baringer
+Robert Strandh
+Luis Oliveira
+Tobias C. Rittweiler
\ No newline at end of file
diff --git a/LICENCE b/LICENCE
new file mode 100644
index 000000000000..b5140fbb2491
--- /dev/null
+++ b/LICENCE
@@ -0,0 +1,37 @@
+Alexandria software and associated documentation are in the public
+domain:
+
+  Authors dedicate this work to public domain, for the benefit of the
+  public at large and to the detriment of the authors' heirs and
+  successors. Authors intends this dedication to be an overt act of
+  relinquishment in perpetuity of all present and future rights under
+  copyright law, whether vested or contingent, in the work. Authors
+  understands that such relinquishment of all rights includes the
+  relinquishment of all rights to enforce (by lawsuit or otherwise)
+  those copyrights in the work.
+
+  Authors recognize that, once placed in the public domain, the work
+  may be freely reproduced, distributed, transmitted, used, modified,
+  built upon, or otherwise exploited by anyone for any purpose,
+  commercial or non-commercial, and in any way, including by methods
+  that have not yet been invented or conceived.
+
+In those legislations where public domain dedications are not
+recognized or possible, Alexandria is distributed under the following
+terms and conditions:
+
+  Permission is hereby granted, free of charge, to any person
+  obtaining a copy of this software and associated documentation files
+  (the "Software"), to deal in the Software without restriction,
+  including without limitation the rights to use, copy, modify, merge,
+  publish, distribute, sublicense, and/or sell copies of the Software,
+  and to permit persons to whom the Software is furnished to do so,
+  subject to the following conditions:
+
+  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+  EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+  MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+  CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+  TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+  SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
diff --git a/README b/README
new file mode 100644
index 000000000000..a5dae9ed1ac7
--- /dev/null
+++ b/README
@@ -0,0 +1,52 @@
+Alexandria is a collection of portable public domain utilities that
+meet the following constraints:
+
+ * Utilities, not extensions: Alexandria will not contain conceptual
+   extensions to Common Lisp, instead limiting itself to tools and
+   utilities that fit well within the framework of standard ANSI
+   Common Lisp. Test-frameworks, system definitions, logging
+   facilities, serialization layers, etc. are all outside the scope of
+   Alexandria as a library, though well within the scope of Alexandria
+   as a project.
+
+ * Conservative: Alexandria limits itself to what project members
+   consider conservative utilities. Alexandria does not and will not
+   include anaphoric constructs, loop-like binding macros, etc.
+
+ * Portable: Alexandria limits itself to portable parts of Common
+   Lisp. Even apparently conservative and useful functions remain
+   outside the scope of Alexandria if they cannot be implemented
+   portably. Portability is here defined as portable within a
+   conforming implementation: implementation bugs are not considered
+   portability issues.
+
+Homepage:
+
+  http://common-lisp.net/project/alexandria/
+
+Mailing lists:
+
+  http://lists.common-lisp.net/mailman/listinfo/alexandria-devel
+  http://lists.common-lisp.net/mailman/listinfo/alexandria-cvs
+
+Repository:
+
+  git://gitlab.common-lisp.net/alexandria/alexandria.git
+
+Documentation:
+
+  http://common-lisp.net/project/alexandria/draft/alexandria.html
+
+  (To build docs locally: cd doc && make html pdf info)
+
+Patches:
+
+  Patches are always welcome! Please send them to the mailing list as
+  attachments, generated by "git format-patch -1".
+
+  Patches should include a commit message that explains what's being
+  done and /why/, and when fixing a bug or adding a feature you should
+  also include a test-case.
+
+  Be advised though that right now new features are unlikely to be
+  accepted until 1.0 is officially out of the door.
diff --git a/alexandria-tests.asd b/alexandria-tests.asd
new file mode 100644
index 000000000000..445c18cf7f77
--- /dev/null
+++ b/alexandria-tests.asd
@@ -0,0 +1,11 @@
+(defsystem "alexandria-tests"
+  :licence "Public Domain / 0-clause MIT"
+  :description "Tests for Alexandria, which is a collection of portable public domain utilities."
+  :author "Nikodemus Siivola <nikodemus@sb-studio.net>, and others."
+  :depends-on (:alexandria #+sbcl :sb-rt #-sbcl :rt)
+  :components ((:file "tests"))
+  :perform (test-op (o c)
+             (flet ((run-tests (&rest args)
+                      (apply (intern (string '#:run-tests) '#:alexandria-tests) args)))
+               (run-tests :compiled nil)
+               (run-tests :compiled t))))
diff --git a/alexandria.asd b/alexandria.asd
new file mode 100644
index 000000000000..db10e4f53710
--- /dev/null
+++ b/alexandria.asd
@@ -0,0 +1,62 @@
+(defsystem "alexandria"
+  :version "1.0.0"
+  :licence "Public Domain / 0-clause MIT"
+  :description "Alexandria is a collection of portable public domain utilities."
+  :author "Nikodemus Siivola and others."
+  :long-description
+  "Alexandria is a project and a library.
+
+As a project Alexandria's goal is to reduce duplication of effort and improve
+portability of Common Lisp code according to its own idiosyncratic and rather
+conservative aesthetic.
+
+As a library Alexandria is one of the means by which the project strives for
+its goals.
+
+Alexandria is a collection of portable public domain utilities that meet
+the following constraints:
+
+ * Utilities, not extensions: Alexandria will not contain conceptual
+   extensions to Common Lisp, instead limiting itself to tools and utilities
+   that fit well within the framework of standard ANSI Common Lisp.
+   Test-frameworks, system definitions, logging facilities, serialization
+   layers, etc. are all outside the scope of Alexandria as a library, though
+   well within the scope of Alexandria as a project.
+
+ * Conservative: Alexandria limits itself to what project members consider
+   conservative utilities. Alexandria does not and will not include anaphoric
+   constructs, loop-like binding macros, etc.
+   Also, its exported symbols are being imported by many other packages
+   already, so each new export carries the danger of causing conflicts.
+
+ * Portable: Alexandria limits itself to portable parts of Common Lisp. Even
+   apparently conservative and useful functions remain outside the scope of
+   Alexandria if they cannot be implemented portably. Portability is here
+   defined as portable within a conforming implementation: implementation bugs
+   are not considered portability issues.
+
+ * Team player: Alexandria will not (initially, at least) subsume or provide
+   functionality for which good-quality special-purpose packages exist, like
+   split-sequence. Instead, third party packages such as that may be
+   \"blessed\"."
+  :components
+  ((:static-file "LICENCE")
+   (:static-file "tests.lisp")
+   (:file "package")
+   (:file "definitions" :depends-on ("package"))
+   (:file "binding" :depends-on ("package"))
+   (:file "strings" :depends-on ("package"))
+   (:file "conditions" :depends-on ("package"))
+   (:file "io" :depends-on ("package" "macros" "lists" "types"))
+   (:file "macros" :depends-on ("package" "strings" "symbols"))
+   (:file "hash-tables" :depends-on ("package" "macros"))
+   (:file "control-flow" :depends-on ("package" "definitions" "macros"))
+   (:file "symbols" :depends-on ("package"))
+   (:file "functions" :depends-on ("package" "symbols" "macros"))
+   (:file "lists" :depends-on ("package" "functions"))
+   (:file "types" :depends-on ("package" "symbols" "lists"))
+   (:file "arrays" :depends-on ("package" "types"))
+   (:file "sequences" :depends-on ("package" "lists" "types"))
+   (:file "numbers" :depends-on ("package" "sequences"))
+   (:file "features" :depends-on ("package" "control-flow")))
+  :in-order-to ((test-op (test-op "alexandria-tests"))))
diff --git a/arrays.lisp b/arrays.lisp
new file mode 100644
index 000000000000..76c18791ad5f
--- /dev/null
+++ b/arrays.lisp
@@ -0,0 +1,18 @@
+(in-package :alexandria)
+
+(defun copy-array (array &key (element-type (array-element-type array))
+                              (fill-pointer (and (array-has-fill-pointer-p array)
+                                                 (fill-pointer array)))
+                              (adjustable (adjustable-array-p array)))
+  "Returns an undisplaced copy of ARRAY, with same fill-pointer and
+adjustability (if any) as the original, unless overridden by the keyword
+arguments."
+ (let* ((dimensions (array-dimensions array))
+        (new-array (make-array dimensions
+                               :element-type element-type
+                               :adjustable adjustable
+                               :fill-pointer fill-pointer)))
+   (dotimes (i (array-total-size array))
+     (setf (row-major-aref new-array i)
+           (row-major-aref array i)))
+   new-array))
diff --git a/binding.lisp b/binding.lisp
new file mode 100644
index 000000000000..37a3d52fb9f0
--- /dev/null
+++ b/binding.lisp
@@ -0,0 +1,90 @@
+(in-package :alexandria)
+
+(defmacro if-let (bindings &body (then-form &optional else-form))
+    "Creates new variable bindings, and conditionally executes either
+THEN-FORM or ELSE-FORM. ELSE-FORM defaults to NIL.
+
+BINDINGS must be either single binding of the form:
+
+ (variable initial-form)
+
+or a list of bindings of the form:
+
+ ((variable-1 initial-form-1)
+  (variable-2 initial-form-2)
+  ...
+  (variable-n initial-form-n))
+
+All initial-forms are executed sequentially in the specified order. Then all
+the variables are bound to the corresponding values.
+
+If all variables were bound to true values, the THEN-FORM is executed with the
+bindings in effect, otherwise the ELSE-FORM is executed with the bindings in
+effect."
+    (let* ((binding-list (if (and (consp bindings) (symbolp (car bindings)))
+                             (list bindings)
+                             bindings))
+         (variables (mapcar #'car binding-list)))
+    `(let ,binding-list
+       (if (and ,@variables)
+           ,then-form
+           ,else-form))))
+
+(defmacro when-let (bindings &body forms)
+    "Creates new variable bindings, and conditionally executes FORMS.
+
+BINDINGS must be either single binding of the form:
+
+ (variable initial-form)
+
+or a list of bindings of the form:
+
+ ((variable-1 initial-form-1)
+  (variable-2 initial-form-2)
+  ...
+  (variable-n initial-form-n))
+
+All initial-forms are executed sequentially in the specified order. Then all
+the variables are bound to the corresponding values.
+
+If all variables were bound to true values, then FORMS are executed as an
+implicit PROGN."
+  (let* ((binding-list (if (and (consp bindings) (symbolp (car bindings)))
+                           (list bindings)
+                           bindings))
+         (variables (mapcar #'car binding-list)))
+    `(let ,binding-list
+       (when (and ,@variables)
+         ,@forms))))
+
+(defmacro when-let* (bindings &body body)
+  "Creates new variable bindings, and conditionally executes BODY.
+
+BINDINGS must be either single binding of the form:
+
+ (variable initial-form)
+
+or a list of bindings of the form:
+
+ ((variable-1 initial-form-1)
+  (variable-2 initial-form-2)
+  ...
+  (variable-n initial-form-n))
+
+Each INITIAL-FORM is executed in turn, and the variable bound to the
+corresponding value. INITIAL-FORM expressions can refer to variables
+previously bound by the WHEN-LET*.
+
+Execution of WHEN-LET* stops immediately if any INITIAL-FORM evaluates to NIL.
+If all INITIAL-FORMs evaluate to true, then BODY is executed as an implicit
+PROGN."
+  (let ((binding-list (if (and (consp bindings) (symbolp (car bindings)))
+                          (list bindings)
+                          bindings)))
+    (labels ((bind (bindings body)
+               (if bindings
+                   `(let (,(car bindings))
+                      (when ,(caar bindings)
+                        ,(bind (cdr bindings) body)))
+                   `(progn ,@body))))
+      (bind binding-list body))))
diff --git a/conditions.lisp b/conditions.lisp
new file mode 100644
index 000000000000..ac471cca7e4c
--- /dev/null
+++ b/conditions.lisp
@@ -0,0 +1,91 @@
+(in-package :alexandria)
+
+(defun required-argument (&optional name)
+  "Signals an error for a missing argument of NAME. Intended for
+use as an initialization form for structure and class-slots, and
+a default value for required keyword arguments."
+  (error "Required argument ~@[~S ~]missing." name))
+
+(define-condition simple-style-warning (simple-warning style-warning)
+  ())
+
+(defun simple-style-warning (message &rest args)
+  (warn 'simple-style-warning :format-control message :format-arguments args))
+
+;; We don't specify a :report for simple-reader-error to let the
+;; underlying implementation report the line and column position for
+;; us. Unfortunately this way the message from simple-error is not
+;; displayed, unless there's special support for that in the
+;; implementation. But even then it's still inspectable from the
+;; debugger...
+(define-condition simple-reader-error
+    #-sbcl(simple-error reader-error)
+    #+sbcl(sb-int:simple-reader-error)
+  ())
+
+(defun simple-reader-error (stream message &rest args)
+  (error 'simple-reader-error
+         :stream stream
+         :format-control message
+         :format-arguments args))
+
+(define-condition simple-parse-error (simple-error parse-error)
+  ())
+
+(defun simple-parse-error (message &rest args)
+  (error 'simple-parse-error
+         :format-control message
+         :format-arguments args))
+
+(define-condition simple-program-error (simple-error program-error)
+  ())
+
+(defun simple-program-error (message &rest args)
+  (error 'simple-program-error
+         :format-control message
+         :format-arguments args))
+
+(defmacro ignore-some-conditions ((&rest conditions) &body body)
+  "Similar to CL:IGNORE-ERRORS but the (unevaluated) CONDITIONS
+list determines which specific conditions are to be ignored."
+  `(handler-case
+       (progn ,@body)
+     ,@(loop for condition in conditions collect
+             `(,condition (c) (values nil c)))))
+
+(defmacro unwind-protect-case ((&optional abort-flag) protected-form &body clauses)
+  "Like CL:UNWIND-PROTECT, but you can specify the circumstances that
+the cleanup CLAUSES are run.
+
+  clauses ::= (:NORMAL form*)* | (:ABORT form*)* | (:ALWAYS form*)*
+
+Clauses can be given in any order, and more than one clause can be
+given for each circumstance. The clauses whose denoted circumstance
+occured, are executed in the order the clauses appear.
+
+ABORT-FLAG is the name of a variable that will be bound to T in
+CLAUSES if the PROTECTED-FORM aborted preemptively, and to NIL
+otherwise.
+
+Examples:
+
+  (unwind-protect-case ()
+       (protected-form)
+     (:normal (format t \"This is only evaluated if PROTECTED-FORM executed normally.~%\"))
+     (:abort  (format t \"This is only evaluated if PROTECTED-FORM aborted preemptively.~%\"))
+     (:always (format t \"This is evaluated in either case.~%\")))
+
+  (unwind-protect-case (aborted-p)
+       (protected-form)
+     (:always (perform-cleanup-if aborted-p)))
+"
+  (check-type abort-flag (or null symbol))
+  (let ((gflag (gensym "FLAG+")))
+    `(let ((,gflag t))
+       (unwind-protect (multiple-value-prog1 ,protected-form (setf ,gflag nil))
+	 (let ,(and abort-flag `((,abort-flag ,gflag)))
+	   ,@(loop for (cleanup-kind . forms) in clauses
+		   collect (ecase cleanup-kind
+			     (:normal `(when (not ,gflag) ,@forms))
+			     (:abort  `(when ,gflag ,@forms))
+			     (:always `(progn ,@forms)))))))))
\ No newline at end of file
diff --git a/control-flow.lisp b/control-flow.lisp
new file mode 100644
index 000000000000..dd00df3e1620
--- /dev/null
+++ b/control-flow.lisp
@@ -0,0 +1,106 @@
+(in-package :alexandria)
+
+(defun extract-function-name (spec)
+  "Useful for macros that want to mimic the functional interface for functions
+like #'eq and 'eq."
+  (if (and (consp spec)
+           (member (first spec) '(quote function)))
+      (second spec)
+      spec))
+
+(defun generate-switch-body (whole object clauses test key &optional default)
+  (with-gensyms (value)
+    (setf test (extract-function-name test))
+    (setf key (extract-function-name key))
+    (when (and (consp default)
+               (member (first default) '(error cerror)))
+      (setf default `(,@default "No keys match in SWITCH. Testing against ~S with ~S."
+                      ,value ',test)))
+    `(let ((,value (,key ,object)))
+      (cond ,@(mapcar (lambda (clause)
+                        (if (member (first clause) '(t otherwise))
+                            (progn
+                              (when default
+                                (error "Multiple default clauses or illegal use of a default clause in ~S."
+                                       whole))
+                              (setf default `(progn ,@(rest clause)))
+                              '(()))
+                            (destructuring-bind (key-form &body forms) clause
+                              `((,test ,value ,key-form)
+                                ,@forms))))
+                      clauses)
+            (t ,default)))))
+
+(defmacro switch (&whole whole (object &key (test 'eql) (key 'identity))
+                         &body clauses)
+  "Evaluates first matching clause, returning its values, or evaluates and
+returns the values of T or OTHERWISE if no keys match."
+  (generate-switch-body whole object clauses test key))
+
+(defmacro eswitch (&whole whole (object &key (test 'eql) (key 'identity))
+                          &body clauses)
+  "Like SWITCH, but signals an error if no key matches."
+  (generate-switch-body whole object clauses test key '(error)))
+
+(defmacro cswitch (&whole whole (object &key (test 'eql) (key 'identity))
+                          &body clauses)
+  "Like SWITCH, but signals a continuable error if no key matches."
+  (generate-switch-body whole object clauses test key '(cerror "Return NIL from CSWITCH.")))
+
+(defmacro whichever (&rest possibilities &environment env)
+  "Evaluates exactly one of POSSIBILITIES, chosen at random."
+  (setf possibilities (mapcar (lambda (p) (macroexpand p env)) possibilities))
+  (if (every (lambda (p) (constantp p)) possibilities)
+      `(svref (load-time-value (vector ,@possibilities)) (random ,(length possibilities)))
+      (labels ((expand (possibilities position random-number)
+                 (if (null (cdr possibilities))
+                     (car possibilities)
+                     (let* ((length (length possibilities))
+                            (half (truncate length 2))
+                            (second-half (nthcdr half possibilities))
+                            (first-half (butlast possibilities (- length half))))
+                       `(if (< ,random-number ,(+ position half))
+                            ,(expand first-half position random-number)
+                            ,(expand second-half (+ position half) random-number))))))
+        (with-gensyms (random-number)
+          (let ((length (length possibilities)))
+            `(let ((,random-number (random ,length)))
+               ,(expand possibilities 0 random-number)))))))
+
+(defmacro xor (&rest datums)
+  "Evaluates its arguments one at a time, from left to right. If more than one
+argument evaluates to a true value no further DATUMS are evaluated, and NIL is
+returned as both primary and secondary value. If exactly one argument
+evaluates to true, its value is returned as the primary value after all the
+arguments have been evaluated, and T is returned as the secondary value. If no
+arguments evaluate to true NIL is retuned as primary, and T as secondary
+value."
+  (with-gensyms (xor tmp true)
+    `(let (,tmp ,true)
+       (block ,xor
+         ,@(mapcar (lambda (datum)
+                     `(if (setf ,tmp ,datum)
+                          (if ,true
+                              (return-from ,xor (values nil nil))
+                              (setf ,true ,tmp))))
+                   datums)
+         (return-from ,xor (values ,true t))))))
+
+(defmacro nth-value-or (nth-value &body forms)
+  "Evaluates FORM arguments one at a time, until the NTH-VALUE returned by one
+of the forms is true. It then returns all the values returned by evaluating
+that form. If none of the forms return a true nth value, this form returns
+NIL."
+  (once-only (nth-value)
+    (with-gensyms (values)
+      `(let ((,values (multiple-value-list ,(first forms))))
+         (if (nth ,nth-value ,values)
+             (values-list ,values)
+             ,(if (rest forms)
+                  `(nth-value-or ,nth-value ,@(rest forms))
+                  nil))))))
+
+(defmacro multiple-value-prog2 (first-form second-form &body forms)
+  "Evaluates FIRST-FORM, then SECOND-FORM, and then FORMS. Yields as its value
+all the value returned by SECOND-FORM."
+  `(progn ,first-form (multiple-value-prog1 ,second-form ,@forms)))
diff --git a/definitions.lisp b/definitions.lisp
new file mode 100644
index 000000000000..863e1f696286
--- /dev/null
+++ b/definitions.lisp
@@ -0,0 +1,37 @@
+(in-package :alexandria)
+
+(defun %reevaluate-constant (name value test)
+  (if (not (boundp name))
+      value
+      (let ((old (symbol-value name))
+            (new value))
+        (if (not (constantp name))
+            (prog1 new
+              (cerror "Try to redefine the variable as a constant."
+                      "~@<~S is an already bound non-constant variable ~
+                       whose value is ~S.~:@>" name old))
+            (if (funcall test old new)
+                old
+                (restart-case
+                    (error "~@<~S is an already defined constant whose value ~
+                              ~S is not equal to the provided initial value ~S ~
+                              under ~S.~:@>" name old new test)
+                  (ignore ()
+                    :report "Retain the current value."
+                    old)
+                  (continue ()
+                    :report "Try to redefine the constant."
+                    new)))))))
+
+(defmacro define-constant (name initial-value &key (test ''eql) documentation)
+  "Ensures that the global variable named by NAME is a constant with a value
+that is equal under TEST to the result of evaluating INITIAL-VALUE. TEST is a
+/function designator/ that defaults to EQL. If DOCUMENTATION is given, it
+becomes the documentation string of the constant.
+
+Signals an error if NAME is already a bound non-constant variable.
+
+Signals an error if NAME is already a constant variable whose value is not
+equal under TEST to result of evaluating INITIAL-VALUE."
+  `(defconstant ,name (%reevaluate-constant ',name ,initial-value ,test)
+     ,@(when documentation `(,documentation))))
diff --git a/doc/.gitignore b/doc/.gitignore
new file mode 100644
index 000000000000..f22577b3ac86
--- /dev/null
+++ b/doc/.gitignore
@@ -0,0 +1,3 @@
+alexandria
+include
+
diff --git a/doc/Makefile b/doc/Makefile
new file mode 100644
index 000000000000..85eb818220d5
--- /dev/null
+++ b/doc/Makefile
@@ -0,0 +1,28 @@
+.PHONY: clean html pdf include clean-include clean-crap info doc
+
+doc: pdf html info clean-crap
+
+clean-include:
+	rm -rf include
+
+clean-crap:
+	rm -f *.aux *.cp *.fn *.fns *.ky *.log *.pg *.toc *.tp *.tps *.vr
+
+clean: clean-include
+	rm -f  *.pdf *.html *.info
+
+include:
+	sbcl --no-userinit --eval '(require :asdf)' \
+	--eval '(let ((asdf:*central-registry* (list "../"))) (require :alexandria))' \
+	--load docstrings.lisp \
+	--eval '(sb-texinfo:generate-includes "include/" (list :alexandria) :base-package :alexandria)' \
+	--eval '(quit)'
+
+pdf: include
+	texi2pdf alexandria.texinfo
+
+html: include
+	makeinfo --html --no-split alexandria.texinfo
+
+info: include
+	makeinfo alexandria.texinfo
diff --git a/doc/alexandria.texinfo b/doc/alexandria.texinfo
new file mode 100644
index 000000000000..89b03ac34967
--- /dev/null
+++ b/doc/alexandria.texinfo
@@ -0,0 +1,277 @@
+\input texinfo   @c -*-texinfo-*-
+@c %**start of header
+@setfilename alexandria.info
+@settitle Alexandria Manual
+@c %**end of header
+
+@settitle Alexandria Manual -- draft version
+
+@c for install-info
+@dircategory Software development
+@direntry
+* alexandria:           Common Lisp utilities.
+@end direntry
+
+@copying
+Alexandria software and associated documentation are in the public
+domain:
+
+@quotation
+  Authors dedicate this work to public domain, for the benefit of the
+  public at large and to the detriment of the authors' heirs and
+  successors. Authors intends this dedication to be an overt act of
+  relinquishment in perpetuity of all present and future rights under
+  copyright law, whether vested or contingent, in the work. Authors
+  understands that such relinquishment of all rights includes the
+  relinquishment of all rights to enforce (by lawsuit or otherwise)
+  those copyrights in the work.
+
+  Authors recognize that, once placed in the public domain, the work
+  may be freely reproduced, distributed, transmitted, used, modified,
+  built upon, or otherwise exploited by anyone for any purpose,
+  commercial or non-commercial, and in any way, including by methods
+  that have not yet been invented or conceived.
+@end quotation
+
+In those legislations where public domain dedications are not
+recognized or possible, Alexandria is distributed under the following
+terms and conditions:
+
+@quotation
+  Permission is hereby granted, free of charge, to any person
+  obtaining a copy of this software and associated documentation files
+  (the "Software"), to deal in the Software without restriction,
+  including without limitation the rights to use, copy, modify, merge,
+  publish, distribute, sublicense, and/or sell copies of the Software,
+  and to permit persons to whom the Software is furnished to do so,
+  subject to the following conditions:
+
+  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+  EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+  MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+  CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+  TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+  SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+@end quotation
+@end copying
+
+@titlepage
+
+@title Alexandria Manual
+@subtitle draft version
+
+@c The following two commands start the copyright page.
+@page
+@vskip 0pt plus 1filll
+@insertcopying
+
+@end titlepage
+
+@contents
+
+@ifnottex
+
+@include include/ifnottex.texinfo
+
+@node Top
+@comment  node-name,  next,  previous,  up
+@top Alexandria
+
+@insertcopying
+
+@menu
+* Hash Tables::
+* Data and Control Flow::
+* Conses::
+* Sequences::
+* IO::
+* Macro Writing::
+* Symbols::
+* Arrays::
+* Types::
+* Numbers::
+@end menu
+
+@end ifnottex
+
+@node Hash Tables
+@comment  node-name,  next,  previous,  up
+@chapter Hash Tables
+
+@include include/macro-alexandria-ensure-gethash.texinfo
+@include include/fun-alexandria-copy-hash-table.texinfo
+@include include/fun-alexandria-maphash-keys.texinfo
+@include include/fun-alexandria-maphash-values.texinfo
+@include include/fun-alexandria-hash-table-keys.texinfo
+@include include/fun-alexandria-hash-table-values.texinfo
+@include include/fun-alexandria-hash-table-alist.texinfo
+@include include/fun-alexandria-hash-table-plist.texinfo
+@include include/fun-alexandria-alist-hash-table.texinfo
+@include include/fun-alexandria-plist-hash-table.texinfo
+
+@node Data and Control Flow
+@comment  node-name,  next,  previous,  up
+@chapter Data and Control Flow
+
+@include include/macro-alexandria-define-constant.texinfo
+@include include/macro-alexandria-destructuring-case.texinfo
+@include include/macro-alexandria-ensure-functionf.texinfo
+@include include/macro-alexandria-multiple-value-prog2.texinfo
+@include include/macro-alexandria-named-lambda.texinfo
+@include include/macro-alexandria-nth-value-or.texinfo
+@include include/macro-alexandria-if-let.texinfo
+@include include/macro-alexandria-when-let.texinfo
+@include include/macro-alexandria-when-let-star.texinfo
+@include include/macro-alexandria-switch.texinfo
+@include include/macro-alexandria-cswitch.texinfo
+@include include/macro-alexandria-eswitch.texinfo
+@include include/macro-alexandria-whichever.texinfo
+@include include/macro-alexandria-xor.texinfo
+
+@include include/fun-alexandria-disjoin.texinfo
+@include include/fun-alexandria-conjoin.texinfo
+@include include/fun-alexandria-compose.texinfo
+@include include/fun-alexandria-ensure-function.texinfo
+@include include/fun-alexandria-multiple-value-compose.texinfo
+@include include/fun-alexandria-curry.texinfo
+@include include/fun-alexandria-rcurry.texinfo
+
+@node Conses
+@comment  node-name,  next,  previous,  up
+@chapter Conses
+
+@include include/type-alexandria-proper-list.texinfo
+@include include/type-alexandria-circular-list.texinfo
+
+@include include/macro-alexandria-appendf.texinfo
+@include include/macro-alexandria-nconcf.texinfo
+@include include/macro-alexandria-remove-from-plistf.texinfo
+@include include/macro-alexandria-delete-from-plistf.texinfo
+@include include/macro-alexandria-reversef.texinfo
+@include include/macro-alexandria-nreversef.texinfo
+@include include/macro-alexandria-unionf.texinfo
+@include include/macro-alexandria-nunionf.texinfo
+
+@include include/macro-alexandria-doplist.texinfo
+
+@include include/fun-alexandria-circular-list-p.texinfo
+@include include/fun-alexandria-circular-tree-p.texinfo
+@include include/fun-alexandria-proper-list-p.texinfo
+
+@include include/fun-alexandria-alist-plist.texinfo
+@include include/fun-alexandria-plist-alist.texinfo
+@include include/fun-alexandria-circular-list.texinfo
+@include include/fun-alexandria-make-circular-list.texinfo
+@include include/fun-alexandria-ensure-car.texinfo
+@include include/fun-alexandria-ensure-cons.texinfo
+@include include/fun-alexandria-ensure-list.texinfo
+@include include/fun-alexandria-flatten.texinfo
+@include include/fun-alexandria-lastcar.texinfo
+@include include/fun-alexandria-setf-lastcar.texinfo
+@include include/fun-alexandria-proper-list-length.texinfo
+@include include/fun-alexandria-mappend.texinfo
+@include include/fun-alexandria-map-product.texinfo
+@include include/fun-alexandria-remove-from-plist.texinfo
+@include include/fun-alexandria-delete-from-plist.texinfo
+@include include/fun-alexandria-set-equal.texinfo
+@include include/fun-alexandria-setp.texinfo
+
+@node Sequences
+@comment  node-name,  next,  previous,  up
+@chapter Sequences
+
+@include include/type-alexandria-proper-sequence.texinfo
+
+@include include/macro-alexandria-deletef.texinfo
+@include include/macro-alexandria-removef.texinfo
+
+@include include/fun-alexandria-rotate.texinfo
+@include include/fun-alexandria-shuffle.texinfo
+@include include/fun-alexandria-random-elt.texinfo
+@include include/fun-alexandria-emptyp.texinfo
+@include include/fun-alexandria-sequence-of-length-p.texinfo
+@include include/fun-alexandria-length-equals.texinfo
+@include include/fun-alexandria-copy-sequence.texinfo
+@include include/fun-alexandria-first-elt.texinfo
+@include include/fun-alexandria-setf-first-elt.texinfo
+@include include/fun-alexandria-last-elt.texinfo
+@include include/fun-alexandria-setf-last-elt.texinfo
+@include include/fun-alexandria-starts-with.texinfo
+@include include/fun-alexandria-starts-with-subseq.texinfo
+@include include/fun-alexandria-ends-with.texinfo
+@include include/fun-alexandria-ends-with-subseq.texinfo
+@include include/fun-alexandria-map-combinations.texinfo
+@include include/fun-alexandria-map-derangements.texinfo
+@include include/fun-alexandria-map-permutations.texinfo
+
+@node IO
+@comment  node-name,   next,  previous,  up
+@chapter IO
+
+@include include/fun-alexandria-read-stream-content-into-string.texinfo
+@include include/fun-alexandria-read-file-into-string.texinfo
+@include include/fun-alexandria-read-stream-content-into-byte-vector.texinfo
+@include include/fun-alexandria-read-file-into-byte-vector.texinfo
+
+@node Macro Writing
+@comment  node-name,  next,  previous,  up
+@chapter Macro Writing
+
+@include include/macro-alexandria-once-only.texinfo
+@include include/macro-alexandria-with-gensyms.texinfo
+@include include/macro-alexandria-with-unique-names.texinfo
+@include include/fun-alexandria-featurep.texinfo
+@include include/fun-alexandria-parse-body.texinfo
+@include include/fun-alexandria-parse-ordinary-lambda-list.texinfo
+
+@node Symbols
+@comment  node-name,  next,  previous,  up
+@chapter Symbols
+
+@include include/fun-alexandria-ensure-symbol.texinfo
+@include include/fun-alexandria-format-symbol.texinfo
+@include include/fun-alexandria-make-keyword.texinfo
+@include include/fun-alexandria-make-gensym.texinfo
+@include include/fun-alexandria-make-gensym-list.texinfo
+@include include/fun-alexandria-symbolicate.texinfo
+
+@node Arrays
+@comment  node-name,  next,  previous,  up
+@chapter Arrays
+
+@include include/type-alexandria-array-index.texinfo
+@include include/type-alexandria-array-length.texinfo
+@include include/fun-alexandria-copy-array.texinfo
+
+@node Types
+@comment  node-name,  next,  previous,  up
+@chapter Types
+
+@include include/type-alexandria-string-designator.texinfo
+@include include/macro-alexandria-coercef.texinfo
+@include include/fun-alexandria-of-type.texinfo
+@include include/fun-alexandria-type-equals.texinfo
+
+@node Numbers
+@comment  node-name,  next,  previous,  up
+@chapter Numbers
+
+@include include/macro-alexandria-maxf.texinfo
+@include include/macro-alexandria-minf.texinfo
+
+@include include/fun-alexandria-binomial-coefficient.texinfo
+@include include/fun-alexandria-count-permutations.texinfo
+@include include/fun-alexandria-clamp.texinfo
+@include include/fun-alexandria-lerp.texinfo
+@include include/fun-alexandria-factorial.texinfo
+@include include/fun-alexandria-subfactorial.texinfo
+@include include/fun-alexandria-gaussian-random.texinfo
+@include include/fun-alexandria-iota.texinfo
+@include include/fun-alexandria-map-iota.texinfo
+@include include/fun-alexandria-mean.texinfo
+@include include/fun-alexandria-median.texinfo
+@include include/fun-alexandria-variance.texinfo
+@include include/fun-alexandria-standard-deviation.texinfo
+
+@bye
diff --git a/doc/docstrings.lisp b/doc/docstrings.lisp
new file mode 100644
index 000000000000..51dda07d09b7
--- /dev/null
+++ b/doc/docstrings.lisp
@@ -0,0 +1,881 @@
+;;; -*- lisp -*-
+
+;;;; A docstring extractor for the sbcl manual.  Creates
+;;;; @include-ready documentation from the docstrings of exported
+;;;; symbols of specified packages.
+
+;;;; This software is part of the SBCL software system. SBCL is in the
+;;;; public domain and is provided with absolutely no warranty. See
+;;;; the COPYING file for more information.
+;;;;
+;;;; Written by Rudi Schlatte <rudi@constantly.at>, mangled
+;;;; by Nikodemus Siivola.
+
+;;;; TODO
+;;;; * Verbatim text
+;;;; * Quotations
+;;;; * Method documentation untested
+;;;; * Method sorting, somehow
+;;;; * Index for macros & constants?
+;;;; * This is getting complicated enough that tests would be good
+;;;; * Nesting (currently only nested itemizations work)
+;;;; * doc -> internal form -> texinfo (so that non-texinfo format are also
+;;;;   easily generated)
+
+;;;; FIXME: The description below is no longer complete. This
+;;;; should possibly be turned into a contrib with proper documentation.
+
+;;;; Formatting heuristics (tweaked to format SAVE-LISP-AND-DIE sanely):
+;;;;
+;;;; Formats SYMBOL as @code{symbol}, or @var{symbol} if symbol is in
+;;;; the argument list of the defun / defmacro.
+;;;;
+;;;; Lines starting with * or - that are followed by intented lines
+;;;; are marked up with @itemize.
+;;;;
+;;;; Lines containing only a SYMBOL that are followed by indented
+;;;; lines are marked up as @table @code, with the SYMBOL as the item.
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (require 'sb-introspect))
+
+(defpackage :sb-texinfo
+  (:use :cl :sb-mop)
+  (:shadow #:documentation)
+  (:export #:generate-includes #:document-package)
+  (:documentation
+   "Tools to generate TexInfo documentation from docstrings."))
+
+(in-package :sb-texinfo)
+
+;;;; various specials and parameters
+
+(defvar *texinfo-output*)
+(defvar *texinfo-variables*)
+(defvar *documentation-package*)
+(defvar *base-package*)
+
+(defparameter *undocumented-packages* '(sb-pcl sb-int sb-kernel sb-sys sb-c))
+
+(defparameter *documentation-types*
+  '(compiler-macro
+    function
+    method-combination
+    setf
+    ;;structure  ; also handled by `type'
+    type
+    variable)
+  "A list of symbols accepted as second argument of `documentation'")
+
+(defparameter *character-replacements*
+  '((#\* . "star") (#\/ . "slash") (#\+ . "plus")
+    (#\< . "lt") (#\> . "gt")
+    (#\= . "equals"))
+  "Characters and their replacement names that `alphanumize' uses. If
+the replacements contain any of the chars they're supposed to replace,
+you deserve to lose.")
+
+(defparameter *characters-to-drop* '(#\\ #\` #\')
+  "Characters that should be removed by `alphanumize'.")
+
+(defparameter *texinfo-escaped-chars* "@{}"
+  "Characters that must be escaped with #\@ for Texinfo.")
+
+(defparameter *itemize-start-characters* '(#\* #\-)
+  "Characters that might start an itemization in docstrings when
+  at the start of a line.")
+
+(defparameter *symbol-characters* "ABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890*:-+&#'"
+  "List of characters that make up symbols in a docstring.")
+
+(defparameter *symbol-delimiters* " ,.!?;")
+
+(defparameter *ordered-documentation-kinds*
+  '(package type structure condition class macro))
+
+;;;; utilities
+
+(defun flatten (list)
+  (cond ((null list)
+         nil)
+        ((consp (car list))
+         (nconc (flatten (car list)) (flatten (cdr list))))
+        ((null (cdr list))
+         (cons (car list) nil))
+        (t
+         (cons (car list) (flatten (cdr list))))))
+
+(defun whitespacep (char)
+  (find char #(#\tab #\space #\page)))
+
+(defun setf-name-p (name)
+  (or (symbolp name)
+      (and (listp name) (= 2 (length name)) (eq (car name) 'setf))))
+
+(defgeneric specializer-name (specializer))
+
+(defmethod specializer-name ((specializer eql-specializer))
+  (list 'eql (eql-specializer-object specializer)))
+
+(defmethod specializer-name ((specializer class))
+  (class-name specializer))
+
+(defun ensure-class-precedence-list (class)
+  (unless (class-finalized-p class)
+    (finalize-inheritance class))
+  (class-precedence-list class))
+
+(defun specialized-lambda-list (method)
+  ;; courtecy of AMOP p. 61
+  (let* ((specializers (method-specializers method))
+         (lambda-list (method-lambda-list method))
+         (n-required (length specializers)))
+    (append (mapcar (lambda (arg specializer)
+                      (if  (eq specializer (find-class 't))
+                           arg
+                           `(,arg ,(specializer-name specializer))))
+                    (subseq lambda-list 0 n-required)
+                    specializers)
+           (subseq lambda-list n-required))))
+
+(defun string-lines (string)
+  "Lines in STRING as a vector."
+  (coerce (with-input-from-string (s string)
+            (loop for line = (read-line s nil nil)
+               while line collect line))
+          'vector))
+
+(defun indentation (line)
+  "Position of first non-SPACE character in LINE."
+  (position-if-not (lambda (c) (char= c #\Space)) line))
+
+(defun docstring (x doc-type)
+  (cl:documentation x doc-type))
+
+(defun flatten-to-string (list)
+  (format nil "~{~A~^-~}" (flatten list)))
+
+(defun alphanumize (original)
+  "Construct a string without characters like *`' that will f-star-ck
+up filename handling. See `*character-replacements*' and
+`*characters-to-drop*' for customization."
+  (let ((name (remove-if (lambda (x) (member x *characters-to-drop*))
+                         (if (listp original)
+                             (flatten-to-string original)
+                             (string original))))
+        (chars-to-replace (mapcar #'car *character-replacements*)))
+    (flet ((replacement-delimiter (index)
+             (cond ((or (< index 0) (>= index (length name))) "")
+                   ((alphanumericp (char name index)) "-")
+                   (t ""))))
+      (loop for index = (position-if #'(lambda (x) (member x chars-to-replace))
+                                     name)
+         while index
+         do (setf name (concatenate 'string (subseq name 0 index)
+                                    (replacement-delimiter (1- index))
+                                    (cdr (assoc (aref name index)
+                                                *character-replacements*))
+                                    (replacement-delimiter (1+ index))
+                                    (subseq name (1+ index))))))
+    name))
+
+;;;; generating various names
+
+(defgeneric name (thing)
+  (:documentation "Name for a documented thing. Names are either
+symbols or lists of symbols."))
+
+(defmethod name ((symbol symbol))
+  symbol)
+
+(defmethod name ((cons cons))
+  cons)
+
+(defmethod name ((package package))
+  (short-package-name package))
+
+(defmethod name ((method method))
+  (list
+   (generic-function-name (method-generic-function method))
+   (method-qualifiers method)
+   (specialized-lambda-list method)))
+
+;;; Node names for DOCUMENTATION instances
+
+(defgeneric name-using-kind/name (kind name doc))
+
+(defmethod name-using-kind/name (kind (name string) doc)
+  (declare (ignore kind doc))
+  name)
+
+(defmethod name-using-kind/name (kind (name symbol) doc)
+  (declare (ignore kind))
+  (format nil "~@[~A:~]~A" (short-package-name (get-package doc)) name))
+
+(defmethod name-using-kind/name (kind (name list) doc)
+  (declare (ignore kind))
+  (assert (setf-name-p name))
+  (format nil "(setf ~@[~A:~]~A)" (short-package-name (get-package doc)) (second name)))
+
+(defmethod name-using-kind/name ((kind (eql 'method)) name doc)
+  (format nil "~A~{ ~A~} ~A"
+          (name-using-kind/name nil (first name) doc)
+          (second name)
+          (third name)))
+
+(defun node-name (doc)
+  "Returns TexInfo node name as a string for a DOCUMENTATION instance."
+  (let ((kind (get-kind doc)))
+    (format nil "~:(~A~) ~(~A~)" kind (name-using-kind/name kind (get-name doc) doc))))
+
+(defun short-package-name (package)
+  (unless (eq package *base-package*)
+    (car (sort (copy-list (cons (package-name package) (package-nicknames package)))
+               #'< :key #'length))))
+
+;;; Definition titles for DOCUMENTATION instances
+
+(defgeneric title-using-kind/name (kind name doc))
+
+(defmethod title-using-kind/name (kind (name string) doc)
+  (declare (ignore kind doc))
+  name)
+
+(defmethod title-using-kind/name (kind (name symbol) doc)
+  (declare (ignore kind))
+  (format nil "~@[~A:~]~A" (short-package-name (get-package doc)) name))
+
+(defmethod title-using-kind/name (kind (name list) doc)
+  (declare (ignore kind))
+  (assert (setf-name-p name))
+  (format nil "(setf ~@[~A:~]~A)" (short-package-name (get-package doc)) (second name)))
+
+(defmethod title-using-kind/name ((kind (eql 'method)) name doc)
+  (format nil "~{~A ~}~A"
+          (second name)
+          (title-using-kind/name nil (first name) doc)))
+
+(defun title-name (doc)
+  "Returns a string to be used as name of the definition."
+  (string-downcase (title-using-kind/name (get-kind doc) (get-name doc) doc)))
+
+(defun include-pathname (doc)
+  (let* ((kind (get-kind doc))
+         (name (nstring-downcase
+                (if (eq 'package kind)
+                    (format nil "package-~A" (alphanumize (get-name doc)))
+                    (format nil "~A-~A-~A"
+                            (case (get-kind doc)
+                              ((function generic-function) "fun")
+                              (structure "struct")
+                              (variable "var")
+                              (otherwise (symbol-name (get-kind doc))))
+                            (alphanumize (let ((*base-package* nil))
+                                           (short-package-name (get-package doc))))
+                            (alphanumize (get-name doc)))))))
+    (make-pathname :name name  :type "texinfo")))
+
+;;;; documentation class and related methods
+
+(defclass documentation ()
+  ((name :initarg :name :reader get-name)
+   (kind :initarg :kind :reader get-kind)
+   (string :initarg :string :reader get-string)
+   (children :initarg :children :initform nil :reader get-children)
+   (package :initform *documentation-package* :reader get-package)))
+
+(defmethod print-object ((documentation documentation) stream)
+  (print-unreadable-object (documentation stream :type t)
+    (princ (list (get-kind documentation) (get-name documentation)) stream)))
+
+(defgeneric make-documentation (x doc-type string))
+
+(defmethod make-documentation ((x package) doc-type string)
+  (declare (ignore doc-type))
+  (make-instance 'documentation
+                 :name (name x)
+                 :kind 'package
+                 :string string))
+
+(defmethod make-documentation (x (doc-type (eql 'function)) string)
+  (declare (ignore doc-type))
+  (let* ((fdef (and (fboundp x) (fdefinition x)))
+         (name x)
+         (kind (cond ((and (symbolp x) (special-operator-p x))
+                      'special-operator)
+                     ((and (symbolp x) (macro-function x))
+                      'macro)
+                     ((typep fdef 'generic-function)
+                      (assert (or (symbolp name) (setf-name-p name)))
+                      'generic-function)
+                     (fdef
+                      (assert (or (symbolp name) (setf-name-p name)))
+                      'function)))
+         (children (when (eq kind 'generic-function)
+                     (collect-gf-documentation fdef))))
+    (make-instance 'documentation
+                   :name (name x)
+                   :string string
+                   :kind kind
+                   :children children)))
+
+(defmethod make-documentation ((x method) doc-type string)
+  (declare (ignore doc-type))
+  (make-instance 'documentation
+                 :name (name x)
+                 :kind 'method
+                 :string string))
+
+(defmethod make-documentation (x (doc-type (eql 'type)) string)
+  (make-instance 'documentation
+                 :name (name x)
+                 :string string
+                 :kind (etypecase (find-class x nil)
+                         (structure-class 'structure)
+                         (standard-class 'class)
+                         (sb-pcl::condition-class 'condition)
+                         ((or built-in-class null) 'type))))
+
+(defmethod make-documentation (x (doc-type (eql 'variable)) string)
+  (make-instance 'documentation
+                 :name (name x)
+                 :string string
+                 :kind (if (constantp x)
+                           'constant
+                           'variable)))
+
+(defmethod make-documentation (x (doc-type (eql 'setf)) string)
+  (declare (ignore doc-type))
+  (make-instance 'documentation
+                 :name (name x)
+                 :kind 'setf-expander
+                 :string string))
+
+(defmethod make-documentation (x doc-type string)
+  (make-instance 'documentation
+                 :name (name x)
+                 :kind doc-type
+                 :string string))
+
+(defun maybe-documentation (x doc-type)
+  "Returns a DOCUMENTATION instance for X and DOC-TYPE, or NIL if
+there is no corresponding docstring."
+  (let ((docstring (docstring x doc-type)))
+    (when docstring
+      (make-documentation x doc-type docstring))))
+
+(defun lambda-list (doc)
+  (case (get-kind doc)
+    ((package constant variable type structure class condition nil)
+     nil)
+    (method
+     (third (get-name doc)))
+    (t
+     ;; KLUDGE: Eugh.
+     ;;
+     ;; believe it or not, the above comment was written before CSR
+     ;; came along and obfuscated this.  (2005-07-04)
+     (when (symbolp (get-name doc))
+       (labels ((clean (x &key optional key)
+                  (typecase x
+                    (atom x)
+                    ((cons (member &optional))
+                     (cons (car x) (clean (cdr x) :optional t)))
+                    ((cons (member &key))
+                     (cons (car x) (clean (cdr x) :key t)))
+                    ((cons (member &whole &environment))
+                     ;; Skip these
+                     (clean (cdr x) :optional optional :key key))
+                    ((cons cons)
+                     (cons
+                      (cond (key (if (consp (caar x))
+                                     (caaar x)
+                                     (caar x)))
+                            (optional (caar x))
+                            (t (clean (car x))))
+                      (clean (cdr x) :key key :optional optional)))
+                    (cons
+                     (cons
+                      (cond ((or key optional) (car x))
+                            (t (clean (car x))))
+                      (clean (cdr x) :key key :optional optional))))))
+         (clean (sb-introspect:function-lambda-list (get-name doc))))))))
+
+(defun get-string-name (x)
+  (let ((name (get-name x)))
+    (cond ((symbolp name)
+           (symbol-name name))
+          ((and (consp name) (eq 'setf (car name)))
+           (symbol-name (second name)))
+          ((stringp name)
+           name)
+          (t
+           (error "Don't know which symbol to use for name ~S" name)))))
+
+(defun documentation< (x y)
+  (let ((p1 (position (get-kind x) *ordered-documentation-kinds*))
+        (p2 (position (get-kind y) *ordered-documentation-kinds*)))
+    (if (or (not (and p1 p2)) (= p1 p2))
+        (string< (get-string-name x) (get-string-name y))
+        (< p1 p2))))
+
+;;;; turning text into texinfo
+
+(defun escape-for-texinfo (string &optional downcasep)
+  "Return STRING with characters in *TEXINFO-ESCAPED-CHARS* escaped
+with #\@. Optionally downcase the result."
+  (let ((result (with-output-to-string (s)
+                  (loop for char across string
+                        when (find char *texinfo-escaped-chars*)
+                        do (write-char #\@ s)
+                        do (write-char char s)))))
+    (if downcasep (nstring-downcase result) result)))
+
+(defun empty-p (line-number lines)
+  (and (< -1 line-number (length lines))
+       (not (indentation (svref lines line-number)))))
+
+;;; line markups
+
+(defvar *not-symbols* '("ANSI" "CLHS"))
+
+(defun locate-symbols (line)
+  "Return a list of index pairs of symbol-like parts of LINE."
+  ;; This would be a good application for a regex ...
+  (let (result)
+    (flet ((grab (start end)
+             (unless (member (subseq line start end) '("ANSI" "CLHS"))
+               (push (list start end) result))))
+      (do ((begin nil)
+           (maybe-begin t)
+           (i 0 (1+ i)))
+          ((= i (length line))
+           ;; symbol at end of line
+           (when (and begin (or (> i (1+ begin))
+                                (not (member (char line begin) '(#\A #\I)))))
+             (grab begin i))
+           (nreverse result))
+        (cond
+          ((and begin (find (char line i) *symbol-delimiters*))
+           ;; symbol end; remember it if it's not "A" or "I"
+           (when (or (> i (1+ begin)) (not (member (char line begin) '(#\A #\I))))
+             (grab begin i))
+           (setf begin nil
+                 maybe-begin t))
+          ((and begin (not (find (char line i) *symbol-characters*)))
+           ;; Not a symbol: abort
+           (setf begin nil))
+          ((and maybe-begin (not begin) (find (char line i) *symbol-characters*))
+           ;; potential symbol begin at this position
+           (setf begin i
+                 maybe-begin nil))
+          ((find (char line i) *symbol-delimiters*)
+           ;; potential symbol begin after this position
+           (setf maybe-begin t))
+          (t
+           ;; Not reading a symbol, not at potential start of symbol
+           (setf maybe-begin nil)))))))
+
+(defun texinfo-line (line)
+  "Format symbols in LINE texinfo-style: either as code or as
+variables if the symbol in question is contained in symbols
+*TEXINFO-VARIABLES*."
+  (with-output-to-string (result)
+    (let ((last 0))
+      (dolist (symbol/index (locate-symbols line))
+        (write-string (subseq line last (first symbol/index)) result)
+        (let ((symbol-name (apply #'subseq line symbol/index)))
+          (format result (if (member symbol-name *texinfo-variables*
+                                     :test #'string=)
+                             "@var{~A}"
+                             "@code{~A}")
+                  (string-downcase symbol-name)))
+        (setf last (second symbol/index)))
+      (write-string (subseq line last) result))))
+
+;;; lisp sections
+
+(defun lisp-section-p (line line-number lines)
+  "Returns T if the given LINE looks like start of lisp code --
+ie. if it starts with whitespace followed by a paren or
+semicolon, and the previous line is empty"
+  (let ((offset (indentation line)))
+    (and offset
+         (plusp offset)
+         (find (find-if-not #'whitespacep line) "(;")
+         (empty-p (1- line-number) lines))))
+
+(defun collect-lisp-section (lines line-number)
+  (let ((lisp (loop for index = line-number then (1+ index)
+                    for line = (and (< index (length lines)) (svref lines index))
+                    while (indentation line)
+                    collect line)))
+    (values (length lisp) `("@lisp" ,@lisp "@end lisp"))))
+
+;;; itemized sections
+
+(defun maybe-itemize-offset (line)
+  "Return NIL or the indentation offset if LINE looks like it starts
+an item in an itemization."
+  (let* ((offset (indentation line))
+         (char (when offset (char line offset))))
+    (and offset
+         (member char *itemize-start-characters* :test #'char=)
+         (char= #\Space (find-if-not (lambda (c) (char= c char))
+                                     line :start offset))
+         offset)))
+
+(defun collect-maybe-itemized-section (lines starting-line)
+  ;; Return index of next line to be processed outside
+  (let ((this-offset (maybe-itemize-offset (svref lines starting-line)))
+        (result nil)
+        (lines-consumed 0))
+    (loop for line-number from starting-line below (length lines)
+       for line = (svref lines line-number)
+       for indentation = (indentation line)
+       for offset = (maybe-itemize-offset line)
+       do (cond
+            ((not indentation)
+             ;; empty line -- inserts paragraph.
+             (push "" result)
+             (incf lines-consumed))
+            ((and offset (> indentation this-offset))
+             ;; nested itemization -- handle recursively
+             ;; FIXME: tables in itemizations go wrong
+             (multiple-value-bind (sub-lines-consumed sub-itemization)
+                 (collect-maybe-itemized-section lines line-number)
+               (when sub-lines-consumed
+                 (incf line-number (1- sub-lines-consumed)) ; +1 on next loop
+                 (incf lines-consumed sub-lines-consumed)
+                 (setf result (nconc (nreverse sub-itemization) result)))))
+            ((and offset (= indentation this-offset))
+             ;; start of new item
+             (push (format nil "@item ~A"
+                           (texinfo-line (subseq line (1+ offset))))
+                   result)
+             (incf lines-consumed))
+            ((and (not offset) (> indentation this-offset))
+             ;; continued item from previous line
+             (push (texinfo-line line) result)
+             (incf lines-consumed))
+            (t
+             ;; end of itemization
+             (loop-finish))))
+    ;; a single-line itemization isn't.
+    (if (> (count-if (lambda (line) (> (length line) 0)) result) 1)
+        (values lines-consumed `("@itemize" ,@(reverse result) "@end itemize"))
+        nil)))
+
+;;; table sections
+
+(defun tabulation-body-p (offset line-number lines)
+  (when (< line-number (length lines))
+    (let ((offset2 (indentation (svref lines line-number))))
+      (and offset2 (< offset offset2)))))
+
+(defun tabulation-p (offset line-number lines direction)
+  (let ((step  (ecase direction
+                 (:backwards (1- line-number))
+                 (:forwards (1+ line-number)))))
+    (when (and (plusp line-number) (< line-number (length lines)))
+      (and (eql offset (indentation (svref lines line-number)))
+           (or (when (eq direction :backwards)
+                 (empty-p step lines))
+               (tabulation-p offset step lines direction)
+               (tabulation-body-p offset step lines))))))
+
+(defun maybe-table-offset (line-number lines)
+  "Return NIL or the indentation offset if LINE looks like it starts
+an item in a tabulation. Ie, if it is (1) indented, (2) preceded by an
+empty line, another tabulation label, or a tabulation body, (3) and
+followed another tabulation label or a tabulation body."
+  (let* ((line (svref lines line-number))
+         (offset (indentation line))
+         (prev (1- line-number))
+         (next (1+ line-number)))
+    (when (and offset (plusp offset))
+      (and (or (empty-p prev lines)
+               (tabulation-body-p offset prev lines)
+               (tabulation-p offset prev lines :backwards))
+           (or (tabulation-body-p offset next lines)
+               (tabulation-p offset next lines :forwards))
+           offset))))
+
+;;; FIXME: This and itemization are very similar: could they share
+;;; some code, mayhap?
+
+(defun collect-maybe-table-section (lines starting-line)
+  ;; Return index of next line to be processed outside
+  (let ((this-offset (maybe-table-offset starting-line lines))
+        (result nil)
+        (lines-consumed 0))
+    (loop for line-number from starting-line below (length lines)
+          for line = (svref lines line-number)
+          for indentation = (indentation line)
+          for offset = (maybe-table-offset line-number lines)
+          do (cond
+               ((not indentation)
+                ;; empty line -- inserts paragraph.
+                (push "" result)
+                (incf lines-consumed))
+               ((and offset (= indentation this-offset))
+                ;; start of new item, or continuation of previous item
+                (if (and result (search "@item" (car result) :test #'char=))
+                    (push (format nil "@itemx ~A" (texinfo-line line))
+                          result)
+                    (progn
+                      (push "" result)
+                      (push (format nil "@item ~A" (texinfo-line line))
+                            result)))
+                (incf lines-consumed))
+               ((> indentation this-offset)
+                ;; continued item from previous line
+                (push (texinfo-line line) result)
+                (incf lines-consumed))
+               (t
+                ;; end of itemization
+                (loop-finish))))
+     ;; a single-line table isn't.
+    (if (> (count-if (lambda (line) (> (length line) 0)) result) 1)
+        (values lines-consumed
+                `("" "@table @emph" ,@(reverse result) "@end table" ""))
+        nil)))
+
+;;; section markup
+
+(defmacro with-maybe-section (index &rest forms)
+  `(multiple-value-bind (count collected) (progn ,@forms)
+    (when count
+      (dolist (line collected)
+        (write-line line *texinfo-output*))
+      (incf ,index (1- count)))))
+
+(defun write-texinfo-string (string &optional lambda-list)
+  "Try to guess as much formatting for a raw docstring as possible."
+  (let ((*texinfo-variables* (flatten lambda-list))
+        (lines (string-lines (escape-for-texinfo string nil))))
+      (loop for line-number from 0 below (length lines)
+            for line = (svref lines line-number)
+            do (cond
+                 ((with-maybe-section line-number
+                    (and (lisp-section-p line line-number lines)
+                         (collect-lisp-section lines line-number))))
+                 ((with-maybe-section line-number
+                    (and (maybe-itemize-offset line)
+                         (collect-maybe-itemized-section lines line-number))))
+                 ((with-maybe-section line-number
+                    (and (maybe-table-offset line-number lines)
+                         (collect-maybe-table-section lines line-number))))
+                 (t
+                  (write-line (texinfo-line line) *texinfo-output*))))))
+
+;;;; texinfo formatting tools
+
+(defun hide-superclass-p (class-name super-name)
+  (let ((super-package (symbol-package super-name)))
+    (or
+     ;; KLUDGE: We assume that we don't want to advertise internal
+     ;; classes in CP-lists, unless the symbol we're documenting is
+     ;; internal as well.
+     (and (member super-package #.'(mapcar #'find-package *undocumented-packages*))
+          (not (eq super-package (symbol-package class-name))))
+     ;; KLUDGE: We don't generally want to advertise SIMPLE-ERROR or
+     ;; SIMPLE-CONDITION in the CPLs of conditions that inherit them
+     ;; simply as a matter of convenience. The assumption here is that
+     ;; the inheritance is incidental unless the name of the condition
+     ;; begins with SIMPLE-.
+     (and (member super-name '(simple-error simple-condition))
+          (let ((prefix "SIMPLE-"))
+            (mismatch prefix (string class-name) :end2 (length prefix)))
+          t ; don't return number from MISMATCH
+          ))))
+
+(defun hide-slot-p (symbol slot)
+  ;; FIXME: There is no pricipal reason to avoid the slot docs fo
+  ;; structures and conditions, but their DOCUMENTATION T doesn't
+  ;; currently work with them the way we'd like.
+  (not (and (typep (find-class symbol nil) 'standard-class)
+            (docstring slot t))))
+
+(defun texinfo-anchor (doc)
+  (format *texinfo-output* "@anchor{~A}~%" (node-name doc)))
+
+;;; KLUDGE: &AUX *PRINT-PRETTY* here means "no linebreaks please"
+(defun texinfo-begin (doc &aux *print-pretty*)
+  (let ((kind (get-kind doc)))
+    (format *texinfo-output* "@~A {~:(~A~)} ~({~A}~@[ ~{~A~^ ~}~]~)~%"
+            (case kind
+              ((package constant variable)
+               "defvr")
+              ((structure class condition type)
+               "deftp")
+              (t
+               "deffn"))
+            (map 'string (lambda (char) (if (eql char #\-) #\Space char)) (string kind))
+            (title-name doc)
+            ;; &foo would be amusingly bold in the pdf thanks to TeX/Texinfo
+            ;; interactions,so we escape the ampersand -- amusingly for TeX.
+            ;; sbcl.texinfo defines macros that expand @&key and friends to &key.
+            (mapcar (lambda (name)
+                      (if (member name lambda-list-keywords)
+                          (format nil "@~A" name)
+                          name))
+                    (lambda-list doc)))))
+
+(defun texinfo-index (doc)
+  (let ((title (title-name doc)))
+    (case (get-kind doc)
+      ((structure type class condition)
+       (format *texinfo-output* "@tindex ~A~%" title))
+      ((variable constant)
+       (format *texinfo-output* "@vindex ~A~%" title))
+      ((compiler-macro function method-combination macro generic-function)
+       (format *texinfo-output* "@findex ~A~%" title)))))
+
+(defun texinfo-inferred-body (doc)
+  (when (member (get-kind doc) '(class structure condition))
+    (let ((name (get-name doc)))
+      ;; class precedence list
+      (format *texinfo-output* "Class precedence list: @code{~(~{@lw{~A}~^, ~}~)}~%~%"
+              (remove-if (lambda (class)  (hide-superclass-p name class))
+                         (mapcar #'class-name (ensure-class-precedence-list (find-class name)))))
+      ;; slots
+      (let ((slots (remove-if (lambda (slot) (hide-slot-p name slot))
+                              (class-direct-slots (find-class name)))))
+        (when slots
+          (format *texinfo-output* "Slots:~%@itemize~%")
+          (dolist (slot slots)
+            (format *texinfo-output*
+                    "@item ~(@code{~A}~#[~:; --- ~]~
+                      ~:{~2*~@[~2:*~A~P: ~{@code{@w{~S}}~^, ~}~]~:^; ~}~)~%~%"
+                    (slot-definition-name slot)
+                    (remove
+                     nil
+                     (mapcar
+                      (lambda (name things)
+                        (if things
+                            (list name (length things) things)))
+                      '("initarg" "reader"  "writer")
+                      (list
+                       (slot-definition-initargs slot)
+                       (slot-definition-readers slot)
+                       (slot-definition-writers slot)))))
+            ;; FIXME: Would be neater to handler as children
+            (write-texinfo-string (docstring slot t)))
+          (format *texinfo-output* "@end itemize~%~%"))))))
+
+(defun texinfo-body (doc)
+  (write-texinfo-string (get-string doc)))
+
+(defun texinfo-end (doc)
+  (write-line (case (get-kind doc)
+                ((package variable constant) "@end defvr")
+                ((structure type class condition) "@end deftp")
+                (t "@end deffn"))
+              *texinfo-output*))
+
+(defun write-texinfo (doc)
+  "Writes TexInfo for a DOCUMENTATION instance to *TEXINFO-OUTPUT*."
+  (texinfo-anchor doc)
+  (texinfo-begin doc)
+  (texinfo-index doc)
+  (texinfo-inferred-body doc)
+  (texinfo-body doc)
+  (texinfo-end doc)
+  ;; FIXME: Children should be sorted one way or another
+  (mapc #'write-texinfo (get-children doc)))
+
+;;;; main logic
+
+(defun collect-gf-documentation (gf)
+  "Collects method documentation for the generic function GF"
+  (loop for method in (generic-function-methods gf)
+        for doc = (maybe-documentation method t)
+        when doc
+        collect doc))
+
+(defun collect-name-documentation (name)
+  (loop for type in *documentation-types*
+        for doc = (maybe-documentation name type)
+        when doc
+        collect doc))
+
+(defun collect-symbol-documentation (symbol)
+  "Collects all docs for a SYMBOL and (SETF SYMBOL), returns a list of
+the form DOC instances. See `*documentation-types*' for the possible
+values of doc-type."
+  (nconc (collect-name-documentation symbol)
+         (collect-name-documentation (list 'setf symbol))))
+
+(defun collect-documentation (package)
+  "Collects all documentation for all external symbols of the given
+package, as well as for the package itself."
+  (let* ((*documentation-package* (find-package package))
+         (docs nil))
+    (check-type package package)
+    (do-external-symbols (symbol package)
+      (setf docs (nconc (collect-symbol-documentation symbol) docs)))
+    (let ((doc (maybe-documentation *documentation-package* t)))
+      (when doc
+        (push doc docs)))
+    docs))
+
+(defmacro with-texinfo-file (pathname &body forms)
+  `(with-open-file (*texinfo-output* ,pathname
+                                    :direction :output
+                                    :if-does-not-exist :create
+                                    :if-exists :supersede)
+    ,@forms))
+
+(defun write-ifnottex ()
+  ;; We use @&key, etc to escape & from TeX in lambda lists -- so we need to
+  ;; define them for info as well.
+  (flet ((macro (name)
+                 (let ((string (string-downcase name)))
+                   (format *texinfo-output* "@macro ~A~%~A~%@end macro~%" string string))))
+    (macro '&allow-other-keys)
+    (macro '&optional)
+    (macro '&rest)
+    (macro '&key)
+    (macro '&body)))
+
+(defun generate-includes (directory packages &key (base-package :cl-user))
+  "Create files in `directory' containing Texinfo markup of all
+docstrings of each exported symbol in `packages'. `directory' is
+created if necessary. If you supply a namestring that doesn't end in a
+slash, you lose. The generated files are of the form
+\"<doc-type>_<packagename>_<symbol-name>.texinfo\" and can be included
+via @include statements. Texinfo syntax-significant characters are
+escaped in symbol names, but if a docstring contains invalid Texinfo
+markup, you lose."
+  (handler-bind ((warning #'muffle-warning))
+    (let ((directory (merge-pathnames (pathname directory)))
+          (*base-package* (find-package base-package)))
+      (ensure-directories-exist directory)
+      (dolist (package packages)
+        (dolist (doc (collect-documentation (find-package package)))
+          (with-texinfo-file (merge-pathnames (include-pathname doc) directory)
+            (write-texinfo doc))))
+      (with-texinfo-file (merge-pathnames "ifnottex.texinfo" directory)
+        (write-ifnottex))
+      directory)))
+
+(defun document-package (package &optional filename)
+  "Create a file containing all available documentation for the
+exported symbols of `package' in Texinfo format. If `filename' is not
+supplied, a file \"<packagename>.texinfo\" is generated.
+
+The definitions can be referenced using Texinfo statements like
+@ref{<doc-type>_<packagename>_<symbol-name>.texinfo}. Texinfo
+syntax-significant characters are escaped in symbol names, but if a
+docstring contains invalid Texinfo markup, you lose."
+  (handler-bind ((warning #'muffle-warning))
+    (let* ((package (find-package package))
+           (filename (or filename (make-pathname
+                                   :name (string-downcase (short-package-name package))
+                                   :type "texinfo")))
+           (docs (sort (collect-documentation package) #'documentation<)))
+      (with-texinfo-file filename
+        (dolist (doc docs)
+          (write-texinfo doc)))
+      filename)))
diff --git a/features.lisp b/features.lisp
new file mode 100644
index 000000000000..67348dbba43b
--- /dev/null
+++ b/features.lisp
@@ -0,0 +1,14 @@
+(in-package :alexandria)
+
+(defun featurep (feature-expression)
+  "Returns T if the argument matches the state of the *FEATURES*
+list and NIL if it does not. FEATURE-EXPRESSION can be any atom
+or list acceptable to the reader macros #+ and #-."
+  (etypecase feature-expression
+    (symbol (not (null (member feature-expression *features*))))
+    (cons (check-type (first feature-expression) symbol)
+          (eswitch ((first feature-expression) :test 'string=)
+            (:and (every #'featurep (rest feature-expression)))
+            (:or  (some #'featurep (rest feature-expression)))
+            (:not (assert (= 2 (length feature-expression)))
+                  (not (featurep (second feature-expression))))))))
diff --git a/functions.lisp b/functions.lisp
new file mode 100644
index 000000000000..dd83e38b4ebc
--- /dev/null
+++ b/functions.lisp
@@ -0,0 +1,161 @@
+(in-package :alexandria)
+
+;;; To propagate return type and allow the compiler to eliminate the IF when
+;;; it is known if the argument is function or not.
+(declaim (inline ensure-function))
+
+(declaim (ftype (function (t) (values function &optional))
+                ensure-function))
+(defun ensure-function (function-designator)
+  "Returns the function designated by FUNCTION-DESIGNATOR:
+if FUNCTION-DESIGNATOR is a function, it is returned, otherwise
+it must be a function name and its FDEFINITION is returned."
+  (if (functionp function-designator)
+      function-designator
+      (fdefinition function-designator)))
+
+(define-modify-macro ensure-functionf/1 () ensure-function)
+
+(defmacro ensure-functionf (&rest places)
+  "Multiple-place modify macro for ENSURE-FUNCTION: ensures that each of
+PLACES contains a function."
+  `(progn ,@(mapcar (lambda (x) `(ensure-functionf/1 ,x)) places)))
+
+(defun disjoin (predicate &rest more-predicates)
+  "Returns a function that applies each of PREDICATE and MORE-PREDICATE
+functions in turn to its arguments, returning the primary value of the first
+predicate that returns true, without calling the remaining predicates.
+If none of the predicates returns true, NIL is returned."
+  (declare (optimize (speed 3) (safety 1) (debug 1)))
+  (let ((predicate (ensure-function predicate))
+	(more-predicates (mapcar #'ensure-function more-predicates)))
+    (lambda (&rest arguments)
+      (or (apply predicate arguments)
+	  (some (lambda (p)
+		  (declare (type function p))
+		  (apply p arguments))
+		more-predicates)))))
+
+(defun conjoin (predicate &rest more-predicates)
+  "Returns a function that applies each of PREDICATE and MORE-PREDICATE
+functions in turn to its arguments, returning NIL if any of the predicates
+returns false, without calling the remaining predicates. If none of the
+predicates returns false, returns the primary value of the last predicate."
+  (if (null more-predicates)
+      predicate
+      (lambda (&rest arguments)
+	(and (apply predicate arguments)
+	     ;; Cannot simply use CL:EVERY because we want to return the
+	     ;; non-NIL value of the last predicate if all succeed.
+	     (do ((tail (cdr more-predicates) (cdr tail))
+		  (head (car more-predicates) (car tail)))
+		 ((not tail)
+		  (apply head arguments))
+	       (unless (apply head arguments)
+		 (return nil)))))))
+
+
+(defun compose (function &rest more-functions)
+  "Returns a function composed of FUNCTION and MORE-FUNCTIONS that applies its
+arguments to to each in turn, starting from the rightmost of MORE-FUNCTIONS,
+and then calling the next one with the primary value of the last."
+  (declare (optimize (speed 3) (safety 1) (debug 1)))
+  (reduce (lambda (f g)
+	    (let ((f (ensure-function f))
+		  (g (ensure-function g)))
+	      (lambda (&rest arguments)
+		(declare (dynamic-extent arguments))
+		(funcall f (apply g arguments)))))
+          more-functions
+          :initial-value function))
+
+(define-compiler-macro compose (function &rest more-functions)
+  (labels ((compose-1 (funs)
+             (if (cdr funs)
+                 `(funcall ,(car funs) ,(compose-1 (cdr funs)))
+                 `(apply ,(car funs) arguments))))
+    (let* ((args (cons function more-functions))
+           (funs (make-gensym-list (length args) "COMPOSE")))
+      `(let ,(loop for f in funs for arg in args
+		   collect `(,f (ensure-function ,arg)))
+         (declare (optimize (speed 3) (safety 1) (debug 1)))
+         (lambda (&rest arguments)
+           (declare (dynamic-extent arguments))
+           ,(compose-1 funs))))))
+
+(defun multiple-value-compose (function &rest more-functions)
+    "Returns a function composed of FUNCTION and MORE-FUNCTIONS that applies
+its arguments to each in turn, starting from the rightmost of
+MORE-FUNCTIONS, and then calling the next one with all the return values of
+the last."
+  (declare (optimize (speed 3) (safety 1) (debug 1)))
+  (reduce (lambda (f g)
+	    (let ((f (ensure-function f))
+		  (g (ensure-function g)))
+	      (lambda (&rest arguments)
+		(declare (dynamic-extent arguments))
+		(multiple-value-call f (apply g arguments)))))
+          more-functions
+          :initial-value function))
+
+(define-compiler-macro multiple-value-compose (function &rest more-functions)
+  (labels ((compose-1 (funs)
+             (if (cdr funs)
+                 `(multiple-value-call ,(car funs) ,(compose-1 (cdr funs)))
+                 `(apply ,(car funs) arguments))))
+    (let* ((args (cons function more-functions))
+           (funs (make-gensym-list (length args) "MV-COMPOSE")))
+      `(let ,(mapcar #'list funs args)
+         (declare (optimize (speed 3) (safety 1) (debug 1)))
+         (lambda (&rest arguments)
+           (declare (dynamic-extent arguments))
+           ,(compose-1 funs))))))
+
+(declaim (inline curry rcurry))
+
+(defun curry (function &rest arguments)
+  "Returns a function that applies ARGUMENTS and the arguments
+it is called with to FUNCTION."
+  (declare (optimize (speed 3) (safety 1)))
+  (let ((fn (ensure-function function)))
+    (lambda (&rest more)
+      (declare (dynamic-extent more))
+      ;; Using M-V-C we don't need to append the arguments.
+      (multiple-value-call fn (values-list arguments) (values-list more)))))
+
+(define-compiler-macro curry (function &rest arguments)
+  (let ((curries (make-gensym-list (length arguments) "CURRY"))
+        (fun (gensym "FUN")))
+    `(let ((,fun (ensure-function ,function))
+           ,@(mapcar #'list curries arguments))
+       (declare (optimize (speed 3) (safety 1)))
+       (lambda (&rest more)
+         (declare (dynamic-extent more))
+         (apply ,fun ,@curries more)))))
+
+(defun rcurry (function &rest arguments)
+  "Returns a function that applies the arguments it is called
+with and ARGUMENTS to FUNCTION."
+  (declare (optimize (speed 3) (safety 1)))
+  (let ((fn (ensure-function function)))
+    (lambda (&rest more)
+      (declare (dynamic-extent more))
+      (multiple-value-call fn (values-list more) (values-list arguments)))))
+
+(define-compiler-macro rcurry (function &rest arguments)
+  (let ((rcurries (make-gensym-list (length arguments) "RCURRY"))
+        (fun (gensym "FUN")))
+    `(let ((,fun (ensure-function ,function))
+           ,@(mapcar #'list rcurries arguments))
+       (declare (optimize (speed 3) (safety 1)))
+       (lambda (&rest more)
+         (declare (dynamic-extent more))
+         (multiple-value-call ,fun (values-list more) ,@rcurries)))))
+
+(declaim (notinline curry rcurry))
+
+(defmacro named-lambda (name lambda-list &body body)
+  "Expands into a lambda-expression within whose BODY NAME denotes the
+corresponding function."
+  `(labels ((,name ,lambda-list ,@body))
+     #',name))
diff --git a/hash-tables.lisp b/hash-tables.lisp
new file mode 100644
index 000000000000..a9f790220405
--- /dev/null
+++ b/hash-tables.lisp
@@ -0,0 +1,101 @@
+(in-package :alexandria)
+
+(defmacro ensure-gethash (key hash-table &optional default)
+  "Like GETHASH, but if KEY is not found in the HASH-TABLE saves the DEFAULT
+under key before returning it. Secondary return value is true if key was
+already in the table."
+  (once-only (key hash-table)
+    (with-unique-names (value presentp)
+      `(multiple-value-bind (,value ,presentp) (gethash ,key ,hash-table)
+         (if ,presentp
+             (values ,value ,presentp)
+             (values (setf (gethash ,key ,hash-table) ,default) nil))))))
+
+(defun copy-hash-table (table &key key test size
+                                   rehash-size rehash-threshold)
+  "Returns a copy of hash table TABLE, with the same keys and values
+as the TABLE. The copy has the same properties as the original, unless
+overridden by the keyword arguments.
+
+Before each of the original values is set into the new hash-table, KEY
+is invoked on the value. As KEY defaults to CL:IDENTITY, a shallow
+copy is returned by default."
+  (setf key (or key 'identity))
+  (setf test (or test (hash-table-test table)))
+  (setf size (or size (hash-table-size table)))
+  (setf rehash-size (or rehash-size (hash-table-rehash-size table)))
+  (setf rehash-threshold (or rehash-threshold (hash-table-rehash-threshold table)))
+  (let ((copy (make-hash-table :test test :size size
+                               :rehash-size rehash-size
+                               :rehash-threshold rehash-threshold)))
+    (maphash (lambda (k v)
+               (setf (gethash k copy) (funcall key v)))
+             table)
+    copy))
+
+(declaim (inline maphash-keys))
+(defun maphash-keys (function table)
+  "Like MAPHASH, but calls FUNCTION with each key in the hash table TABLE."
+  (maphash (lambda (k v)
+             (declare (ignore v))
+             (funcall function k))
+           table))
+
+(declaim (inline maphash-values))
+(defun maphash-values (function table)
+  "Like MAPHASH, but calls FUNCTION with each value in the hash table TABLE."
+  (maphash (lambda (k v)
+             (declare (ignore k))
+             (funcall function v))
+           table))
+
+(defun hash-table-keys (table)
+  "Returns a list containing the keys of hash table TABLE."
+  (let ((keys nil))
+    (maphash-keys (lambda (k)
+                    (push k keys))
+                  table)
+    keys))
+
+(defun hash-table-values (table)
+  "Returns a list containing the values of hash table TABLE."
+  (let ((values nil))
+    (maphash-values (lambda (v)
+                      (push v values))
+                    table)
+    values))
+
+(defun hash-table-alist (table)
+  "Returns an association list containing the keys and values of hash table
+TABLE."
+  (let ((alist nil))
+    (maphash (lambda (k v)
+               (push (cons k v) alist))
+             table)
+    alist))
+
+(defun hash-table-plist (table)
+  "Returns a property list containing the keys and values of hash table
+TABLE."
+  (let ((plist nil))
+    (maphash (lambda (k v)
+               (setf plist (list* k v plist)))
+             table)
+    plist))
+
+(defun alist-hash-table (alist &rest hash-table-initargs)
+  "Returns a hash table containing the keys and values of the association list
+ALIST. Hash table is initialized using the HASH-TABLE-INITARGS."
+  (let ((table (apply #'make-hash-table hash-table-initargs)))
+    (dolist (cons alist)
+      (ensure-gethash (car cons) table (cdr cons)))
+    table))
+
+(defun plist-hash-table (plist &rest hash-table-initargs)
+  "Returns a hash table containing the keys and values of the property list
+PLIST. Hash table is initialized using the HASH-TABLE-INITARGS."
+  (let ((table (apply #'make-hash-table hash-table-initargs)))
+    (do ((tail plist (cddr tail)))
+        ((not tail))
+      (ensure-gethash (car tail) table (cadr tail)))
+    table))
diff --git a/io.lisp b/io.lisp
new file mode 100644
index 000000000000..28bf5e6d82c7
--- /dev/null
+++ b/io.lisp
@@ -0,0 +1,172 @@
+;; Copyright (c) 2002-2006, Edward Marco Baringer
+;; All rights reserved.
+
+(in-package :alexandria)
+
+(defmacro with-open-file* ((stream filespec &key direction element-type
+                                   if-exists if-does-not-exist external-format)
+                           &body body)
+  "Just like WITH-OPEN-FILE, but NIL values in the keyword arguments mean to use
+the default value specified for OPEN."
+  (once-only (direction element-type if-exists if-does-not-exist external-format)
+    `(with-open-stream
+         (,stream (apply #'open ,filespec
+                         (append
+                          (when ,direction
+                            (list :direction ,direction))
+                          (when ,element-type
+                            (list :element-type ,element-type))
+                          (when ,if-exists
+                            (list :if-exists ,if-exists))
+                          (when ,if-does-not-exist
+                            (list :if-does-not-exist ,if-does-not-exist))
+                          (when ,external-format
+                            (list :external-format ,external-format)))))
+       ,@body)))
+
+(defmacro with-input-from-file ((stream-name file-name &rest args
+                                             &key (direction nil direction-p)
+                                             &allow-other-keys)
+                                &body body)
+  "Evaluate BODY with STREAM-NAME to an input stream on the file
+FILE-NAME. ARGS is sent as is to the call to OPEN except EXTERNAL-FORMAT,
+which is only sent to WITH-OPEN-FILE when it's not NIL."
+  (declare (ignore direction))
+  (when direction-p
+    (error "Can't specify :DIRECTION for WITH-INPUT-FROM-FILE."))
+  `(with-open-file* (,stream-name ,file-name :direction :input ,@args)
+     ,@body))
+
+(defmacro with-output-to-file ((stream-name file-name &rest args
+                                            &key (direction nil direction-p)
+                                            &allow-other-keys)
+			       &body body)
+  "Evaluate BODY with STREAM-NAME to an output stream on the file
+FILE-NAME. ARGS is sent as is to the call to OPEN except EXTERNAL-FORMAT,
+which is only sent to WITH-OPEN-FILE when it's not NIL."
+  (declare (ignore direction))
+  (when direction-p
+    (error "Can't specify :DIRECTION for WITH-OUTPUT-TO-FILE."))
+  `(with-open-file* (,stream-name ,file-name :direction :output ,@args)
+     ,@body))
+
+(defun read-stream-content-into-string (stream &key (buffer-size 4096))
+  "Return the \"content\" of STREAM as a fresh string."
+  (check-type buffer-size positive-integer)
+  (let ((*print-pretty* nil))
+    (with-output-to-string (datum)
+      (let ((buffer (make-array buffer-size :element-type 'character)))
+        (loop
+          :for bytes-read = (read-sequence buffer stream)
+          :do (write-sequence buffer datum :start 0 :end bytes-read)
+          :while (= bytes-read buffer-size))))))
+
+(defun read-file-into-string (pathname &key (buffer-size 4096) external-format)
+  "Return the contents of the file denoted by PATHNAME as a fresh string.
+
+The EXTERNAL-FORMAT parameter will be passed directly to WITH-OPEN-FILE
+unless it's NIL, which means the system default."
+  (with-input-from-file
+      (file-stream pathname :external-format external-format)
+    (read-stream-content-into-string file-stream :buffer-size buffer-size)))
+
+(defun write-string-into-file (string pathname &key (if-exists :error)
+                                                    if-does-not-exist
+                                                    external-format)
+  "Write STRING to PATHNAME.
+
+The EXTERNAL-FORMAT parameter will be passed directly to WITH-OPEN-FILE
+unless it's NIL, which means the system default."
+  (with-output-to-file (file-stream pathname :if-exists if-exists
+                                    :if-does-not-exist if-does-not-exist
+                                    :external-format external-format)
+    (write-sequence string file-stream)))
+
+(defun read-stream-content-into-byte-vector (stream &key ((%length length))
+                                                         (initial-size 4096))
+  "Return \"content\" of STREAM as freshly allocated (unsigned-byte 8) vector."
+  (check-type length (or null non-negative-integer))
+  (check-type initial-size positive-integer)
+  (do ((buffer (make-array (or length initial-size)
+                           :element-type '(unsigned-byte 8)))
+       (offset 0)
+       (offset-wanted 0))
+      ((or (/= offset-wanted offset)
+           (and length (>= offset length)))
+       (if (= offset (length buffer))
+           buffer
+           (subseq buffer 0 offset)))
+    (unless (zerop offset)
+      (let ((new-buffer (make-array (* 2 (length buffer))
+                                    :element-type '(unsigned-byte 8))))
+        (replace new-buffer buffer)
+        (setf buffer new-buffer)))
+    (setf offset-wanted (length buffer)
+          offset (read-sequence buffer stream :start offset))))
+
+(defun read-file-into-byte-vector (pathname)
+  "Read PATHNAME into a freshly allocated (unsigned-byte 8) vector."
+  (with-input-from-file (stream pathname :element-type '(unsigned-byte 8))
+    (read-stream-content-into-byte-vector stream '%length (file-length stream))))
+
+(defun write-byte-vector-into-file (bytes pathname &key (if-exists :error)
+                                                       if-does-not-exist)
+  "Write BYTES to PATHNAME."
+  (check-type bytes (vector (unsigned-byte 8)))
+  (with-output-to-file (stream pathname :if-exists if-exists
+                               :if-does-not-exist if-does-not-exist
+                               :element-type '(unsigned-byte 8))
+    (write-sequence bytes stream)))
+
+(defun copy-file (from to &key (if-to-exists :supersede)
+			       (element-type '(unsigned-byte 8)) finish-output)
+  (with-input-from-file (input from :element-type element-type)
+    (with-output-to-file (output to :element-type element-type
+				    :if-exists if-to-exists)
+      (copy-stream input output
+                   :element-type element-type
+                   :finish-output finish-output))))
+
+(defun copy-stream (input output &key (element-type (stream-element-type input))
+                    (buffer-size 4096)
+                    (buffer (make-array buffer-size :element-type element-type))
+                    (start 0) end
+                    finish-output)
+  "Reads data from INPUT and writes it to OUTPUT. Both INPUT and OUTPUT must
+be streams, they will be passed to READ-SEQUENCE and WRITE-SEQUENCE and must have
+compatible element-types."
+  (check-type start non-negative-integer)
+  (check-type end (or null non-negative-integer))
+  (check-type buffer-size positive-integer)
+  (when (and end
+             (< end start))
+    (error "END is smaller than START in ~S" 'copy-stream))
+  (let ((output-position 0)
+        (input-position 0))
+    (unless (zerop start)
+      ;; FIXME add platform specific optimization to skip seekable streams
+      (loop while (< input-position start)
+            do (let ((n (read-sequence buffer input
+                                       :end (min (length buffer)
+                                                 (- start input-position)))))
+                 (when (zerop n)
+                   (error "~@<Could not read enough bytes from the input to fulfill ~
+                           the :START ~S requirement in ~S.~:@>" 'copy-stream start))
+                 (incf input-position n))))
+    (assert (= input-position start))
+    (loop while (or (null end) (< input-position end))
+          do (let ((n (read-sequence buffer input
+                                     :end (when end
+                                            (min (length buffer)
+                                                 (- end input-position))))))
+               (when (zerop n)
+                 (if end
+                     (error "~@<Could not read enough bytes from the input to fulfill ~
+                          the :END ~S requirement in ~S.~:@>" 'copy-stream end)
+                     (return)))
+               (incf input-position n)
+               (write-sequence buffer output :end n)
+               (incf output-position n)))
+    (when finish-output
+      (finish-output output))
+    output-position))
diff --git a/lists.lisp b/lists.lisp
new file mode 100644
index 000000000000..51286071ebf2
--- /dev/null
+++ b/lists.lisp
@@ -0,0 +1,367 @@
+(in-package :alexandria)
+
+(declaim (inline safe-endp))
+(defun safe-endp (x)
+  (declare (optimize safety))
+  (endp x))
+
+(defun alist-plist (alist)
+  "Returns a property list containing the same keys and values as the
+association list ALIST in the same order."
+  (let (plist)
+    (dolist (pair alist)
+      (push (car pair) plist)
+      (push (cdr pair) plist))
+    (nreverse plist)))
+
+(defun plist-alist (plist)
+  "Returns an association list containing the same keys and values as the
+property list PLIST in the same order."
+  (let (alist)
+    (do ((tail plist (cddr tail)))
+        ((safe-endp tail) (nreverse alist))
+      (push (cons (car tail) (cadr tail)) alist))))
+
+(declaim (inline racons))
+(defun racons (key value ralist)
+  (acons value key ralist))
+
+(macrolet
+    ((define-alist-get (name get-entry get-value-from-entry add doc)
+       `(progn
+          (declaim (inline ,name))
+          (defun ,name (alist key &key (test 'eql))
+            ,doc
+            (let ((entry (,get-entry key alist :test test)))
+              (values (,get-value-from-entry entry) entry)))
+          (define-setf-expander ,name (place key &key (test ''eql)
+                                       &environment env)
+            (multiple-value-bind
+                  (temporary-variables initforms newvals setter getter)
+                (get-setf-expansion place env)
+              (when (cdr newvals)
+                (error "~A cannot store multiple values in one place" ',name))
+              (with-unique-names (new-value key-val test-val alist entry)
+                (values
+                 (append temporary-variables
+                         (list alist
+                               key-val
+                               test-val
+                               entry))
+                 (append initforms
+                         (list getter
+                               key
+                               test
+                               `(,',get-entry ,key-val ,alist :test ,test-val)))
+                 `(,new-value)
+                 `(cond
+                    (,entry
+                     (setf (,',get-value-from-entry ,entry) ,new-value))
+                    (t
+                     (let ,newvals
+                       (setf ,(first newvals) (,',add ,key ,new-value ,alist))
+                       ,setter
+                       ,new-value)))
+                 `(,',get-value-from-entry ,entry))))))))
+ (define-alist-get assoc-value assoc cdr acons
+"ASSOC-VALUE is an alist accessor very much like ASSOC, but it can
+be used with SETF.")
+ (define-alist-get rassoc-value rassoc car racons
+"RASSOC-VALUE is an alist accessor very much like RASSOC, but it can
+be used with SETF."))
+
+(defun malformed-plist (plist)
+  (error "Malformed plist: ~S" plist))
+
+(defmacro doplist ((key val plist &optional values) &body body)
+  "Iterates over elements of PLIST. BODY can be preceded by
+declarations, and is like a TAGBODY. RETURN may be used to terminate
+the iteration early. If RETURN is not used, returns VALUES."
+  (multiple-value-bind (forms declarations) (parse-body body)
+    (with-gensyms (tail loop results)
+      `(block nil
+         (flet ((,results ()
+                  (let (,key ,val)
+                    (declare (ignorable ,key ,val))
+                    (return ,values))))
+           (let* ((,tail ,plist)
+                  (,key (if ,tail
+                            (pop ,tail)
+                            (,results)))
+                 (,val (if ,tail
+                           (pop ,tail)
+                           (malformed-plist ',plist))))
+            (declare (ignorable ,key ,val))
+            ,@declarations
+            (tagbody
+               ,loop
+               ,@forms
+               (setf ,key (if ,tail
+                              (pop ,tail)
+                              (,results))
+                     ,val (if ,tail
+                              (pop ,tail)
+                              (malformed-plist ',plist)))
+               (go ,loop))))))))
+
+(define-modify-macro appendf (&rest lists) append
+  "Modify-macro for APPEND. Appends LISTS to the place designated by the first
+argument.")
+
+(define-modify-macro nconcf (&rest lists) nconc
+  "Modify-macro for NCONC. Concatenates LISTS to place designated by the first
+argument.")
+
+(define-modify-macro unionf (list &rest args) union
+  "Modify-macro for UNION. Saves the union of LIST and the contents of the
+place designated by the first argument to the designated place.")
+
+(define-modify-macro nunionf (list &rest args) nunion
+  "Modify-macro for NUNION. Saves the union of LIST and the contents of the
+place designated by the first argument to the designated place. May modify
+either argument.")
+
+(define-modify-macro reversef () reverse
+  "Modify-macro for REVERSE. Copies and reverses the list stored in the given
+place and saves back the result into the place.")
+
+(define-modify-macro nreversef () nreverse
+  "Modify-macro for NREVERSE. Reverses the list stored in the given place by
+destructively modifying it and saves back the result into the place.")
+
+(defun circular-list (&rest elements)
+  "Creates a circular list of ELEMENTS."
+  (let ((cycle (copy-list elements)))
+    (nconc cycle cycle)))
+
+(defun circular-list-p (object)
+  "Returns true if OBJECT is a circular list, NIL otherwise."
+  (and (listp object)
+       (do ((fast object (cddr fast))
+            (slow (cons (car object) (cdr object)) (cdr slow)))
+           (nil)
+         (unless (and (consp fast) (listp (cdr fast)))
+           (return nil))
+         (when (eq fast slow)
+           (return t)))))
+
+(defun circular-tree-p (object)
+  "Returns true if OBJECT is a circular tree, NIL otherwise."
+  (labels ((circularp (object seen)
+             (and (consp object)
+                  (do ((fast (cons (car object) (cdr object)) (cddr fast))
+                       (slow object (cdr slow)))
+                      (nil)
+                    (when (or (eq fast slow) (member slow seen))
+                      (return-from circular-tree-p t))
+                    (when (or (not (consp fast)) (not (consp (cdr slow))))
+                      (return
+                        (do ((tail object (cdr tail)))
+                            ((not (consp tail))
+                             nil)
+                          (let ((elt (car tail)))
+                            (circularp elt (cons object seen))))))))))
+    (circularp object nil)))
+
+(defun proper-list-p (object)
+  "Returns true if OBJECT is a proper list."
+  (cond ((not object)
+         t)
+        ((consp object)
+         (do ((fast object (cddr fast))
+              (slow (cons (car object) (cdr object)) (cdr slow)))
+             (nil)
+           (unless (and (listp fast) (consp (cdr fast)))
+             (return (and (listp fast) (not (cdr fast)))))
+           (when (eq fast slow)
+             (return nil))))
+        (t
+         nil)))
+
+(deftype proper-list ()
+  "Type designator for proper lists. Implemented as a SATISFIES type, hence
+not recommended for performance intensive use. Main usefullness as a type
+designator of the expected type in a TYPE-ERROR."
+  `(and list (satisfies proper-list-p)))
+
+(defun circular-list-error (list)
+  (error 'type-error
+         :datum list
+         :expected-type '(and list (not circular-list))))
+
+(macrolet ((def (name lambda-list doc step declare ret1 ret2)
+             (assert (member 'list lambda-list))
+             `(defun ,name ,lambda-list
+                ,doc
+                (do ((last list fast)
+                     (fast list (cddr fast))
+                     (slow (cons (car list) (cdr list)) (cdr slow))
+                     ,@(when step (list step)))
+                    (nil)
+                  (declare (dynamic-extent slow) ,@(when declare (list declare))
+                           (ignorable last))
+                  (when (safe-endp fast)
+                    (return ,ret1))
+                  (when (safe-endp (cdr fast))
+                    (return ,ret2))
+                  (when (eq fast slow)
+                    (circular-list-error list))))))
+  (def proper-list-length (list)
+    "Returns length of LIST, signalling an error if it is not a proper list."
+    (n 1 (+ n 2))
+    ;; KLUDGE: Most implementations don't actually support lists with bignum
+    ;; elements -- and this is WAY faster on most implementations then declaring
+    ;; N to be an UNSIGNED-BYTE.
+    (fixnum n)
+    (1- n)
+    n)
+
+  (def lastcar (list)
+      "Returns the last element of LIST. Signals a type-error if LIST is not a
+proper list."
+    nil
+    nil
+    (cadr last)
+    (car fast))
+
+  (def (setf lastcar) (object list)
+      "Sets the last element of LIST. Signals a type-error if LIST is not a proper
+list."
+    nil
+    nil
+    (setf (cadr last) object)
+    (setf (car fast) object)))
+
+(defun make-circular-list (length &key initial-element)
+  "Creates a circular list of LENGTH with the given INITIAL-ELEMENT."
+  (let ((cycle (make-list length :initial-element initial-element)))
+    (nconc cycle cycle)))
+
+(deftype circular-list ()
+  "Type designator for circular lists. Implemented as a SATISFIES type, so not
+recommended for performance intensive use. Main usefullness as the
+expected-type designator of a TYPE-ERROR."
+  `(satisfies circular-list-p))
+
+(defun ensure-car (thing)
+  "If THING is a CONS, its CAR is returned. Otherwise THING is returned."
+  (if (consp thing)
+      (car thing)
+      thing))
+
+(defun ensure-cons (cons)
+  "If CONS is a cons, it is returned. Otherwise returns a fresh cons with CONS
+  in the car, and NIL in the cdr."
+  (if (consp cons)
+      cons
+      (cons cons nil)))
+
+(defun ensure-list (list)
+  "If LIST is a list, it is returned. Otherwise returns the list designated by LIST."
+  (if (listp list)
+      list
+      (list list)))
+
+(defun remove-from-plist (plist &rest keys)
+  "Returns a propery-list with same keys and values as PLIST, except that keys
+in the list designated by KEYS and values corresponding to them are removed.
+The returned property-list may share structure with the PLIST, but PLIST is
+not destructively modified. Keys are compared using EQ."
+  (declare (optimize (speed 3)))
+  ;; FIXME: possible optimization: (remove-from-plist '(:x 0 :a 1 :b 2) :a)
+  ;; could return the tail without consing up a new list.
+  (loop for (key . rest) on plist by #'cddr
+        do (assert rest () "Expected a proper plist, got ~S" plist)
+        unless (member key keys :test #'eq)
+        collect key and collect (first rest)))
+
+(defun delete-from-plist (plist &rest keys)
+  "Just like REMOVE-FROM-PLIST, but this version may destructively modify the
+provided PLIST."
+  (declare (optimize speed))
+  (loop with head = plist
+        with tail = nil   ; a nil tail means an empty result so far
+        for (key . rest) on plist by #'cddr
+        do (assert rest () "Expected a proper plist, got ~S" plist)
+           (if (member key keys :test #'eq)
+               ;; skip over this pair
+               (let ((next (cdr rest)))
+                 (if tail
+                     (setf (cdr tail) next)
+                     (setf head next)))
+               ;; keep this pair
+               (setf tail rest))
+        finally (return head)))
+
+(define-modify-macro remove-from-plistf (&rest keys) remove-from-plist
+                     "Modify macro for REMOVE-FROM-PLIST.")
+(define-modify-macro delete-from-plistf (&rest keys) delete-from-plist
+                     "Modify macro for DELETE-FROM-PLIST.")
+
+(declaim (inline sans))
+(defun sans (plist &rest keys)
+  "Alias of REMOVE-FROM-PLIST for backward compatibility."
+  (apply #'remove-from-plist plist keys))
+
+(defun mappend (function &rest lists)
+  "Applies FUNCTION to respective element(s) of each LIST, appending all the
+all the result list to a single list. FUNCTION must return a list."
+  (loop for results in (apply #'mapcar function lists)
+        append results))
+
+(defun setp (object &key (test #'eql) (key #'identity))
+  "Returns true if OBJECT is a list that denotes a set, NIL otherwise. A list
+denotes a set if each element of the list is unique under KEY and TEST."
+  (and (listp object)
+       (let (seen)
+         (dolist (elt object t)
+           (let ((key (funcall key elt)))
+             (if (member key seen :test test)
+                 (return nil)
+                 (push key seen)))))))
+
+(defun set-equal (list1 list2 &key (test #'eql) (key nil keyp))
+  "Returns true if every element of LIST1 matches some element of LIST2 and
+every element of LIST2 matches some element of LIST1. Otherwise returns false."
+  (let ((keylist1 (if keyp (mapcar key list1) list1))
+        (keylist2 (if keyp (mapcar key list2) list2)))
+    (and (dolist (elt keylist1 t)
+           (or (member elt keylist2 :test test)
+               (return nil)))
+         (dolist (elt keylist2 t)
+           (or (member elt keylist1 :test test)
+               (return nil))))))
+
+(defun map-product (function list &rest more-lists)
+  "Returns a list containing the results of calling FUNCTION with one argument
+from LIST, and one from each of MORE-LISTS for each combination of arguments.
+In other words, returns the product of LIST and MORE-LISTS using FUNCTION.
+
+Example:
+
+ (map-product 'list '(1 2) '(3 4) '(5 6))
+  => ((1 3 5) (1 3 6) (1 4 5) (1 4 6)
+      (2 3 5) (2 3 6) (2 4 5) (2 4 6))
+"
+  (labels ((%map-product (f lists)
+             (let ((more (cdr lists))
+                   (one (car lists)))
+               (if (not more)
+                   (mapcar f one)
+                   (mappend (lambda (x)
+                              (%map-product (curry f x) more))
+                            one)))))
+    (%map-product (ensure-function function) (cons list more-lists))))
+
+(defun flatten (tree)
+  "Traverses the tree in order, collecting non-null leaves into a list."
+  (let (list)
+    (labels ((traverse (subtree)
+               (when subtree
+                 (if (consp subtree)
+                     (progn
+                       (traverse (car subtree))
+                       (traverse (cdr subtree)))
+                     (push subtree list)))))
+      (traverse tree))
+    (nreverse list)))
diff --git a/macros.lisp b/macros.lisp
new file mode 100644
index 000000000000..4364ad63b82a
--- /dev/null
+++ b/macros.lisp
@@ -0,0 +1,370 @@
+(in-package :alexandria)
+
+(defmacro with-gensyms (names &body forms)
+  "Binds a set of variables to gensyms and evaluates the implicit progn FORMS.
+
+Each element within NAMES is either a symbol SYMBOL or a pair (SYMBOL
+STRING-DESIGNATOR). Bare symbols are equivalent to the pair (SYMBOL SYMBOL).
+
+Each pair (SYMBOL STRING-DESIGNATOR) specifies that the variable named by SYMBOL
+should be bound to a symbol constructed using GENSYM with the string designated
+by STRING-DESIGNATOR being its first argument."
+  `(let ,(mapcar (lambda (name)
+                   (multiple-value-bind (symbol string)
+                       (etypecase name
+                         (symbol
+                          (values name (symbol-name name)))
+                         ((cons symbol (cons string-designator null))
+                          (values (first name) (string (second name)))))
+                     `(,symbol (gensym ,string))))
+                 names)
+     ,@forms))
+
+(defmacro with-unique-names (names &body forms)
+  "Alias for WITH-GENSYMS."
+  `(with-gensyms ,names ,@forms))
+
+(defmacro once-only (specs &body forms)
+  "Constructs code whose primary goal is to help automate the handling of
+multiple evaluation within macros. Multiple evaluation is handled by introducing
+intermediate variables, in order to reuse the result of an expression.
+
+The returned value is a list of the form
+
+  (let ((<gensym-1> <expr-1>)
+        ...
+        (<gensym-n> <expr-n>))
+    <res>)
+
+where GENSYM-1, ..., GENSYM-N are the intermediate variables introduced in order
+to evaluate EXPR-1, ..., EXPR-N once, only. RES is code that is the result of
+evaluating the implicit progn FORMS within a special context determined by
+SPECS. RES should make use of (reference) the intermediate variables.
+
+Each element within SPECS is either a symbol SYMBOL or a pair (SYMBOL INITFORM).
+Bare symbols are equivalent to the pair (SYMBOL SYMBOL).
+
+Each pair (SYMBOL INITFORM) specifies a single intermediate variable:
+
+- INITFORM is an expression evaluated to produce EXPR-i
+
+- SYMBOL is the name of the variable that will be bound around FORMS to the
+  corresponding gensym GENSYM-i, in order for FORMS to generate RES that
+  references the intermediate variable
+
+The evaluation of INITFORMs and binding of SYMBOLs resembles LET. INITFORMs of
+all the pairs are evaluated before binding SYMBOLs and evaluating FORMS.
+
+Example:
+
+  The following expression
+
+  (let ((x '(incf y)))
+    (once-only (x)
+      `(cons ,x ,x)))
+
+  ;;; =>
+  ;;; (let ((#1=#:X123 (incf y)))
+  ;;;   (cons #1# #1#))
+
+  could be used within a macro to avoid multiple evaluation like so
+
+  (defmacro cons1 (x)
+    (once-only (x)
+      `(cons ,x ,x)))
+
+  (let ((y 0))
+    (cons1 (incf y)))
+
+  ;;; => (1 . 1)
+
+Example:
+
+  The following expression demonstrates the usage of the INITFORM field
+
+  (let ((expr '(incf y)))
+    (once-only ((var `(1+ ,expr)))
+      `(list ',expr ,var ,var)))
+
+  ;;; =>
+  ;;; (let ((#1=#:VAR123 (1+ (incf y))))
+  ;;;   (list '(incf y) #1# #1))
+
+  which could be used like so
+
+  (defmacro print-succ-twice (expr)
+    (once-only ((var `(1+ ,expr)))
+      `(format t \"Expr: ~s, Once: ~s, Twice: ~s~%\" ',expr ,var ,var)))
+
+  (let ((y 10))
+    (print-succ-twice (incf y)))
+
+  ;;; >>
+  ;;; Expr: (INCF Y), Once: 12, Twice: 12"
+  (let ((gensyms (make-gensym-list (length specs) "ONCE-ONLY"))
+        (names-and-forms (mapcar (lambda (spec)
+                                   (etypecase spec
+                                     (list
+                                      (destructuring-bind (name form) spec
+                                        (cons name form)))
+                                     (symbol
+                                      (cons spec spec))))
+                                 specs)))
+    ;; bind in user-macro
+    `(let ,(mapcar (lambda (g n) (list g `(gensym ,(string (car n)))))
+                   gensyms names-and-forms)
+       ;; bind in final expansion
+       `(let (,,@(mapcar (lambda (g n)
+                           ``(,,g ,,(cdr n)))
+                         gensyms names-and-forms))
+          ;; bind in user-macro
+          ,(let ,(mapcar (lambda (n g) (list (car n) g))
+                         names-and-forms gensyms)
+             ,@forms)))))
+
+(defun parse-body (body &key documentation whole)
+  "Parses BODY into (values remaining-forms declarations doc-string).
+Documentation strings are recognized only if DOCUMENTATION is true.
+Syntax errors in body are signalled and WHOLE is used in the signal
+arguments when given."
+  (let ((doc nil)
+        (decls nil)
+        (current nil))
+    (tagbody
+     :declarations
+       (setf current (car body))
+       (when (and documentation (stringp current) (cdr body))
+         (if doc
+             (error "Too many documentation strings in ~S." (or whole body))
+             (setf doc (pop body)))
+         (go :declarations))
+       (when (and (listp current) (eql (first current) 'declare))
+         (push (pop body) decls)
+         (go :declarations)))
+    (values body (nreverse decls) doc)))
+
+(defun parse-ordinary-lambda-list (lambda-list &key (normalize t)
+                                   allow-specializers
+                                   (normalize-optional normalize)
+                                   (normalize-keyword normalize)
+                                   (normalize-auxilary normalize))
+  "Parses an ordinary lambda-list, returning as multiple values:
+
+1. Required parameters.
+
+2. Optional parameter specifications, normalized into form:
+
+   (name init suppliedp)
+
+3. Name of the rest parameter, or NIL.
+
+4. Keyword parameter specifications, normalized into form:
+
+   ((keyword-name name) init suppliedp)
+
+5. Boolean indicating &ALLOW-OTHER-KEYS presence.
+
+6. &AUX parameter specifications, normalized into form
+
+   (name init).
+
+7. Existence of &KEY in the lambda-list.
+
+Signals a PROGRAM-ERROR is the lambda-list is malformed."
+  (let ((state :required)
+        (allow-other-keys nil)
+        (auxp nil)
+        (required nil)
+        (optional nil)
+        (rest nil)
+        (keys nil)
+        (keyp nil)
+        (aux nil))
+    (labels ((fail (elt)
+               (simple-program-error "Misplaced ~S in ordinary lambda-list:~%  ~S"
+                                     elt lambda-list))
+             (check-variable (elt what &optional (allow-specializers allow-specializers))
+               (unless (and (or (symbolp elt)
+                                (and allow-specializers
+                                     (consp elt) (= 2 (length elt)) (symbolp (first elt))))
+                            (not (constantp elt)))
+                 (simple-program-error "Invalid ~A ~S in ordinary lambda-list:~%  ~S"
+                                       what elt lambda-list)))
+             (check-spec (spec what)
+               (destructuring-bind (init suppliedp) spec
+                 (declare (ignore init))
+                 (check-variable suppliedp what nil))))
+      (dolist (elt lambda-list)
+        (case elt
+          (&optional
+           (if (eq state :required)
+               (setf state elt)
+               (fail elt)))
+          (&rest
+           (if (member state '(:required &optional))
+               (setf state elt)
+               (fail elt)))
+          (&key
+           (if (member state '(:required &optional :after-rest))
+               (setf state elt)
+               (fail elt))
+           (setf keyp t))
+          (&allow-other-keys
+           (if (eq state '&key)
+               (setf allow-other-keys t
+                     state elt)
+               (fail elt)))
+          (&aux
+           (cond ((eq state '&rest)
+                  (fail elt))
+                 (auxp
+                  (simple-program-error "Multiple ~S in ordinary lambda-list:~%  ~S"
+                                        elt lambda-list))
+                 (t
+                  (setf auxp t
+                        state elt))
+                 ))
+          (otherwise
+           (when (member elt '#.(set-difference lambda-list-keywords
+                                                '(&optional &rest &key &allow-other-keys &aux)))
+             (simple-program-error
+              "Bad lambda-list keyword ~S in ordinary lambda-list:~%  ~S"
+              elt lambda-list))
+           (case state
+             (:required
+              (check-variable elt "required parameter")
+              (push elt required))
+             (&optional
+              (cond ((consp elt)
+                     (destructuring-bind (name &rest tail) elt
+                       (check-variable name "optional parameter")
+                       (cond ((cdr tail)
+                              (check-spec tail "optional-supplied-p parameter"))
+                             ((and normalize-optional tail)
+                              (setf elt (append elt '(nil))))
+                             (normalize-optional
+                              (setf elt (append elt '(nil nil)))))))
+                    (t
+                     (check-variable elt "optional parameter")
+                     (when normalize-optional
+                       (setf elt (cons elt '(nil nil))))))
+              (push (ensure-list elt) optional))
+             (&rest
+              (check-variable elt "rest parameter")
+              (setf rest elt
+                    state :after-rest))
+             (&key
+              (cond ((consp elt)
+                     (destructuring-bind (var-or-kv &rest tail) elt
+                       (cond ((consp var-or-kv)
+                              (destructuring-bind (keyword var) var-or-kv
+                                (unless (symbolp keyword)
+                                  (simple-program-error "Invalid keyword name ~S in ordinary ~
+                                                         lambda-list:~%  ~S"
+                                                        keyword lambda-list))
+                                (check-variable var "keyword parameter")))
+                             (t
+                              (check-variable var-or-kv "keyword parameter")
+                              (when normalize-keyword
+                                (setf var-or-kv (list (make-keyword var-or-kv) var-or-kv)))))
+                       (cond ((cdr tail)
+                              (check-spec tail "keyword-supplied-p parameter"))
+                             ((and normalize-keyword tail)
+                              (setf tail (append tail '(nil))))
+                             (normalize-keyword
+                              (setf tail '(nil nil))))
+                       (setf elt (cons var-or-kv tail))))
+                    (t
+                     (check-variable elt "keyword parameter")
+                     (setf elt (if normalize-keyword
+                                   (list (list (make-keyword elt) elt) nil nil)
+                                   elt))))
+              (push elt keys))
+             (&aux
+              (if (consp elt)
+                  (destructuring-bind (var &optional init) elt
+                    (declare (ignore init))
+                    (check-variable var "&aux parameter"))
+                  (progn
+                    (check-variable elt "&aux parameter")
+                    (setf elt (list* elt (when normalize-auxilary
+                                           '(nil))))))
+              (push elt aux))
+             (t
+              (simple-program-error "Invalid ordinary lambda-list:~%  ~S" lambda-list)))))))
+    (values (nreverse required) (nreverse optional) rest (nreverse keys)
+            allow-other-keys (nreverse aux) keyp)))
+
+;;;; DESTRUCTURING-*CASE
+
+(defun expand-destructuring-case (key clauses case)
+  (once-only (key)
+    `(if (typep ,key 'cons)
+         (,case (car ,key)
+           ,@(mapcar (lambda (clause)
+                       (destructuring-bind ((keys . lambda-list) &body body) clause
+                         `(,keys
+                           (destructuring-bind ,lambda-list (cdr ,key)
+                             ,@body))))
+                     clauses))
+         (error "Invalid key to DESTRUCTURING-~S: ~S" ',case ,key))))
+
+(defmacro destructuring-case (keyform &body clauses)
+  "DESTRUCTURING-CASE, -CCASE, and -ECASE are a combination of CASE and DESTRUCTURING-BIND.
+KEYFORM must evaluate to a CONS.
+
+Clauses are of the form:
+
+  ((CASE-KEYS . DESTRUCTURING-LAMBDA-LIST) FORM*)
+
+The clause whose CASE-KEYS matches CAR of KEY, as if by CASE, CCASE, or ECASE,
+is selected, and FORMs are then executed with CDR of KEY is destructured and
+bound by the DESTRUCTURING-LAMBDA-LIST.
+
+Example:
+
+ (defun dcase (x)
+   (destructuring-case x
+     ((:foo a b)
+      (format nil \"foo: ~S, ~S\" a b))
+     ((:bar &key a b)
+      (format nil \"bar: ~S, ~S\" a b))
+     (((:alt1 :alt2) a)
+      (format nil \"alt: ~S\" a))
+     ((t &rest rest)
+      (format nil \"unknown: ~S\" rest))))
+
+  (dcase (list :foo 1 2))        ; => \"foo: 1, 2\"
+  (dcase (list :bar :a 1 :b 2))  ; => \"bar: 1, 2\"
+  (dcase (list :alt1 1))         ; => \"alt: 1\"
+  (dcase (list :alt2 2))         ; => \"alt: 2\"
+  (dcase (list :quux 1 2 3))     ; => \"unknown: 1, 2, 3\"
+
+ (defun decase (x)
+   (destructuring-case x
+     ((:foo a b)
+      (format nil \"foo: ~S, ~S\" a b))
+     ((:bar &key a b)
+      (format nil \"bar: ~S, ~S\" a b))
+     (((:alt1 :alt2) a)
+      (format nil \"alt: ~S\" a))))
+
+  (decase (list :foo 1 2))        ; => \"foo: 1, 2\"
+  (decase (list :bar :a 1 :b 2))  ; => \"bar: 1, 2\"
+  (decase (list :alt1 1))         ; => \"alt: 1\"
+  (decase (list :alt2 2))         ; => \"alt: 2\"
+  (decase (list :quux 1 2 3))     ; =| error
+"
+  (expand-destructuring-case keyform clauses 'case))
+
+(defmacro destructuring-ccase (keyform &body clauses)
+  (expand-destructuring-case keyform clauses 'ccase))
+
+(defmacro destructuring-ecase (keyform &body clauses)
+  (expand-destructuring-case keyform clauses 'ecase))
+
+(dolist (name '(destructuring-ccase destructuring-ecase))
+  (setf (documentation name 'function) (documentation 'destructuring-case 'function)))
+
+
+
diff --git a/numbers.lisp b/numbers.lisp
new file mode 100644
index 000000000000..1c06f71d508f
--- /dev/null
+++ b/numbers.lisp
@@ -0,0 +1,295 @@
+(in-package :alexandria)
+
+(declaim (inline clamp))
+(defun clamp (number min max)
+  "Clamps the NUMBER into [min, max] range. Returns MIN if NUMBER is lesser then
+MIN and MAX if NUMBER is greater then MAX, otherwise returns NUMBER."
+  (if (< number min)
+      min
+      (if (> number max)
+          max
+          number)))
+
+(defun gaussian-random (&optional min max)
+  "Returns two gaussian random double floats as the primary and secondary value,
+optionally constrained by MIN and MAX. Gaussian random numbers form a standard
+normal distribution around 0.0d0.
+
+Sufficiently positive MIN or negative MAX will cause the algorithm used to
+take a very long time. If MIN is positive it should be close to zero, and
+similarly if MAX is negative it should be close to zero."
+  (macrolet
+      ((valid (x)
+         `(<= (or min ,x) ,x (or max ,x)) ))
+    (labels
+        ((gauss ()
+           (loop
+                 for x1 = (- (random 2.0d0) 1.0d0)
+                 for x2 = (- (random 2.0d0) 1.0d0)
+                 for w = (+ (expt x1 2) (expt x2 2))
+                 when (< w 1.0d0)
+                 do (let ((v (sqrt (/ (* -2.0d0 (log w)) w))))
+                      (return (values (* x1 v) (* x2 v))))))
+         (guard (x)
+           (unless (valid x)
+             (tagbody
+              :retry
+                (multiple-value-bind (x1 x2) (gauss)
+                  (when (valid x1)
+                    (setf x x1)
+                    (go :done))
+                  (when (valid x2)
+                    (setf x x2)
+                    (go :done))
+                  (go :retry))
+              :done))
+           x))
+      (multiple-value-bind
+            (g1 g2) (gauss)
+        (values (guard g1) (guard g2))))))
+
+(declaim (inline iota))
+(defun iota (n &key (start 0) (step 1))
+  "Return a list of n numbers, starting from START (with numeric contagion
+from STEP applied), each consequtive number being the sum of the previous one
+and STEP. START defaults to 0 and STEP to 1.
+
+Examples:
+
+  (iota 4)                      => (0 1 2 3)
+  (iota 3 :start 1 :step 1.0)   => (1.0 2.0 3.0)
+  (iota 3 :start -1 :step -1/2) => (-1 -3/2 -2)
+"
+  (declare (type (integer 0) n) (number start step))
+  (loop ;; KLUDGE: get numeric contagion right for the first element too
+        for i = (+ (- (+ start step) step)) then (+ i step)
+        repeat n
+        collect i))
+
+(declaim (inline map-iota))
+(defun map-iota (function n &key (start 0) (step 1))
+  "Calls FUNCTION with N numbers, starting from START (with numeric contagion
+from STEP applied), each consequtive number being the sum of the previous one
+and STEP. START defaults to 0 and STEP to 1. Returns N.
+
+Examples:
+
+  (map-iota #'print 3 :start 1 :step 1.0) => 3
+    ;;; 1.0
+    ;;; 2.0
+    ;;; 3.0
+"
+  (declare (type (integer 0) n) (number start step))
+  (loop ;; KLUDGE: get numeric contagion right for the first element too
+        for i = (+ start (- step step)) then (+ i step)
+        repeat n
+        do (funcall function i))
+  n)
+
+(declaim (inline lerp))
+(defun lerp (v a b)
+  "Returns the result of linear interpolation between A and B, using the
+interpolation coefficient V."
+  ;; The correct version is numerically stable, at the expense of an
+  ;; extra multiply. See (lerp 0.1 4 25) with (+ a (* v (- b a))). The
+  ;; unstable version can often be converted to a fast instruction on
+  ;; a lot of machines, though this is machine/implementation
+  ;; specific. As alexandria is more about correct code, than
+  ;; efficiency, and we're only talking about a single extra multiply,
+  ;; many would prefer the stable version
+  (+ (* (- 1.0 v) a) (* v b)))
+
+(declaim (inline mean))
+(defun mean (sample)
+  "Returns the mean of SAMPLE. SAMPLE must be a sequence of numbers."
+  (/ (reduce #'+ sample) (length sample)))
+
+(defun median (sample)
+  "Returns median of SAMPLE. SAMPLE must be a sequence of real numbers."
+  ;; Implements and uses the quick-select algorithm to find the median
+  ;; https://en.wikipedia.org/wiki/Quickselect
+
+  (labels ((randint-in-range (start-int end-int)
+             "Returns a random integer in the specified range, inclusive"
+             (+ start-int (random (1+ (- end-int start-int)))))
+           (partition (vec start-i end-i)
+             "Implements the partition function, which performs a partial
+              sort of vec around the (randomly) chosen pivot.
+              Returns the index where the pivot element would be located
+              in a correctly-sorted array"
+             (if (= start-i end-i)
+                 start-i
+                 (let ((pivot-i (randint-in-range start-i end-i)))
+                   (rotatef (aref vec start-i) (aref vec pivot-i))
+                   (let ((swap-i end-i))
+                     (loop for i from swap-i downto (1+ start-i) do
+                       (when (>= (aref vec i) (aref vec start-i))
+                         (rotatef (aref vec i) (aref vec swap-i))
+                         (decf swap-i)))
+                     (rotatef (aref vec swap-i) (aref vec start-i))
+                     swap-i)))))
+
+    (let* ((vector (copy-sequence 'vector sample))
+           (len (length vector))
+           (mid-i (ash len -1))
+           (i 0)
+           (j (1- len)))
+
+      (loop for correct-pos = (partition vector i j)
+            while (/= correct-pos mid-i) do
+              (if (< correct-pos mid-i)
+                  (setf i (1+ correct-pos))
+                  (setf j (1- correct-pos))))
+
+      (if (oddp len)
+          (aref vector mid-i)
+          (* 1/2
+             (+ (aref vector mid-i)
+                (reduce #'max (make-array
+                               mid-i
+                               :displaced-to vector))))))))
+
+(declaim (inline variance))
+(defun variance (sample &key (biased t))
+  "Variance of SAMPLE. Returns the biased variance if BIASED is true (the default),
+and the unbiased estimator of variance if BIASED is false. SAMPLE must be a
+sequence of numbers."
+  (let ((mean (mean sample)))
+    (/ (reduce (lambda (a b)
+                 (+ a (expt (- b mean) 2)))
+               sample
+               :initial-value 0)
+       (- (length sample) (if biased 0 1)))))
+
+(declaim (inline standard-deviation))
+(defun standard-deviation (sample &key (biased t))
+  "Standard deviation of SAMPLE. Returns the biased standard deviation if
+BIASED is true (the default), and the square root of the unbiased estimator
+for variance if BIASED is false (which is not the same as the unbiased
+estimator for standard deviation). SAMPLE must be a sequence of numbers."
+  (sqrt (variance sample :biased biased)))
+
+(define-modify-macro maxf (&rest numbers) max
+  "Modify-macro for MAX. Sets place designated by the first argument to the
+maximum of its original value and NUMBERS.")
+
+(define-modify-macro minf (&rest numbers) min
+  "Modify-macro for MIN. Sets place designated by the first argument to the
+minimum of its original value and NUMBERS.")
+
+;;;; Factorial
+
+;;; KLUDGE: This is really dependant on the numbers in question: for
+;;; small numbers this is larger, and vice versa. Ideally instead of a
+;;; constant we would have RANGE-FAST-TO-MULTIPLY-DIRECTLY-P.
+(defconstant +factorial-bisection-range-limit+ 8)
+
+;;; KLUDGE: This is really platform dependant: ideally we would use
+;;; (load-time-value (find-good-direct-multiplication-limit)) instead.
+(defconstant +factorial-direct-multiplication-limit+ 13)
+
+(defun %multiply-range (i j)
+  ;; We use a a bit of cleverness here:
+  ;;
+  ;; 1. For large factorials we bisect in order to avoid expensive bignum
+  ;;    multiplications: 1 x 2 x 3 x ... runs into bignums pretty soon,
+  ;;    and once it does that all further multiplications will be with bignums.
+  ;;
+  ;;    By instead doing the multiplication in a tree like
+  ;;       ((1 x 2) x (3 x 4)) x ((5 x 6) x (7 x 8))
+  ;;    we manage to get less bignums.
+  ;;
+  ;; 2. Division isn't exactly free either, however, so we don't bisect
+  ;;    all the way down, but multiply ranges of integers close to each
+  ;;    other directly.
+  ;;
+  ;; For even better results it should be possible to use prime
+  ;; factorization magic, but Nikodemus ran out of steam.
+  ;;
+  ;; KLUDGE: We support factorials of bignums, but it seems quite
+  ;; unlikely anyone would ever be able to use them on a modern lisp,
+  ;; since the resulting numbers are unlikely to fit in memory... but
+  ;; it would be extremely unelegant to define FACTORIAL only on
+  ;; fixnums, _and_ on lisps with 16 bit fixnums this can actually be
+  ;; needed.
+  (labels ((bisect (j k)
+             (declare (type (integer 1 #.most-positive-fixnum) j k))
+             (if (< (- k j) +factorial-bisection-range-limit+)
+                 (multiply-range j k)
+                 (let ((middle (+ j (truncate (- k j) 2))))
+                   (* (bisect j middle)
+                      (bisect (+ middle 1) k)))))
+           (bisect-big (j k)
+             (declare (type (integer 1) j k))
+             (if (= j k)
+                 j
+                 (let ((middle (+ j (truncate (- k j) 2))))
+                   (* (if (<= middle most-positive-fixnum)
+                          (bisect j middle)
+                          (bisect-big j middle))
+                      (bisect-big (+ middle 1) k)))))
+           (multiply-range (j k)
+             (declare (type (integer 1 #.most-positive-fixnum) j k))
+             (do ((f k (* f m))
+                  (m (1- k) (1- m)))
+                 ((< m j) f)
+               (declare (type (integer 0 (#.most-positive-fixnum)) m)
+                        (type unsigned-byte f)))))
+    (if (and (typep i 'fixnum) (typep j 'fixnum))
+        (bisect i j)
+        (bisect-big i j))))
+
+(declaim (inline factorial))
+(defun %factorial (n)
+  (if (< n 2)
+      1
+      (%multiply-range 1 n)))
+
+(defun factorial (n)
+  "Factorial of non-negative integer N."
+  (check-type n (integer 0))
+  (%factorial n))
+
+;;;; Combinatorics
+
+(defun binomial-coefficient (n k)
+  "Binomial coefficient of N and K, also expressed as N choose K. This is the
+number of K element combinations given N choises. N must be equal to or
+greater then K."
+  (check-type n (integer 0))
+  (check-type k (integer 0))
+  (assert (>= n k))
+  (if (or (zerop k) (= n k))
+      1
+      (let ((n-k (- n k)))
+        ;; Swaps K and N-K if K < N-K because the algorithm
+        ;; below is faster for bigger K and smaller N-K
+        (when (< k n-k)
+          (rotatef k n-k))
+        (if (= 1 n-k)
+            n
+            ;; General case, avoid computing the 1x...xK twice:
+            ;;
+            ;;    N!           1x...xN          (K+1)x...xN
+            ;; --------  =  ---------------- =  ------------, N>1
+            ;; K!(N-K)!     1x...xK x (N-K)!       (N-K)!
+            (/ (%multiply-range (+ k 1) n)
+               (%factorial n-k))))))
+
+(defun subfactorial (n)
+  "Subfactorial of the non-negative integer N."
+  (check-type n (integer 0))
+  (if (zerop n)
+      1
+      (do ((x 1 (1+ x))
+           (a 0 (* x (+ a b)))
+           (b 1 a))
+          ((= n x) a))))
+
+(defun count-permutations (n &optional (k n))
+  "Number of K element permutations for a sequence of N objects.
+K defaults to N"
+  (check-type n (integer 0))
+  (check-type k (integer 0))
+  (assert (>= n k))
+  (%multiply-range (1+ (- n k)) n))
diff --git a/package.lisp b/package.lisp
new file mode 100644
index 000000000000..f9d2014cd7b5
--- /dev/null
+++ b/package.lisp
@@ -0,0 +1,243 @@
+(defpackage :alexandria.1.0.0
+  (:nicknames :alexandria)
+  (:use :cl)
+  #+sb-package-locks
+  (:lock t)
+  (:export
+   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+   ;; BLESSED
+   ;;
+   ;; Binding constructs
+   #:if-let
+   #:when-let
+   #:when-let*
+   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+   ;; REVIEW IN PROGRESS
+   ;;
+   ;; Control flow
+   ;;
+   ;; -- no clear consensus yet --
+   #:cswitch
+   #:eswitch
+   #:switch
+   ;; -- problem free? --
+   #:multiple-value-prog2
+   #:nth-value-or
+   #:whichever
+   #:xor
+   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+   ;; REVIEW PENDING
+   ;;
+   ;; Definitions
+   #:define-constant
+   ;; Hash tables
+   #:alist-hash-table
+   #:copy-hash-table
+   #:ensure-gethash
+   #:hash-table-alist
+   #:hash-table-keys
+   #:hash-table-plist
+   #:hash-table-values
+   #:maphash-keys
+   #:maphash-values
+   #:plist-hash-table
+   ;; Functions
+   #:compose
+   #:conjoin
+   #:curry
+   #:disjoin
+   #:ensure-function
+   #:ensure-functionf
+   #:multiple-value-compose
+   #:named-lambda
+   #:rcurry
+   ;; Lists
+   #:alist-plist
+   #:appendf
+   #:nconcf
+   #:reversef
+   #:nreversef
+   #:circular-list
+   #:circular-list-p
+   #:circular-tree-p
+   #:doplist
+   #:ensure-car
+   #:ensure-cons
+   #:ensure-list
+   #:flatten
+   #:lastcar
+   #:make-circular-list
+   #:map-product
+   #:mappend
+   #:nunionf
+   #:plist-alist
+   #:proper-list
+   #:proper-list-length
+   #:proper-list-p
+   #:remove-from-plist
+   #:remove-from-plistf
+   #:delete-from-plist
+   #:delete-from-plistf
+   #:set-equal
+   #:setp
+   #:unionf
+   ;; Numbers
+   #:binomial-coefficient
+   #:clamp
+   #:count-permutations
+   #:factorial
+   #:gaussian-random
+   #:iota
+   #:lerp
+   #:map-iota
+   #:maxf
+   #:mean
+   #:median
+   #:minf
+   #:standard-deviation
+   #:subfactorial
+   #:variance
+   ;; Arrays
+   #:array-index
+   #:array-length
+   #:copy-array
+   ;; Sequences
+   #:copy-sequence
+   #:deletef
+   #:emptyp
+   #:ends-with
+   #:ends-with-subseq
+   #:extremum
+   #:first-elt
+   #:last-elt
+   #:length=
+   #:map-combinations
+   #:map-derangements
+   #:map-permutations
+   #:proper-sequence
+   #:random-elt
+   #:removef
+   #:rotate
+   #:sequence-of-length-p
+   #:shuffle
+   #:starts-with
+   #:starts-with-subseq
+   ;; Macros
+   #:once-only
+   #:parse-body
+   #:parse-ordinary-lambda-list
+   #:with-gensyms
+   #:with-unique-names
+   ;; Symbols
+   #:ensure-symbol
+   #:format-symbol
+   #:make-gensym
+   #:make-gensym-list
+   #:make-keyword
+   ;; Strings
+   #:string-designator
+   ;; Types
+   #:negative-double-float
+   #:negative-fixnum-p
+   #:negative-float
+   #:negative-float-p
+   #:negative-long-float
+   #:negative-long-float-p
+   #:negative-rational
+   #:negative-rational-p
+   #:negative-real
+   #:negative-single-float-p
+   #:non-negative-double-float
+   #:non-negative-double-float-p
+   #:non-negative-fixnum
+   #:non-negative-fixnum-p
+   #:non-negative-float
+   #:non-negative-float-p
+   #:non-negative-integer-p
+   #:non-negative-long-float
+   #:non-negative-rational
+   #:non-negative-real-p
+   #:non-negative-short-float-p
+   #:non-negative-single-float
+   #:non-negative-single-float-p
+   #:non-positive-double-float
+   #:non-positive-double-float-p
+   #:non-positive-fixnum
+   #:non-positive-fixnum-p
+   #:non-positive-float
+   #:non-positive-float-p
+   #:non-positive-integer
+   #:non-positive-rational
+   #:non-positive-real
+   #:non-positive-real-p
+   #:non-positive-short-float
+   #:non-positive-short-float-p
+   #:non-positive-single-float-p
+   #:positive-double-float
+   #:positive-double-float-p
+   #:positive-fixnum
+   #:positive-fixnum-p
+   #:positive-float
+   #:positive-float-p
+   #:positive-integer
+   #:positive-rational
+   #:positive-real
+   #:positive-real-p
+   #:positive-short-float
+   #:positive-short-float-p
+   #:positive-single-float
+   #:positive-single-float-p
+   #:coercef
+   #:negative-double-float-p
+   #:negative-fixnum
+   #:negative-integer
+   #:negative-integer-p
+   #:negative-real-p
+   #:negative-short-float
+   #:negative-short-float-p
+   #:negative-single-float
+   #:non-negative-integer
+   #:non-negative-long-float-p
+   #:non-negative-rational-p
+   #:non-negative-real
+   #:non-negative-short-float
+   #:non-positive-integer-p
+   #:non-positive-long-float
+   #:non-positive-long-float-p
+   #:non-positive-rational-p
+   #:non-positive-single-float
+   #:of-type
+   #:positive-integer-p
+   #:positive-long-float
+   #:positive-long-float-p
+   #:positive-rational-p
+   #:type=
+   ;; Conditions
+   #:required-argument
+   #:ignore-some-conditions
+   #:simple-style-warning
+   #:simple-reader-error
+   #:simple-parse-error
+   #:simple-program-error
+   #:unwind-protect-case
+   ;; Features
+   #:featurep
+   ;; io
+   #:with-input-from-file
+   #:with-output-to-file
+   #:read-stream-content-into-string
+   #:read-file-into-string
+   #:write-string-into-file
+   #:read-stream-content-into-byte-vector
+   #:read-file-into-byte-vector
+   #:write-byte-vector-into-file
+   #:copy-stream
+   #:copy-file
+   ;; new additions collected at the end (subject to removal or further changes)
+   #:symbolicate
+   #:assoc-value
+   #:rassoc-value
+   #:destructuring-case
+   #:destructuring-ccase
+   #:destructuring-ecase
+   ))
diff --git a/sequences.lisp b/sequences.lisp
new file mode 100644
index 000000000000..21464f537610
--- /dev/null
+++ b/sequences.lisp
@@ -0,0 +1,555 @@
+(in-package :alexandria)
+
+;; Make these inlinable by declaiming them INLINE here and some of them
+;; NOTINLINE at the end of the file. Exclude functions that have a compiler
+;; macro, because NOTINLINE is required to prevent compiler-macro expansion.
+(declaim (inline copy-sequence sequence-of-length-p))
+
+(defun sequence-of-length-p (sequence length)
+  "Return true if SEQUENCE is a sequence of length LENGTH. Signals an error if
+SEQUENCE is not a sequence. Returns FALSE for circular lists."
+  (declare (type array-index length)
+           #-lispworks (inline length)
+           (optimize speed))
+  (etypecase sequence
+    (null
+     (zerop length))
+    (cons
+     (let ((n (1- length)))
+       (unless (minusp n)
+         (let ((tail (nthcdr n sequence)))
+           (and tail
+                (null (cdr tail)))))))
+    (vector
+     (= length (length sequence)))
+    (sequence
+     (= length (length sequence)))))
+
+(defun rotate-tail-to-head (sequence n)
+  (declare (type (integer 1) n))
+  (if (listp sequence)
+      (let ((m (mod n (proper-list-length sequence))))
+        (if (null (cdr sequence))
+            sequence
+            (let* ((tail (last sequence (+ m 1)))
+                   (last (cdr tail)))
+              (setf (cdr tail) nil)
+              (nconc last sequence))))
+      (let* ((len (length sequence))
+             (m (mod n len))
+             (tail (subseq sequence (- len m))))
+        (replace sequence sequence :start1 m :start2 0)
+        (replace sequence tail)
+        sequence)))
+
+(defun rotate-head-to-tail (sequence n)
+  (declare (type (integer 1) n))
+  (if (listp sequence)
+      (let ((m (mod (1- n) (proper-list-length sequence))))
+        (if (null (cdr sequence))
+            sequence
+            (let* ((headtail (nthcdr m sequence))
+                   (tail (cdr headtail)))
+              (setf (cdr headtail) nil)
+              (nconc tail sequence))))
+      (let* ((len (length sequence))
+             (m (mod n len))
+             (head (subseq sequence 0 m)))
+        (replace sequence sequence :start1 0 :start2 m)
+        (replace sequence head :start1 (- len m))
+        sequence)))
+
+(defun rotate (sequence &optional (n 1))
+  "Returns a sequence of the same type as SEQUENCE, with the elements of
+SEQUENCE rotated by N: N elements are moved from the end of the sequence to
+the front if N is positive, and -N elements moved from the front to the end if
+N is negative. SEQUENCE must be a proper sequence. N must be an integer,
+defaulting to 1.
+
+If absolute value of N is greater then the length of the sequence, the results
+are identical to calling ROTATE with
+
+  (* (signum n) (mod n (length sequence))).
+
+Note: the original sequence may be destructively altered, and result sequence may
+share structure with it."
+  (if (plusp n)
+      (rotate-tail-to-head sequence n)
+      (if (minusp n)
+          (rotate-head-to-tail sequence (- n))
+          sequence)))
+
+(defun shuffle (sequence &key (start 0) end)
+  "Returns a random permutation of SEQUENCE bounded by START and END.
+Original sequence may be destructively modified, and (if it contains
+CONS or lists themselv) share storage with the original one.
+Signals an error if SEQUENCE is not a proper sequence."
+  (declare (type fixnum start)
+           (type (or fixnum null) end))
+  (etypecase sequence
+    (list
+     (let* ((end (or end (proper-list-length sequence)))
+            (n (- end start)))
+       (do ((tail (nthcdr start sequence) (cdr tail)))
+           ((zerop n))
+         (rotatef (car tail) (car (nthcdr (random n) tail)))
+         (decf n))))
+    (vector
+     (let ((end (or end (length sequence))))
+       (loop for i from start below end
+             do (rotatef (aref sequence i)
+                         (aref sequence (+ i (random (- end i))))))))
+    (sequence
+     (let ((end (or end (length sequence))))
+       (loop for i from (- end 1) downto start
+             do (rotatef (elt sequence i)
+                         (elt sequence (+ i (random (- end i)))))))))
+  sequence)
+
+(defun random-elt (sequence &key (start 0) end)
+  "Returns a random element from SEQUENCE bounded by START and END. Signals an
+error if the SEQUENCE is not a proper non-empty sequence, or if END and START
+are not proper bounding index designators for SEQUENCE."
+  (declare (sequence sequence) (fixnum start) (type (or fixnum null) end))
+  (let* ((size (if (listp sequence)
+                   (proper-list-length sequence)
+                   (length sequence)))
+         (end2 (or end size)))
+    (cond ((zerop size)
+           (error 'type-error
+                  :datum sequence
+                  :expected-type `(and sequence (not (satisfies emptyp)))))
+          ((not (and (<= 0 start) (< start end2) (<= end2 size)))
+           (error 'simple-type-error
+                  :datum (cons start end)
+                  :expected-type `(cons (integer 0 (,end2))
+                                        (or null (integer (,start) ,size)))
+                  :format-control "~@<~S and ~S are not valid bounding index designators for ~
+                                   a sequence of length ~S.~:@>"
+                  :format-arguments (list start end size)))
+          (t
+           (let ((index (+ start (random (- end2 start)))))
+             (elt sequence index))))))
+
+(declaim (inline remove/swapped-arguments))
+(defun remove/swapped-arguments (sequence item &rest keyword-arguments)
+  (apply #'remove item sequence keyword-arguments))
+
+(define-modify-macro removef (item &rest keyword-arguments)
+  remove/swapped-arguments
+  "Modify-macro for REMOVE. Sets place designated by the first argument to
+the result of calling REMOVE with ITEM, place, and the KEYWORD-ARGUMENTS.")
+
+(declaim (inline delete/swapped-arguments))
+(defun delete/swapped-arguments (sequence item &rest keyword-arguments)
+  (apply #'delete item sequence keyword-arguments))
+
+(define-modify-macro deletef (item &rest keyword-arguments)
+  delete/swapped-arguments
+  "Modify-macro for DELETE. Sets place designated by the first argument to
+the result of calling DELETE with ITEM, place, and the KEYWORD-ARGUMENTS.")
+
+(deftype proper-sequence ()
+  "Type designator for proper sequences, that is proper lists and sequences
+that are not lists."
+  `(or proper-list
+       (and (not list) sequence)))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (when (and (find-package '#:sequence)
+             (find-symbol (string '#:emptyp) '#:sequence))
+    (pushnew 'sequence-emptyp *features*)))
+
+#-alexandria::sequence-emptyp
+(defun emptyp (sequence)
+  "Returns true if SEQUENCE is an empty sequence. Signals an error if SEQUENCE
+is not a sequence."
+  (etypecase sequence
+    (list (null sequence))
+    (sequence (zerop (length sequence)))))
+
+#+alexandria::sequence-emptyp
+(declaim (ftype (function (sequence) (values boolean &optional)) emptyp))
+#+alexandria::sequence-emptyp
+(setf (symbol-function 'emptyp) (symbol-function 'sequence:emptyp))
+#+alexandria::sequence-emptyp
+(define-compiler-macro emptyp (sequence)
+  `(sequence:emptyp ,sequence))
+
+(defun length= (&rest sequences)
+  "Takes any number of sequences or integers in any order. Returns true iff
+the length of all the sequences and the integers are equal. Hint: there's a
+compiler macro that expands into more efficient code if the first argument
+is a literal integer."
+  (declare (dynamic-extent sequences)
+           (inline sequence-of-length-p)
+           (optimize speed))
+  (unless (cdr sequences)
+    (error "You must call LENGTH= with at least two arguments"))
+  ;; There's room for optimization here: multiple list arguments could be
+  ;; traversed in parallel.
+  (let* ((first (pop sequences))
+         (current (if (integerp first)
+                      first
+                      (length first))))
+    (declare (type array-index current))
+    (dolist (el sequences)
+      (if (integerp el)
+          (unless (= el current)
+            (return-from length= nil))
+          (unless (sequence-of-length-p el current)
+            (return-from length= nil)))))
+  t)
+
+(define-compiler-macro length= (&whole form length &rest sequences)
+  (cond
+    ((zerop (length sequences))
+     form)
+    (t
+     (let ((optimizedp (integerp length)))
+       (with-unique-names (tmp current)
+         (declare (ignorable current))
+         `(locally
+              (declare (inline sequence-of-length-p))
+            (let ((,tmp)
+                  ,@(unless optimizedp
+                     `((,current ,length))))
+              ,@(unless optimizedp
+                  `((unless (integerp ,current)
+                      (setf ,current (length ,current)))))
+              (and
+               ,@(loop
+                    :for sequence :in sequences
+                    :collect `(progn
+                                (setf ,tmp ,sequence)
+                                (if (integerp ,tmp)
+                                    (= ,tmp ,(if optimizedp
+                                                 length
+                                                 current))
+                                    (sequence-of-length-p ,tmp ,(if optimizedp
+                                                                    length
+                                                                    current)))))))))))))
+
+(defun copy-sequence (type sequence)
+  "Returns a fresh sequence of TYPE, which has the same elements as
+SEQUENCE."
+  (if (typep sequence type)
+      (copy-seq sequence)
+      (coerce sequence type)))
+
+(defun first-elt (sequence)
+  "Returns the first element of SEQUENCE. Signals a type-error if SEQUENCE is
+not a sequence, or is an empty sequence."
+  ;; Can't just directly use ELT, as it is not guaranteed to signal the
+  ;; type-error.
+  (cond  ((consp sequence)
+          (car sequence))
+         ((and (typep sequence 'sequence) (not (emptyp sequence)))
+          (elt sequence 0))
+         (t
+          (error 'type-error
+                 :datum sequence
+                 :expected-type '(and sequence (not (satisfies emptyp)))))))
+
+(defun (setf first-elt) (object sequence)
+  "Sets the first element of SEQUENCE. Signals a type-error if SEQUENCE is
+not a sequence, is an empty sequence, or if OBJECT cannot be stored in SEQUENCE."
+  ;; Can't just directly use ELT, as it is not guaranteed to signal the
+  ;; type-error.
+  (cond ((consp sequence)
+         (setf (car sequence) object))
+        ((and (typep sequence 'sequence) (not (emptyp sequence)))
+         (setf (elt sequence 0) object))
+        (t
+         (error 'type-error
+                :datum sequence
+                :expected-type '(and sequence (not (satisfies emptyp)))))))
+
+(defun last-elt (sequence)
+  "Returns the last element of SEQUENCE. Signals a type-error if SEQUENCE is
+not a proper sequence, or is an empty sequence."
+  ;; Can't just directly use ELT, as it is not guaranteed to signal the
+  ;; type-error.
+  (let ((len 0))
+    (cond ((consp sequence)
+           (lastcar sequence))
+          ((and (typep sequence '(and sequence (not list))) (plusp (setf len (length sequence))))
+           (elt sequence (1- len)))
+          (t
+           (error 'type-error
+                  :datum sequence
+                  :expected-type '(and proper-sequence (not (satisfies emptyp))))))))
+
+(defun (setf last-elt) (object sequence)
+  "Sets the last element of SEQUENCE. Signals a type-error if SEQUENCE is not a proper
+sequence, is an empty sequence, or if OBJECT cannot be stored in SEQUENCE."
+  (let ((len 0))
+    (cond ((consp sequence)
+           (setf (lastcar sequence) object))
+          ((and (typep sequence '(and sequence (not list))) (plusp (setf len (length sequence))))
+           (setf (elt sequence (1- len)) object))
+          (t
+           (error 'type-error
+                  :datum sequence
+                  :expected-type '(and proper-sequence (not (satisfies emptyp))))))))
+
+(defun starts-with-subseq (prefix sequence &rest args
+                           &key
+                           (return-suffix nil return-suffix-supplied-p)
+                           &allow-other-keys)
+  "Test whether the first elements of SEQUENCE are the same (as per TEST) as the elements of PREFIX.
+
+If RETURN-SUFFIX is T the function returns, as a second value, a
+sub-sequence or displaced array pointing to the sequence after PREFIX."
+  (declare (dynamic-extent args))
+  (let ((sequence-length (length sequence))
+        (prefix-length (length prefix)))
+    (when (< sequence-length prefix-length)
+      (return-from starts-with-subseq (values nil nil)))
+    (flet ((make-suffix (start)
+             (when return-suffix
+               (cond
+                 ((not (arrayp sequence))
+                  (if start
+                      (subseq sequence start)
+                      (subseq sequence 0 0)))
+                 ((not start)
+                  (make-array 0
+                              :element-type (array-element-type sequence)
+                              :adjustable nil))
+                 (t
+                  (make-array (- sequence-length start)
+                              :element-type (array-element-type sequence)
+                              :displaced-to sequence
+                              :displaced-index-offset start
+                              :adjustable nil))))))
+      (let ((mismatch (apply #'mismatch prefix sequence
+                             (if return-suffix-supplied-p
+                                 (remove-from-plist args :return-suffix)
+                                 args))))
+        (cond
+          ((not mismatch)
+           (values t (make-suffix nil)))
+          ((= mismatch prefix-length)
+           (values t (make-suffix mismatch)))
+          (t
+           (values nil nil)))))))
+
+(defun ends-with-subseq (suffix sequence &key (test #'eql))
+  "Test whether SEQUENCE ends with SUFFIX. In other words: return true if
+the last (length SUFFIX) elements of SEQUENCE are equal to SUFFIX."
+  (let ((sequence-length (length sequence))
+        (suffix-length (length suffix)))
+    (when (< sequence-length suffix-length)
+      ;; if SEQUENCE is shorter than SUFFIX, then SEQUENCE can't end with SUFFIX.
+      (return-from ends-with-subseq nil))
+    (loop for sequence-index from (- sequence-length suffix-length) below sequence-length
+          for suffix-index from 0 below suffix-length
+          when (not (funcall test (elt sequence sequence-index) (elt suffix suffix-index)))
+          do (return-from ends-with-subseq nil)
+          finally (return t))))
+
+(defun starts-with (object sequence &key (test #'eql) (key #'identity))
+  "Returns true if SEQUENCE is a sequence whose first element is EQL to OBJECT.
+Returns NIL if the SEQUENCE is not a sequence or is an empty sequence."
+  (let ((first-elt (typecase sequence
+                     (cons (car sequence))
+                     (sequence
+                      (if (emptyp sequence)
+                          (return-from starts-with nil)
+                          (elt sequence 0)))
+                     (t
+                      (return-from starts-with nil)))))
+    (funcall test (funcall key first-elt) object)))
+
+(defun ends-with (object sequence &key (test #'eql) (key #'identity))
+  "Returns true if SEQUENCE is a sequence whose last element is EQL to OBJECT.
+Returns NIL if the SEQUENCE is not a sequence or is an empty sequence. Signals
+an error if SEQUENCE is an improper list."
+  (let ((last-elt (typecase sequence
+                    (cons
+                     (lastcar sequence)) ; signals for improper lists
+                    (sequence
+                     ;; Can't use last-elt, as that signals an error
+                     ;; for empty sequences
+                     (let ((len (length sequence)))
+                       (if (plusp len)
+                           (elt sequence (1- len))
+                           (return-from ends-with nil))))
+                    (t
+                     (return-from ends-with nil)))))
+    (funcall test (funcall key last-elt) object)))
+
+(defun map-combinations (function sequence &key (start 0) end length (copy t))
+  "Calls FUNCTION with each combination of LENGTH constructable from the
+elements of the subsequence of SEQUENCE delimited by START and END. START
+defaults to 0, END to length of SEQUENCE, and LENGTH to the length of the
+delimited subsequence. (So unless LENGTH is specified there is only a single
+combination, which has the same elements as the delimited subsequence.) If
+COPY is true (the default) each combination is freshly allocated. If COPY is
+false all combinations are EQ to each other, in which case consequences are
+unspecified if a combination is modified by FUNCTION."
+  (let* ((end (or end (length sequence)))
+         (size (- end start))
+         (length (or length size))
+         (combination (subseq sequence 0 length))
+         (function (ensure-function function)))
+    (if (= length size)
+        (funcall function combination)
+        (flet ((call ()
+                 (funcall function (if copy
+                                       (copy-seq combination)
+                                       combination))))
+          (etypecase sequence
+            ;; When dealing with lists we prefer walking back and
+            ;; forth instead of using indexes.
+            (list
+             (labels ((combine-list (c-tail o-tail)
+                        (if (not c-tail)
+                            (call)
+                            (do ((tail o-tail (cdr tail)))
+                                ((not tail))
+                              (setf (car c-tail) (car tail))
+                              (combine-list (cdr c-tail) (cdr tail))))))
+               (combine-list combination (nthcdr start sequence))))
+            (vector
+             (labels ((combine (count start)
+                        (if (zerop count)
+                            (call)
+                            (loop for i from start below end
+                                  do (let ((j (- count 1)))
+                                       (setf (aref combination j) (aref sequence i))
+                                       (combine j (+ i 1)))))))
+               (combine length start)))
+            (sequence
+             (labels ((combine (count start)
+                        (if (zerop count)
+                            (call)
+                            (loop for i from start below end
+                                  do (let ((j (- count 1)))
+                                       (setf (elt combination j) (elt sequence i))
+                                       (combine j (+ i 1)))))))
+               (combine length start)))))))
+  sequence)
+
+(defun map-permutations (function sequence &key (start 0) end length (copy t))
+  "Calls function with each permutation of LENGTH constructable
+from the subsequence of SEQUENCE delimited by START and END. START
+defaults to 0, END to length of the sequence, and LENGTH to the
+length of the delimited subsequence."
+  (let* ((end (or end (length sequence)))
+         (size (- end start))
+         (length (or length size)))
+    (labels ((permute (seq n)
+               (let ((n-1 (- n 1)))
+                 (if (zerop n-1)
+                     (funcall function (if copy
+                                           (copy-seq seq)
+                                           seq))
+                     (loop for i from 0 upto n-1
+                           do (permute seq n-1)
+                           (if (evenp n-1)
+                               (rotatef (elt seq 0) (elt seq n-1))
+                               (rotatef (elt seq i) (elt seq n-1)))))))
+             (permute-sequence (seq)
+               (permute seq length)))
+      (if (= length size)
+          ;; Things are simple if we need to just permute the
+          ;; full START-END range.
+          (permute-sequence (subseq sequence start end))
+          ;; Otherwise we need to generate all the combinations
+          ;; of LENGTH in the START-END range, and then permute
+          ;; a copy of the result: can't permute the combination
+          ;; directly, as they share structure with each other.
+          (let ((permutation (subseq sequence 0 length)))
+            (flet ((permute-combination (combination)
+                     (permute-sequence (replace permutation combination))))
+              (declare (dynamic-extent #'permute-combination))
+              (map-combinations #'permute-combination sequence
+                                :start start
+                                :end end
+                                :length length
+                                :copy nil)))))))
+
+(defun map-derangements (function sequence &key (start 0) end (copy t))
+  "Calls FUNCTION with each derangement of the subsequence of SEQUENCE denoted
+by the bounding index designators START and END. Derangement is a permutation
+of the sequence where no element remains in place. SEQUENCE is not modified,
+but individual derangements are EQ to each other. Consequences are unspecified
+if calling FUNCTION modifies either the derangement or SEQUENCE."
+  (let* ((end (or end (length sequence)))
+         (size (- end start))
+         ;; We don't really care about the elements here.
+         (derangement (subseq sequence 0 size))
+         ;; Bitvector that has 1 for elements that have been deranged.
+         (mask (make-array size :element-type 'bit :initial-element 0)))
+    (declare (dynamic-extent mask))
+    ;; ad hoc algorith
+    (labels ((derange (place n)
+               ;; Perform one recursive step in deranging the
+               ;; sequence: PLACE is index of the original sequence
+               ;; to derange to another index, and N is the number of
+               ;; indexes not yet deranged.
+               (if (zerop n)
+                   (funcall function (if copy
+                                         (copy-seq derangement)
+                                         derangement))
+                   ;; Itarate over the indexes I of the subsequence to
+                   ;; derange: if I != PLACE and I has not yet been
+                   ;; deranged by an earlier call put the element from
+                   ;; PLACE to I, mark I as deranged, and recurse,
+                   ;; finally removing the mark.
+                   (loop for i from 0 below size
+                         do
+                         (unless (or (= place (+ i start)) (not (zerop (bit mask i))))
+                           (setf (elt derangement i) (elt sequence place)
+                                 (bit mask i) 1)
+                           (derange (1+ place) (1- n))
+                           (setf (bit mask i) 0))))))
+      (derange start size)
+      sequence)))
+
+(declaim (notinline sequence-of-length-p))
+
+(defun extremum (sequence predicate &key key (start 0) end)
+  "Returns the element of SEQUENCE that would appear first if the subsequence
+bounded by START and END was sorted using PREDICATE and KEY.
+
+EXTREMUM determines the relationship between two elements of SEQUENCE by using
+the PREDICATE function. PREDICATE should return true if and only if the first
+argument is strictly less than the second one (in some appropriate sense). Two
+arguments X and Y are considered to be equal if (FUNCALL PREDICATE X Y)
+and (FUNCALL PREDICATE Y X) are both false.
+
+The arguments to the PREDICATE function are computed from elements of SEQUENCE
+using the KEY function, if supplied. If KEY is not supplied or is NIL, the
+sequence element itself is used.
+
+If SEQUENCE is empty, NIL is returned."
+  (let* ((pred-fun (ensure-function predicate))
+         (key-fun (unless (or (not key) (eq key 'identity) (eq key #'identity))
+                    (ensure-function key)))
+         (real-end (or end (length sequence))))
+    (cond ((> real-end start)
+           (if key-fun
+               (flet ((reduce-keys (a b)
+                        (if (funcall pred-fun
+                                     (funcall key-fun a)
+                                     (funcall key-fun b))
+                            a
+                            b)))
+                 (declare (dynamic-extent #'reduce-keys))
+                 (reduce #'reduce-keys sequence :start start :end real-end))
+               (flet ((reduce-elts (a b)
+                        (if (funcall pred-fun a b)
+                            a
+                            b)))
+                 (declare (dynamic-extent #'reduce-elts))
+                 (reduce #'reduce-elts sequence :start start :end real-end))))
+          ((= real-end start)
+           nil)
+          (t
+           (error "Invalid bounding indexes for sequence of length ~S: ~S ~S, ~S ~S"
+                  (length sequence)
+                  :start start
+                  :end end)))))
diff --git a/strings.lisp b/strings.lisp
new file mode 100644
index 000000000000..e9fd91c96155
--- /dev/null
+++ b/strings.lisp
@@ -0,0 +1,6 @@
+(in-package :alexandria)
+
+(deftype string-designator ()
+  "A string designator type. A string designator is either a string, a symbol,
+or a character."
+  `(or symbol string character))
diff --git a/symbols.lisp b/symbols.lisp
new file mode 100644
index 000000000000..5733d3e1cc50
--- /dev/null
+++ b/symbols.lisp
@@ -0,0 +1,65 @@
+(in-package :alexandria)
+
+(declaim (inline ensure-symbol))
+(defun ensure-symbol (name &optional (package *package*))
+  "Returns a symbol with name designated by NAME, accessible in package
+designated by PACKAGE. If symbol is not already accessible in PACKAGE, it is
+interned there. Returns a secondary value reflecting the status of the symbol
+in the package, which matches the secondary return value of INTERN.
+
+Example:
+
+  (ensure-symbol :cons :cl) => cl:cons, :external
+"
+  (intern (string name) package))
+
+(defun maybe-intern (name package)
+  (values
+   (if package
+       (intern name (if (eq t package) *package* package))
+       (make-symbol name))))
+
+(declaim (inline format-symbol))
+(defun format-symbol (package control &rest arguments)
+  "Constructs a string by applying ARGUMENTS to string designator CONTROL as
+if by FORMAT within WITH-STANDARD-IO-SYNTAX, and then creates a symbol named
+by that string.
+
+If PACKAGE is NIL, returns an uninterned symbol, if package is T, returns a
+symbol interned in the current package, and otherwise returns a symbol
+interned in the package designated by PACKAGE."
+  (maybe-intern (with-standard-io-syntax
+                  (apply #'format nil (string control) arguments))
+                package))
+
+(defun make-keyword (name)
+  "Interns the string designated by NAME in the KEYWORD package."
+  (intern (string name) :keyword))
+
+(defun make-gensym (name)
+  "If NAME is a non-negative integer, calls GENSYM using it. Otherwise NAME
+must be a string designator, in which case calls GENSYM using the designated
+string as the argument."
+  (gensym (if (typep name '(integer 0))
+              name
+              (string name))))
+
+(defun make-gensym-list (length &optional (x "G"))
+  "Returns a list of LENGTH gensyms, each generated as if with a call to MAKE-GENSYM,
+using the second (optional, defaulting to \"G\") argument."
+  (let ((g (if (typep x '(integer 0)) x (string x))))
+    (loop repeat length
+          collect (gensym g))))
+
+(defun symbolicate (&rest things)
+  "Concatenate together the names of some strings and symbols,
+producing a symbol in the current package."
+  (let* ((length (reduce #'+ things
+                         :key (lambda (x) (length (string x)))))
+         (name (make-array length :element-type 'character)))
+    (let ((index 0))
+      (dolist (thing things (values (intern name)))
+        (let* ((x (string thing))
+               (len (length x)))
+          (replace name x :start1 index)
+          (incf index len))))))
diff --git a/tests.lisp b/tests.lisp
new file mode 100644
index 000000000000..b70ef0475e81
--- /dev/null
+++ b/tests.lisp
@@ -0,0 +1,2047 @@
+(in-package :cl-user)
+
+(defpackage :alexandria-tests
+  (:use :cl :alexandria #+sbcl :sb-rt #-sbcl :rtest)
+  (:import-from #+sbcl :sb-rt #-sbcl :rtest
+                #:*compile-tests* #:*expected-failures*))
+
+(in-package :alexandria-tests)
+
+(defun run-tests (&key ((:compiled *compile-tests*)))
+  (do-tests))
+
+(defun hash-table-test-name (name)
+  ;; Workaround for Clisp calling EQL in a hash-table FASTHASH-EQL.
+  (hash-table-test (make-hash-table :test name)))
+
+;;;; Arrays
+
+(deftest copy-array.1
+    (let* ((orig (vector 1 2 3))
+           (copy (copy-array orig)))
+      (values (eq orig copy) (equalp orig copy)))
+  nil t)
+
+(deftest copy-array.2
+    (let ((orig (make-array 1024 :fill-pointer 0)))
+      (vector-push-extend 1 orig)
+      (vector-push-extend 2 orig)
+      (vector-push-extend 3 orig)
+      (let ((copy (copy-array orig)))
+        (values (eq orig copy) (equalp orig copy)
+                (array-has-fill-pointer-p copy)
+                (eql (fill-pointer orig) (fill-pointer copy)))))
+  nil t t t)
+
+(deftest copy-array.3
+    (let* ((orig (vector 1 2 3))
+           (copy (copy-array orig)))
+      (typep copy 'simple-array))
+  t)
+
+(deftest copy-array.4
+   (let ((orig (make-array 21
+                           :adjustable t
+                           :fill-pointer 0)))
+     (dotimes (n 42)
+       (vector-push-extend n orig))
+     (let ((copy (copy-array orig
+                             :adjustable nil
+                             :fill-pointer nil)))
+       (typep copy 'simple-array)))
+ t)
+
+(deftest array-index.1
+    (typep 0 'array-index)
+  t)
+
+;;;; Conditions
+
+(deftest unwind-protect-case.1
+    (let (result)
+      (unwind-protect-case ()
+          (random 10)
+        (:normal (push :normal result))
+        (:abort  (push :abort result))
+        (:always (push :always result)))
+      result)
+  (:always :normal))
+
+(deftest unwind-protect-case.2
+    (let (result)
+      (unwind-protect-case ()
+          (random 10)
+        (:always (push :always result))
+        (:normal (push :normal result))
+        (:abort  (push :abort result)))
+      result)
+  (:normal :always))
+
+(deftest unwind-protect-case.3
+    (let (result1 result2 result3)
+      (ignore-errors
+        (unwind-protect-case ()
+            (error "FOOF!")
+          (:normal (push :normal result1))
+          (:abort  (push :abort result1))
+          (:always (push :always result1))))
+      (catch 'foof
+        (unwind-protect-case ()
+            (throw 'foof 42)
+          (:normal (push :normal result2))
+          (:abort  (push :abort result2))
+          (:always (push :always result2))))
+      (block foof
+        (unwind-protect-case ()
+            (return-from foof 42)
+          (:normal (push :normal result3))
+          (:abort  (push :abort result3))
+          (:always (push :always result3))))
+      (values result1 result2 result3))
+  (:always :abort)
+  (:always :abort)
+  (:always :abort))
+
+(deftest unwind-protect-case.4
+    (let (result)
+      (unwind-protect-case (aborted-p)
+          (random 42)
+        (:always (setq result aborted-p)))
+      result)
+  nil)
+
+(deftest unwind-protect-case.5
+    (let (result)
+      (block foof
+        (unwind-protect-case (aborted-p)
+            (return-from foof)
+          (:always (setq result aborted-p))))
+      result)
+  t)
+
+;;;; Control flow
+
+(deftest switch.1
+    (switch (13 :test =)
+      (12 :oops)
+      (13.0 :yay))
+  :yay)
+
+(deftest switch.2
+    (switch (13)
+      ((+ 12 2) :oops)
+      ((- 13 1) :oops2)
+      (t :yay))
+  :yay)
+
+(deftest eswitch.1
+    (let ((x 13))
+      (eswitch (x :test =)
+        (12 :oops)
+        (13.0 :yay)))
+  :yay)
+
+(deftest eswitch.2
+    (let ((x 13))
+      (eswitch (x :key 1+)
+        (11 :oops)
+        (14 :yay)))
+  :yay)
+
+(deftest cswitch.1
+    (cswitch (13 :test =)
+      (12 :oops)
+      (13.0 :yay))
+  :yay)
+
+(deftest cswitch.2
+    (cswitch (13 :key 1-)
+      (12 :yay)
+      (13.0 :oops))
+  :yay)
+
+(deftest multiple-value-prog2.1
+    (multiple-value-prog2
+        (values 1 1 1)
+        (values 2 20 200)
+      (values 3 3 3))
+  2 20 200)
+
+(deftest nth-value-or.1
+    (multiple-value-bind (a b c)
+        (nth-value-or 1
+                      (values 1 nil 1)
+                      (values 2 2 2))
+      (= a b c 2))
+  t)
+
+(deftest whichever.1
+    (let ((x (whichever 1 2 3)))
+      (and (member x '(1 2 3)) t))
+  t)
+
+(deftest whichever.2
+    (let* ((a 1)
+           (b 2)
+           (c 3)
+           (x (whichever a b c)))
+      (and (member x '(1 2 3)) t))
+  t)
+
+(deftest xor.1
+    (xor nil nil 1 nil)
+  1
+  t)
+
+(deftest xor.2
+    (xor nil nil 1 2)
+  nil
+  nil)
+
+(deftest xor.3
+    (xor nil nil nil)
+  nil
+  t)
+
+;;;; Definitions
+
+(deftest define-constant.1
+    (let ((name (gensym)))
+      (eval `(define-constant ,name "FOO" :test 'equal))
+      (eval `(define-constant ,name "FOO" :test 'equal))
+      (values (equal "FOO" (symbol-value name))
+              (constantp name)))
+  t
+  t)
+
+(deftest define-constant.2
+    (let ((name (gensym)))
+      (eval `(define-constant ,name 13))
+      (eval `(define-constant ,name 13))
+      (values (eql 13 (symbol-value name))
+              (constantp name)))
+  t
+  t)
+
+;;;; Errors
+
+;;; TYPEP is specified to return a generalized boolean and, for
+;;; example, ECL exploits this by returning the superclasses of ERROR
+;;; in this case.
+(defun errorp (x)
+  (not (null (typep x 'error))))
+
+(deftest required-argument.1
+    (multiple-value-bind (res err)
+        (ignore-errors (required-argument))
+      (errorp err))
+  t)
+
+;;;; Hash tables
+
+(deftest ensure-gethash.1
+    (let ((table (make-hash-table))
+          (x (list 1)))
+      (multiple-value-bind (value already-there)
+          (ensure-gethash x table 42)
+        (and (= value 42)
+             (not already-there)
+             (= 42 (gethash x table))
+             (multiple-value-bind (value2 already-there2)
+                 (ensure-gethash x table 13)
+               (and (= value2 42)
+                    already-there2
+                    (= 42 (gethash x table)))))))
+  t)
+
+(deftest ensure-gethash.2
+    (let ((table (make-hash-table))
+          (count 0))
+      (multiple-value-call #'values
+        (ensure-gethash (progn (incf count) :foo)
+                        (progn (incf count) table)
+                        (progn (incf count) :bar))
+        (gethash :foo table)
+        count))
+  :bar nil :bar t 3)
+
+(deftest copy-hash-table.1
+    (let ((orig (make-hash-table :test 'eq :size 123))
+          (foo "foo"))
+      (setf (gethash orig orig) t
+            (gethash foo orig) t)
+      (let ((eq-copy (copy-hash-table orig))
+            (eql-copy (copy-hash-table orig :test 'eql))
+            (equal-copy (copy-hash-table orig :test 'equal))
+            (equalp-copy (copy-hash-table orig :test 'equalp)))
+        (list (eql (hash-table-size eq-copy) (hash-table-size orig))
+              (eql (hash-table-rehash-size eq-copy)
+                   (hash-table-rehash-size orig))
+              (hash-table-count eql-copy)
+              (gethash orig eq-copy)
+              (gethash (copy-seq foo) eql-copy)
+              (gethash foo eql-copy)
+              (gethash (copy-seq foo) equal-copy)
+              (gethash "FOO" equal-copy)
+              (gethash "FOO" equalp-copy))))
+  (t t 2 t nil t t nil t))
+
+(deftest copy-hash-table.2
+    (let ((ht (make-hash-table))
+          (list (list :list (vector :A :B :C))))
+      (setf (gethash 'list ht) list)
+      (let* ((shallow-copy (copy-hash-table ht))
+             (deep1-copy (copy-hash-table ht :key 'copy-list))
+             (list         (gethash 'list ht))
+             (shallow-list (gethash 'list shallow-copy))
+             (deep1-list   (gethash 'list deep1-copy)))
+        (list (eq ht shallow-copy)
+              (eq ht deep1-copy)
+              (eq list shallow-list)
+              (eq list deep1-list)                   ; outer list was copied.
+              (eq (second list) (second shallow-list))
+              (eq (second list) (second deep1-list)) ; inner vector wasn't copied.
+              )))
+  (nil nil t nil t t))
+
+(deftest maphash-keys.1
+    (let ((keys nil)
+          (table (make-hash-table)))
+      (declare (notinline maphash-keys))
+      (dotimes (i 10)
+        (setf (gethash i table) t))
+      (maphash-keys (lambda (k) (push k keys)) table)
+      (set-equal keys '(0 1 2 3 4 5 6 7 8 9)))
+  t)
+
+(deftest maphash-values.1
+    (let ((vals nil)
+          (table (make-hash-table)))
+      (declare (notinline maphash-values))
+      (dotimes (i 10)
+        (setf (gethash i table) (- i)))
+      (maphash-values (lambda (v) (push v vals)) table)
+      (set-equal vals '(0 -1 -2 -3 -4 -5 -6 -7 -8 -9)))
+  t)
+
+(deftest hash-table-keys.1
+    (let ((table (make-hash-table)))
+      (dotimes (i 10)
+        (setf (gethash i table) t))
+      (set-equal (hash-table-keys table) '(0 1 2 3 4 5 6 7 8 9)))
+  t)
+
+(deftest hash-table-values.1
+    (let ((table (make-hash-table)))
+      (dotimes (i 10)
+        (setf (gethash (gensym) table) i))
+      (set-equal (hash-table-values table) '(0 1 2 3 4 5 6 7 8 9)))
+  t)
+
+(deftest hash-table-alist.1
+    (let ((table (make-hash-table)))
+      (dotimes (i 10)
+        (setf (gethash i table) (- i)))
+      (let ((alist (hash-table-alist table)))
+        (list (length alist)
+              (assoc 0 alist)
+              (assoc 3 alist)
+              (assoc 9 alist)
+              (assoc nil alist))))
+  (10 (0 . 0) (3 . -3) (9 . -9) nil))
+
+(deftest hash-table-plist.1
+    (let ((table (make-hash-table)))
+      (dotimes (i 10)
+        (setf (gethash i table) (- i)))
+      (let ((plist (hash-table-plist table)))
+        (list (length plist)
+              (getf plist 0)
+              (getf plist 2)
+              (getf plist 7)
+              (getf plist nil))))
+  (20 0 -2 -7 nil))
+
+(deftest alist-hash-table.1
+    (let* ((alist '((0 a) (1 b) (2 c)))
+           (table (alist-hash-table alist)))
+      (list (hash-table-count table)
+            (gethash 0 table)
+            (gethash 1 table)
+            (gethash 2 table)
+            (eq (hash-table-test-name 'eql)
+                (hash-table-test table))))
+  (3 (a) (b) (c) t))
+
+(deftest alist-hash-table.duplicate-keys
+    (let* ((alist '((0 a) (1 b) (0 c) (1 d) (2 e)))
+           (table (alist-hash-table alist)))
+      (list (hash-table-count table)
+            (gethash 0 table)
+            (gethash 1 table)
+            (gethash 2 table)))
+  (3 (a) (b) (e)))
+
+(deftest plist-hash-table.1
+    (let* ((plist '(:a 1 :b 2 :c 3))
+           (table (plist-hash-table plist :test 'eq)))
+      (list (hash-table-count table)
+            (gethash :a table)
+            (gethash :b table)
+            (gethash :c table)
+            (gethash 2 table)
+            (gethash nil table)
+            (eq (hash-table-test-name 'eq)
+                (hash-table-test table))))
+  (3 1 2 3 nil nil t))
+
+(deftest plist-hash-table.duplicate-keys
+    (let* ((plist '(:a 1 :b 2 :a 3 :b 4 :c 5))
+           (table (plist-hash-table plist)))
+      (list (hash-table-count table)
+            (gethash :a table)
+            (gethash :b table)
+            (gethash :c table)))
+  (3 1 2 5))
+
+;;;; Functions
+
+(deftest disjoin.1
+    (let ((disjunction (disjoin (lambda (x)
+                                  (and (consp x) :cons))
+                                (lambda (x)
+                                  (and (stringp x) :string)))))
+      (list (funcall disjunction 'zot)
+            (funcall disjunction '(foo bar))
+            (funcall disjunction "test")))
+  (nil :cons :string))
+
+(deftest disjoin.2
+    (let ((disjunction (disjoin #'zerop)))
+      (list (funcall disjunction 0)
+            (funcall disjunction 1)))
+  (t nil))
+
+(deftest conjoin.1
+    (let ((conjunction (conjoin #'consp
+                                (lambda (x)
+                                  (stringp (car x)))
+                                (lambda (x)
+                                  (char (car x) 0)))))
+      (list (funcall conjunction 'zot)
+            (funcall conjunction '(foo))
+            (funcall conjunction '("foo"))))
+  (nil nil #\f))
+
+(deftest conjoin.2
+    (let ((conjunction (conjoin #'zerop)))
+      (list (funcall conjunction 0)
+            (funcall conjunction 1)))
+  (t nil))
+
+(deftest compose.1
+    (let ((composite (compose '1+
+                              (lambda (x)
+                                (* x 2))
+                              #'read-from-string)))
+      (funcall composite "1"))
+  3)
+
+(deftest compose.2
+    (let ((composite
+           (locally (declare (notinline compose))
+             (compose '1+
+                      (lambda (x)
+                        (* x 2))
+                      #'read-from-string))))
+      (funcall composite "2"))
+  5)
+
+(deftest compose.3
+    (let ((compose-form (funcall (compiler-macro-function 'compose)
+                                 '(compose '1+
+                                   (lambda (x)
+                                     (* x 2))
+                                   #'read-from-string)
+                                 nil)))
+      (let ((fun (funcall (compile nil `(lambda () ,compose-form)))))
+        (funcall fun "3")))
+  7)
+
+(deftest compose.4
+    (let ((composite (compose #'zerop)))
+      (list (funcall composite 0)
+            (funcall composite 1)))
+  (t nil))
+
+(deftest multiple-value-compose.1
+    (let ((composite (multiple-value-compose
+                      #'truncate
+                      (lambda (x y)
+                        (values y x))
+                      (lambda (x)
+                        (with-input-from-string (s x)
+                          (values (read s) (read s)))))))
+      (multiple-value-list (funcall composite "2 7")))
+  (3 1))
+
+(deftest multiple-value-compose.2
+    (let ((composite (locally (declare (notinline multiple-value-compose))
+                       (multiple-value-compose
+                        #'truncate
+                        (lambda (x y)
+                          (values y x))
+                       (lambda (x)
+                         (with-input-from-string (s x)
+                           (values (read s) (read s))))))))
+      (multiple-value-list (funcall composite "2 11")))
+  (5 1))
+
+(deftest multiple-value-compose.3
+    (let ((compose-form (funcall (compiler-macro-function 'multiple-value-compose)
+                                 '(multiple-value-compose
+                                   #'truncate
+                                   (lambda (x y)
+                                     (values y x))
+                                   (lambda (x)
+                                     (with-input-from-string (s x)
+                                       (values (read s) (read s)))))
+                                 nil)))
+      (let ((fun (funcall (compile nil `(lambda () ,compose-form)))))
+        (multiple-value-list (funcall fun "2 9"))))
+  (4 1))
+
+(deftest multiple-value-compose.4
+    (let ((composite (multiple-value-compose #'truncate)))
+      (multiple-value-list (funcall composite 9 2)))
+  (4 1))
+
+(deftest curry.1
+    (let ((curried (curry '+ 3)))
+      (funcall curried 1 5))
+  9)
+
+(deftest curry.2
+    (let ((curried (locally (declare (notinline curry))
+                     (curry '* 2 3))))
+      (funcall curried 7))
+  42)
+
+(deftest curry.3
+    (let ((curried-form (funcall (compiler-macro-function 'curry)
+                                 '(curry '/ 8)
+                                 nil)))
+      (let ((fun (funcall (compile nil `(lambda () ,curried-form)))))
+        (funcall fun 2)))
+  4)
+
+(deftest curry.4
+    (let* ((x 1)
+           (curried (curry (progn
+                             (incf x)
+                             (lambda (y z) (* x y z)))
+                           3)))
+      (list (funcall curried 7)
+            (funcall curried 7)
+            x))
+  (42 42 2))
+
+(deftest rcurry.1
+    (let ((r (rcurry '/ 2)))
+      (funcall r 8))
+  4)
+
+(deftest rcurry.2
+    (let* ((x 1)
+           (curried (rcurry (progn
+                              (incf x)
+                              (lambda (y z) (* x y z)))
+                            3)))
+      (list (funcall curried 7)
+            (funcall curried 7)
+            x))
+  (42 42 2))
+
+(deftest named-lambda.1
+    (let ((fac (named-lambda fac (x)
+                 (if (> x 1)
+                     (* x (fac (- x 1)))
+                     x))))
+      (funcall fac 5))
+  120)
+
+(deftest named-lambda.2
+    (let ((fac (named-lambda fac (&key x)
+                 (if (> x 1)
+                     (* x (fac :x (- x 1)))
+                     x))))
+      (funcall fac :x 5))
+  120)
+
+;;;; Lists
+
+(deftest alist-plist.1
+    (alist-plist '((a . 1) (b . 2) (c . 3)))
+  (a 1 b 2 c 3))
+
+(deftest plist-alist.1
+    (plist-alist '(a 1 b 2 c 3))
+  ((a . 1) (b . 2) (c . 3)))
+
+(deftest unionf.1
+    (let* ((list (list 1 2 3))
+           (orig list))
+      (unionf list (list 1 2 4))
+      (values (equal orig (list 1 2 3))
+              (eql (length list) 4)
+              (set-difference list (list 1 2 3 4))
+              (set-difference (list 1 2 3 4) list)))
+  t
+  t
+  nil
+  nil)
+
+(deftest nunionf.1
+    (let ((list (list 1 2 3)))
+      (nunionf list (list 1 2 4))
+      (values (eql (length list) 4)
+              (set-difference (list 1 2 3 4) list)
+              (set-difference list (list 1 2 3 4))))
+  t
+  nil
+  nil)
+
+(deftest appendf.1
+    (let* ((list (list 1 2 3))
+           (orig list))
+      (appendf list '(4 5 6) '(7 8))
+      (list list (eq list orig)))
+  ((1 2 3 4 5 6 7 8) nil))
+
+(deftest nconcf.1
+    (let ((list1 (list 1 2 3))
+          (list2 (list 4 5 6)))
+      (nconcf list1 list2 (list 7 8 9))
+      list1)
+  (1 2 3 4 5 6 7 8 9))
+
+(deftest circular-list.1
+    (let ((circle (circular-list 1 2 3)))
+      (list (first circle)
+            (second circle)
+            (third circle)
+            (fourth circle)
+            (eq circle (nthcdr 3 circle))))
+  (1 2 3 1 t))
+
+(deftest circular-list-p.1
+    (let* ((circle (circular-list 1 2 3 4))
+           (tree (list circle circle))
+           (dotted (cons circle t))
+           (proper (list 1 2 3 circle))
+           (tailcirc (list* 1 2 3 circle)))
+      (list (circular-list-p circle)
+            (circular-list-p tree)
+            (circular-list-p dotted)
+            (circular-list-p proper)
+            (circular-list-p tailcirc)))
+  (t nil nil nil t))
+
+(deftest circular-list-p.2
+    (circular-list-p 'foo)
+  nil)
+
+(deftest circular-tree-p.1
+    (let* ((circle (circular-list 1 2 3 4))
+           (tree1 (list circle circle))
+           (tree2 (let* ((level2 (list 1 nil 2))
+                         (level1 (list level2)))
+                    (setf (second level2) level1)
+                    level1))
+           (dotted (cons circle t))
+           (proper (list 1 2 3 circle))
+           (tailcirc (list* 1 2 3 circle))
+           (quite-proper (list 1 2 3))
+           (quite-dotted (list 1 (cons 2 3))))
+      (list (circular-tree-p circle)
+            (circular-tree-p tree1)
+            (circular-tree-p tree2)
+            (circular-tree-p dotted)
+            (circular-tree-p proper)
+            (circular-tree-p tailcirc)
+            (circular-tree-p quite-proper)
+            (circular-tree-p quite-dotted)))
+  (t t t t t t nil nil))
+
+(deftest circular-tree-p.2
+    (alexandria:circular-tree-p '#1=(#1#))
+  t)
+
+(deftest proper-list-p.1
+    (let ((l1 (list 1))
+          (l2 (list 1 2))
+          (l3 (cons 1 2))
+          (l4 (list (cons 1 2) 3))
+          (l5 (circular-list 1 2)))
+      (list (proper-list-p l1)
+            (proper-list-p l2)
+            (proper-list-p l3)
+            (proper-list-p l4)
+            (proper-list-p l5)))
+  (t t nil t nil))
+
+(deftest proper-list-p.2
+    (proper-list-p '(1 2 . 3))
+  nil)
+
+(deftest proper-list.type.1
+    (let ((l1 (list 1))
+          (l2 (list 1 2))
+          (l3 (cons 1 2))
+          (l4 (list (cons 1 2) 3))
+          (l5 (circular-list 1 2)))
+      (list (typep l1 'proper-list)
+            (typep l2 'proper-list)
+            (typep l3 'proper-list)
+            (typep l4 'proper-list)
+            (typep l5 'proper-list)))
+  (t t nil t nil))
+
+(deftest proper-list-length.1
+    (values
+     (proper-list-length nil)
+     (proper-list-length (list 1))
+     (proper-list-length (list 2 2))
+     (proper-list-length (list 3 3 3))
+     (proper-list-length (list 4 4 4 4))
+     (proper-list-length (list 5 5 5 5 5))
+     (proper-list-length (list 6 6 6 6 6 6))
+     (proper-list-length (list 7 7 7 7 7 7 7))
+     (proper-list-length (list 8 8 8 8 8 8 8 8))
+     (proper-list-length (list 9 9 9 9 9 9 9 9 9)))
+  0 1 2 3 4 5 6 7 8 9)
+
+(deftest proper-list-length.2
+    (flet ((plength (x)
+             (handler-case
+                 (proper-list-length x)
+               (type-error ()
+                 :ok))))
+      (values
+       (plength (list* 1))
+       (plength (list* 2 2))
+       (plength (list* 3 3 3))
+       (plength (list* 4 4 4 4))
+       (plength (list* 5 5 5 5 5))
+       (plength (list* 6 6 6 6 6 6))
+       (plength (list* 7 7 7 7 7 7 7))
+       (plength (list* 8 8 8 8 8 8 8 8))
+       (plength (list* 9 9 9 9 9 9 9 9 9))))
+  :ok :ok :ok
+  :ok :ok :ok
+  :ok :ok :ok)
+
+(deftest lastcar.1
+    (let ((l1 (list 1))
+          (l2 (list 1 2)))
+      (list (lastcar l1)
+            (lastcar l2)))
+  (1 2))
+
+(deftest lastcar.error.2
+    (handler-case
+        (progn
+          (lastcar (circular-list 1 2 3))
+          nil)
+      (error ()
+        t))
+  t)
+
+(deftest setf-lastcar.1
+    (let ((l (list 1 2 3 4)))
+      (values (lastcar l)
+              (progn
+                (setf (lastcar l) 42)
+                (lastcar l))))
+  4
+  42)
+
+(deftest setf-lastcar.2
+    (let ((l (circular-list 1 2 3)))
+      (multiple-value-bind (res err)
+          (ignore-errors (setf (lastcar l) 4))
+        (typep err 'type-error)))
+  t)
+
+(deftest make-circular-list.1
+    (let ((l (make-circular-list 3 :initial-element :x)))
+      (setf (car l) :y)
+      (list (eq l (nthcdr 3 l))
+            (first l)
+            (second l)
+            (third l)
+            (fourth l)))
+  (t :y :x :x :y))
+
+(deftest circular-list.type.1
+    (let* ((l1 (list 1 2 3))
+           (l2 (circular-list 1 2 3))
+           (l3 (list* 1 2 3 l2)))
+      (list (typep l1 'circular-list)
+            (typep l2 'circular-list)
+            (typep l3 'circular-list)))
+  (nil t t))
+
+(deftest ensure-list.1
+    (let ((x (list 1))
+          (y 2))
+      (list (ensure-list x)
+            (ensure-list y)))
+  ((1) (2)))
+
+(deftest ensure-cons.1
+    (let ((x (cons 1 2))
+          (y nil)
+          (z "foo"))
+      (values (ensure-cons x)
+              (ensure-cons y)
+              (ensure-cons z)))
+  (1 . 2)
+  (nil)
+  ("foo"))
+
+(deftest setp.1
+    (setp '(1))
+  t)
+
+(deftest setp.2
+    (setp nil)
+  t)
+
+(deftest setp.3
+    (setp "foo")
+  nil)
+
+(deftest setp.4
+    (setp '(1 2 3 1))
+  nil)
+
+(deftest setp.5
+    (setp '(1 2 3))
+  t)
+
+(deftest setp.6
+    (setp '(a :a))
+  t)
+
+(deftest setp.7
+    (setp '(a :a) :key 'character)
+  nil)
+
+(deftest setp.8
+    (setp '(a :a) :key 'character :test (constantly nil))
+  t)
+
+(deftest set-equal.1
+    (set-equal '(1 2 3) '(3 1 2))
+  t)
+
+(deftest set-equal.2
+    (set-equal '("Xa") '("Xb")
+               :test (lambda (a b) (eql (char a 0) (char b 0))))
+  t)
+
+(deftest set-equal.3
+    (set-equal '(1 2) '(4 2))
+  nil)
+
+(deftest set-equal.4
+    (set-equal '(a b c) '(:a :b :c) :key 'string :test 'equal)
+  t)
+
+(deftest set-equal.5
+    (set-equal '(a d c) '(:a :b :c) :key 'string :test 'equal)
+  nil)
+
+(deftest set-equal.6
+    (set-equal '(a b c) '(a b c d))
+  nil)
+
+(deftest map-product.1
+    (map-product 'cons '(2 3) '(1 4))
+  ((2 . 1) (2 . 4) (3 . 1) (3 . 4)))
+
+(deftest map-product.2
+    (map-product #'cons '(2 3) '(1 4))
+  ((2 . 1) (2 . 4) (3 . 1) (3 . 4)))
+
+(deftest flatten.1
+    (flatten '((1) 2 (((3 4))) ((((5)) 6)) 7))
+  (1 2 3 4 5 6 7))
+
+(deftest remove-from-plist.1
+    (let ((orig '(a 1 b 2 c 3 d 4)))
+      (list (remove-from-plist orig 'a 'c)
+            (remove-from-plist orig 'b 'd)
+            (remove-from-plist orig 'b)
+            (remove-from-plist orig 'a)
+            (remove-from-plist orig 'd 42 "zot")
+            (remove-from-plist orig 'a 'b 'c 'd)
+            (remove-from-plist orig 'a 'b 'c 'd 'x)
+            (equal orig '(a 1 b 2 c 3 d 4))))
+  ((b 2 d 4)
+   (a 1 c 3)
+   (a 1 c 3 d 4)
+   (b 2 c 3 d 4)
+   (a 1 b 2 c 3)
+   nil
+   nil
+   t))
+
+(deftest delete-from-plist.1
+    (let ((orig '(a 1 b 2 c 3 d 4 d 5)))
+      (list (delete-from-plist (copy-list orig) 'a 'c)
+            (delete-from-plist (copy-list orig) 'b 'd)
+            (delete-from-plist (copy-list orig) 'b)
+            (delete-from-plist (copy-list orig) 'a)
+            (delete-from-plist (copy-list orig) 'd 42 "zot")
+            (delete-from-plist (copy-list orig) 'a 'b 'c 'd)
+            (delete-from-plist (copy-list orig) 'a 'b 'c 'd 'x)
+            (equal orig (delete-from-plist orig))
+            (eq orig (delete-from-plist orig))))
+  ((b 2 d 4 d 5)
+   (a 1 c 3)
+   (a 1 c 3 d 4 d 5)
+   (b 2 c 3 d 4 d 5)
+   (a 1 b 2 c 3)
+   nil
+   nil
+   t
+   t))
+
+(deftest mappend.1
+    (mappend (compose 'list '*) '(1 2 3) '(1 2 3))
+  (1 4 9))
+
+(deftest assoc-value.1
+    (let ((key1 '(complex key))
+          (key2 'simple-key)
+          (alist '())
+          (result '()))
+      (push 1 (assoc-value alist key1 :test #'equal))
+      (push 2 (assoc-value alist key1 :test 'equal))
+      (push 42 (assoc-value alist key2))
+      (push 43 (assoc-value alist key2 :test 'eq))
+      (push (assoc-value alist key1 :test #'equal) result)
+      (push (assoc-value alist key2) result)
+
+      (push 'very (rassoc-value alist (list 2 1) :test #'equal))
+      (push (cdr (assoc '(very complex key) alist :test #'equal)) result)
+      result)
+  ((2 1) (43 42) (2 1)))
+
+;;;; Numbers
+
+(deftest clamp.1
+    (list (clamp 1.5 1 2)
+          (clamp 2.0 1 2)
+          (clamp 1.0 1 2)
+          (clamp 3 1 2)
+          (clamp 0 1 2))
+  (1.5 2.0 1.0 2 1))
+
+(deftest gaussian-random.1
+    (let ((min -0.2)
+          (max +0.2))
+      (multiple-value-bind (g1 g2)
+          (gaussian-random min max)
+        (values (<= min g1 max)
+                (<= min g2 max)
+                (/= g1 g2) ;uh
+                )))
+  t
+  t
+  t)
+
+#+sbcl
+(deftest gaussian-random.2
+    (handler-case
+        (sb-ext:with-timeout 2
+          (progn
+            (loop
+              :repeat 10000
+              :do (gaussian-random 0 nil))
+            'done))
+      (sb-ext:timeout ()
+        'timed-out))
+  done)
+
+(deftest iota.1
+    (iota 3)
+  (0 1 2))
+
+(deftest iota.2
+    (iota 3 :start 0.0d0)
+  (0.0d0 1.0d0 2.0d0))
+
+(deftest iota.3
+    (iota 3 :start 2 :step 3.0)
+  (2.0 5.0 8.0))
+
+(deftest map-iota.1
+    (let (all)
+      (declare (notinline map-iota))
+      (values (map-iota (lambda (x) (push x all))
+                        3
+                        :start 2
+                        :step 1.1d0)
+              all))
+  3
+  (4.2d0 3.1d0 2.0d0))
+
+(deftest lerp.1
+    (lerp 0.5 1 2)
+  1.5)
+
+(deftest lerp.2
+    (lerp 0.1 1 2)
+  1.1)
+
+(deftest lerp.3
+    (lerp 0.1 4 25)
+  6.1)
+
+(deftest mean.1
+    (mean '(1 2 3))
+  2)
+
+(deftest mean.2
+    (mean '(1 2 3 4))
+  5/2)
+
+(deftest mean.3
+    (mean '(1 2 10))
+  13/3)
+
+(deftest median.1
+    (median '(100 0 99 1 98 2 97))
+  97)
+
+(deftest median.2
+    (median '(100 0 99 1 98 2 97 96))
+  193/2)
+
+(deftest variance.1
+    (variance (list 1 2 3))
+  2/3)
+
+(deftest standard-deviation.1
+    (< 0 (standard-deviation (list 1 2 3)) 1)
+  t)
+
+(deftest maxf.1
+    (let ((x 1))
+      (maxf x 2)
+      x)
+  2)
+
+(deftest maxf.2
+    (let ((x 1))
+      (maxf x 0)
+      x)
+  1)
+
+(deftest maxf.3
+    (let ((x 1)
+          (c 0))
+      (maxf x (incf c))
+      (list x c))
+  (1 1))
+
+(deftest maxf.4
+    (let ((xv (vector 0 0 0))
+          (p 0))
+      (maxf (svref xv (incf p)) (incf p))
+      (list p xv))
+  (2 #(0 2 0)))
+
+(deftest minf.1
+    (let ((y 1))
+      (minf y 0)
+      y)
+  0)
+
+(deftest minf.2
+    (let ((xv (vector 10 10 10))
+          (p 0))
+      (minf (svref xv (incf p)) (incf p))
+      (list p xv))
+  (2 #(10 2 10)))
+
+(deftest subfactorial.1
+    (mapcar #'subfactorial (iota 22))
+  (1
+   0
+   1
+   2
+   9
+   44
+   265
+   1854
+   14833
+   133496
+   1334961
+   14684570
+   176214841
+   2290792932
+   32071101049
+   481066515734
+   7697064251745
+   130850092279664
+   2355301661033953
+   44750731559645106
+   895014631192902121
+   18795307255050944540))
+
+;;;; Arrays
+
+#+nil
+(deftest array-index.type)
+
+#+nil
+(deftest copy-array)
+
+;;;; Sequences
+
+(deftest rotate.1
+    (list (rotate (list 1 2 3) 0)
+          (rotate (list 1 2 3) 1)
+          (rotate (list 1 2 3) 2)
+          (rotate (list 1 2 3) 3)
+          (rotate (list 1 2 3) 4))
+  ((1 2 3)
+   (3 1 2)
+   (2 3 1)
+   (1 2 3)
+   (3 1 2)))
+
+(deftest rotate.2
+    (list (rotate (vector 1 2 3 4) 0)
+          (rotate (vector 1 2 3 4))
+          (rotate (vector 1 2 3 4) 2)
+          (rotate (vector 1 2 3 4) 3)
+          (rotate (vector 1 2 3 4) 4)
+          (rotate (vector 1 2 3 4) 5))
+  (#(1 2 3 4)
+    #(4 1 2 3)
+    #(3 4 1 2)
+    #(2 3 4 1)
+    #(1 2 3 4)
+    #(4 1 2 3)))
+
+(deftest rotate.3
+    (list (rotate (list 1 2 3) 0)
+          (rotate (list 1 2 3) -1)
+          (rotate (list 1 2 3) -2)
+          (rotate (list 1 2 3) -3)
+          (rotate (list 1 2 3) -4))
+  ((1 2 3)
+   (2 3 1)
+   (3 1 2)
+   (1 2 3)
+   (2 3 1)))
+
+(deftest rotate.4
+    (list (rotate (vector 1 2 3 4) 0)
+          (rotate (vector 1 2 3 4) -1)
+          (rotate (vector 1 2 3 4) -2)
+          (rotate (vector 1 2 3 4) -3)
+          (rotate (vector 1 2 3 4) -4)
+          (rotate (vector 1 2 3 4) -5))
+  (#(1 2 3 4)
+   #(2 3 4 1)
+   #(3 4 1 2)
+   #(4 1 2 3)
+   #(1 2 3 4)
+   #(2 3 4 1)))
+
+(deftest rotate.5
+    (values (rotate (list 1) 17)
+            (rotate (list 1) -5))
+  (1)
+  (1))
+
+(deftest shuffle.1
+    (let ((s (shuffle (iota 100))))
+      (list (equal s (iota 100))
+            (every (lambda (x)
+                     (member x s))
+                   (iota 100))
+            (every (lambda (x)
+                     (typep x '(integer 0 99)))
+                   s)))
+  (nil t t))
+
+(deftest shuffle.2
+    (let ((s (shuffle (coerce (iota 100) 'vector))))
+      (list (equal s (coerce (iota 100) 'vector))
+            (every (lambda (x)
+                     (find x s))
+                   (iota 100))
+            (every (lambda (x)
+                     (typep x '(integer 0 99)))
+                   s)))
+  (nil t t))
+
+(deftest shuffle.3
+    (let* ((orig (coerce (iota 21) 'vector))
+           (copy (copy-seq orig)))
+      (shuffle copy :start 10 :end 15)
+      (list (every #'eql (subseq copy 0 10) (subseq orig 0 10))
+            (every #'eql (subseq copy 15) (subseq orig 15))))
+  (t t))
+
+(deftest random-elt.1
+    (let ((s1 #(1 2 3 4))
+          (s2 '(1 2 3 4)))
+      (list (dotimes (i 1000 nil)
+              (unless (member (random-elt s1) s2)
+                (return nil))
+              (when (/= (random-elt s1) (random-elt s1))
+                (return t)))
+            (dotimes (i 1000 nil)
+              (unless (member (random-elt s2) s2)
+                (return nil))
+              (when (/= (random-elt s2) (random-elt s2))
+                (return t)))))
+  (t t))
+
+(deftest removef.1
+    (let* ((x '(1 2 3))
+           (x* x)
+           (y #(1 2 3))
+           (y* y))
+      (removef x 1)
+      (removef y 3)
+      (list x x* y y*))
+  ((2 3)
+   (1 2 3)
+   #(1 2)
+   #(1 2 3)))
+
+(deftest deletef.1
+    (let* ((x (list 1 2 3))
+           (x* x)
+           (y (vector 1 2 3)))
+      (deletef x 2)
+      (deletef y 1)
+      (list x x* y))
+  ((1 3)
+   (1 3)
+   #(2 3)))
+
+(deftest map-permutations.1
+    (let ((seq (list 1 2 3))
+          (seen nil)
+          (ok t))
+      (map-permutations (lambda (s)
+                          (unless (set-equal s seq)
+                            (setf ok nil))
+                          (when (member s seen :test 'equal)
+                            (setf ok nil))
+                          (push s seen))
+                        seq
+                        :copy t)
+      (values ok (length seen)))
+  t
+  6)
+
+(deftest proper-sequence.type.1
+    (mapcar (lambda (x)
+              (typep x 'proper-sequence))
+            (list (list 1 2 3)
+                  (vector 1 2 3)
+                  #2a((1 2) (3 4))
+                  (circular-list 1 2 3 4)))
+  (t t nil nil))
+
+(deftest emptyp.1
+    (mapcar #'emptyp
+            (list (list 1)
+                  (circular-list 1)
+                  nil
+                  (vector)
+                  (vector 1)))
+  (nil nil t t nil))
+
+(deftest sequence-of-length-p.1
+    (mapcar #'sequence-of-length-p
+            (list nil
+                  #()
+                  (list 1)
+                  (vector 1)
+                  (list 1 2)
+                  (vector 1 2)
+                  (list 1 2)
+                  (vector 1 2)
+                  (list 1 2)
+                  (vector 1 2))
+            (list 0
+                  0
+                  1
+                  1
+                  2
+                  2
+                  1
+                  1
+                  4
+                  4))
+  (t t t t t t nil nil nil nil))
+
+(deftest length=.1
+    (mapcar #'length=
+            (list nil
+                  #()
+                  (list 1)
+                  (vector 1)
+                  (list 1 2)
+                  (vector 1 2)
+                  (list 1 2)
+                  (vector 1 2)
+                  (list 1 2)
+                  (vector 1 2))
+            (list 0
+                  0
+                  1
+                  1
+                  2
+                  2
+                  1
+                  1
+                  4
+                  4))
+  (t t t t t t nil nil nil nil))
+
+(deftest length=.2
+    ;; test the compiler macro
+    (macrolet ((x (&rest args)
+                 (funcall
+                  (compile nil
+                           `(lambda ()
+                              (length= ,@args))))))
+      (list (x 2 '(1 2))
+            (x '(1 2) '(3 4))
+            (x '(1 2) 2)
+            (x '(1 2) 2 '(3 4))
+            (x 1 2 3)))
+  (t t t t nil))
+
+(deftest copy-sequence.1
+    (let ((l (list 1 2 3))
+          (v (vector #\a #\b #\c)))
+      (declare (notinline copy-sequence))
+      (let ((l.list (copy-sequence 'list l))
+            (l.vector (copy-sequence 'vector l))
+            (l.spec-v (copy-sequence '(vector fixnum) l))
+            (v.vector (copy-sequence 'vector v))
+            (v.list (copy-sequence 'list v))
+            (v.string (copy-sequence 'string v)))
+        (list (member l (list l.list l.vector l.spec-v))
+              (member v (list v.vector v.list v.string))
+              (equal l.list l)
+              (equalp l.vector #(1 2 3))
+              (type= (upgraded-array-element-type 'fixnum)
+                     (array-element-type l.spec-v))
+              (equalp v.vector v)
+              (equal v.list '(#\a #\b #\c))
+              (equal "abc" v.string))))
+  (nil nil t t t t t t))
+
+(deftest first-elt.1
+    (mapcar #'first-elt
+            (list (list 1 2 3)
+                  "abc"
+                  (vector :a :b :c)))
+  (1 #\a :a))
+
+(deftest first-elt.error.1
+    (mapcar (lambda (x)
+              (handler-case
+                  (first-elt x)
+                (type-error ()
+                  :type-error)))
+            (list nil
+                  #()
+                  12
+                  :zot))
+  (:type-error
+   :type-error
+   :type-error
+   :type-error))
+
+(deftest setf-first-elt.1
+    (let ((l (list 1 2 3))
+          (s (copy-seq "foobar"))
+          (v (vector :a :b :c)))
+      (setf (first-elt l) -1
+            (first-elt s) #\x
+            (first-elt v) 'zot)
+      (values l s v))
+  (-1 2 3)
+  "xoobar"
+  #(zot :b :c))
+
+(deftest setf-first-elt.error.1
+    (let ((l 'foo))
+      (multiple-value-bind (res err)
+          (ignore-errors (setf (first-elt l) 4))
+        (typep err 'type-error)))
+  t)
+
+(deftest last-elt.1
+    (mapcar #'last-elt
+            (list (list 1 2 3)
+                  (vector :a :b :c)
+                  "FOOBAR"
+                  #*001
+                  #*010))
+  (3 :c #\R 1 0))
+
+(deftest last-elt.error.1
+    (mapcar (lambda (x)
+              (handler-case
+                  (last-elt x)
+                (type-error ()
+                  :type-error)))
+            (list nil
+                  #()
+                  12
+                  :zot
+                  (circular-list 1 2 3)
+                  (list* 1 2 3 (circular-list 4 5))))
+  (:type-error
+   :type-error
+   :type-error
+   :type-error
+   :type-error
+   :type-error))
+
+(deftest setf-last-elt.1
+    (let ((l (list 1 2 3))
+          (s (copy-seq "foobar"))
+          (b (copy-seq #*010101001)))
+      (setf (last-elt l) '???
+            (last-elt s) #\?
+            (last-elt b) 0)
+      (values l s b))
+  (1 2 ???)
+  "fooba?"
+  #*010101000)
+
+(deftest setf-last-elt.error.1
+    (handler-case
+        (setf (last-elt 'foo) 13)
+      (type-error ()
+        :type-error))
+  :type-error)
+
+(deftest starts-with.1
+    (list (starts-with 1 '(1 2 3))
+          (starts-with 1 #(1 2 3))
+          (starts-with #\x "xyz")
+          (starts-with 2 '(1 2 3))
+          (starts-with 3 #(1 2 3))
+          (starts-with 1 1)
+          (starts-with nil nil))
+  (t t t nil nil nil nil))
+
+(deftest starts-with.2
+    (values (starts-with 1 '(-1 2 3) :key '-)
+            (starts-with "foo" '("foo" "bar") :test 'equal)
+            (starts-with "f" '(#\f) :key 'string :test 'equal)
+            (starts-with -1 '(0 1 2) :key #'1+)
+            (starts-with "zot" '("ZOT") :test 'equal))
+  t
+  t
+  t
+  nil
+  nil)
+
+(deftest ends-with.1
+    (list (ends-with 3 '(1 2 3))
+          (ends-with 3 #(1 2 3))
+          (ends-with #\z "xyz")
+          (ends-with 2 '(1 2 3))
+          (ends-with 1 #(1 2 3))
+          (ends-with 1 1)
+          (ends-with nil nil))
+  (t t t nil nil nil nil))
+
+(deftest ends-with.2
+    (values (ends-with 2 '(0 13 1) :key '1+)
+            (ends-with "foo" (vector "bar" "foo") :test 'equal)
+            (ends-with "X" (vector 1 2 #\X) :key 'string :test 'equal)
+            (ends-with "foo" "foo" :test 'equal))
+  t
+  t
+  t
+  nil)
+
+(deftest ends-with.error.1
+    (handler-case
+        (ends-with 3 (circular-list 3 3 3 1 3 3))
+      (type-error ()
+        :type-error))
+  :type-error)
+
+(deftest sequences.passing-improper-lists
+    (macrolet ((signals-error-p (form)
+                 `(handler-case
+                      (progn ,form nil)
+                    (type-error (e)
+                      t)))
+               (cut (fn &rest args)
+                 (with-gensyms (arg)
+                   (print`(lambda (,arg)
+                       (apply ,fn (list ,@(substitute arg '_ args))))))))
+      (let ((circular-list (make-circular-list 5 :initial-element :foo))
+            (dotted-list (list* 'a 'b 'c 'd)))
+        (loop for nth from 0
+              for fn in (list
+                         (cut #'lastcar _)
+                         (cut #'rotate _ 3)
+                         (cut #'rotate _ -3)
+                         (cut #'shuffle _)
+                         (cut #'random-elt _)
+                         (cut #'last-elt _)
+                         (cut #'ends-with :foo _))
+              nconcing
+                 (let ((on-circular-p (signals-error-p (funcall fn circular-list)))
+                       (on-dotted-p (signals-error-p (funcall fn dotted-list))))
+                   (when (or (not on-circular-p) (not on-dotted-p))
+                     (append
+                      (unless on-circular-p
+                        (let ((*print-circle* t))
+                          (list
+                           (format nil
+                                   "No appropriate error signalled when passing ~S to ~Ath entry."
+                                   circular-list nth))))
+                      (unless on-dotted-p
+                        (list
+                         (format nil
+                                 "No appropriate error signalled when passing ~S to ~Ath entry."
+                                 dotted-list nth)))))))))
+  nil)
+
+;;;; IO
+
+(deftest read-stream-content-into-string.1
+    (values (with-input-from-string (stream "foo bar")
+              (read-stream-content-into-string stream))
+            (with-input-from-string (stream "foo bar")
+              (read-stream-content-into-string stream :buffer-size 1))
+            (with-input-from-string (stream "foo bar")
+              (read-stream-content-into-string stream :buffer-size 6))
+            (with-input-from-string (stream "foo bar")
+              (read-stream-content-into-string stream :buffer-size 7)))
+  "foo bar"
+  "foo bar"
+  "foo bar"
+  "foo bar")
+
+(deftest read-stream-content-into-string.2
+    (handler-case
+        (let ((stream (make-broadcast-stream)))
+          (read-stream-content-into-string stream :buffer-size 0))
+      (type-error ()
+        :type-error))
+  :type-error)
+
+#+(or)
+(defvar *octets*
+  (map '(simple-array (unsigned-byte 8) (7)) #'char-code "foo bar"))
+
+#+(or)
+(deftest read-stream-content-into-byte-vector.1
+    (values (with-input-from-byte-vector (stream *octets*)
+              (read-stream-content-into-byte-vector stream))
+            (with-input-from-byte-vector (stream *octets*)
+              (read-stream-content-into-byte-vector stream :initial-size 1))
+            (with-input-from-byte-vector (stream *octets*)
+              (read-stream-content-into-byte-vector stream 'alexandria::%length 6))
+            (with-input-from-byte-vector (stream *octets*)
+              (read-stream-content-into-byte-vector stream 'alexandria::%length 3)))
+  *octets*
+  *octets*
+  *octets*
+  (subseq *octets* 0 3))
+
+(deftest read-stream-content-into-byte-vector.2
+    (handler-case
+        (let ((stream (make-broadcast-stream)))
+          (read-stream-content-into-byte-vector stream :initial-size 0))
+      (type-error ()
+        :type-error))
+  :type-error)
+
+;;;; Macros
+
+(deftest with-unique-names.1
+    (let ((*gensym-counter* 0))
+      (let ((syms (with-unique-names (foo bar quux)
+                    (list foo bar quux))))
+        (list (find-if #'symbol-package syms)
+              (equal '("FOO0" "BAR1" "QUUX2")
+                     (mapcar #'symbol-name syms)))))
+  (nil t))
+
+(deftest with-unique-names.2
+    (let ((*gensym-counter* 0))
+      (let ((syms (with-unique-names ((foo "_foo_") (bar -bar-) (quux #\q))
+                    (list foo bar quux))))
+        (list (find-if #'symbol-package syms)
+              (equal '("_foo_0" "-BAR-1" "q2")
+                     (mapcar #'symbol-name syms)))))
+  (nil t))
+
+(deftest with-unique-names.3
+    (let ((*gensym-counter* 0))
+      (multiple-value-bind (res err)
+          (ignore-errors
+            (eval
+             '(let ((syms
+                     (with-unique-names ((foo "_foo_") (bar -bar-) (quux 42))
+                       (list foo bar quux))))
+               (list (find-if #'symbol-package syms)
+                (equal '("_foo_0" "-BAR-1" "q2")
+                 (mapcar #'symbol-name syms))))))
+        (errorp err)))
+  t)
+
+(deftest once-only.1
+    (macrolet ((cons1.good (x)
+                 (once-only (x)
+                   `(cons ,x ,x)))
+               (cons1.bad (x)
+                 `(cons ,x ,x)))
+      (let ((y 0))
+        (list (cons1.good (incf y))
+              y
+              (cons1.bad (incf y))
+              y)))
+  ((1 . 1) 1 (2 . 3) 3))
+
+(deftest once-only.2
+    (macrolet ((cons1 (x)
+                 (once-only ((y x))
+                   `(cons ,y ,y))))
+      (let ((z 0))
+        (list (cons1 (incf z))
+              z
+              (cons1 (incf z)))))
+  ((1 . 1) 1 (2 . 2)))
+
+(deftest parse-body.1
+    (parse-body '("doc" "body") :documentation t)
+  ("body")
+  nil
+  "doc")
+
+(deftest parse-body.2
+    (parse-body '("body") :documentation t)
+  ("body")
+  nil
+  nil)
+
+(deftest parse-body.3
+    (parse-body '("doc" "body"))
+  ("doc" "body")
+  nil
+  nil)
+
+(deftest parse-body.4
+    (parse-body '((declare (foo)) "doc" (declare (bar)) body) :documentation t)
+  (body)
+  ((declare (foo)) (declare (bar)))
+  "doc")
+
+(deftest parse-body.5
+    (parse-body '((declare (foo)) "doc" (declare (bar)) body))
+  ("doc" (declare (bar)) body)
+  ((declare (foo)))
+  nil)
+
+(deftest parse-body.6
+    (multiple-value-bind (res err)
+        (ignore-errors
+          (parse-body '("foo" "bar" "quux")
+                      :documentation t))
+      (errorp err))
+  t)
+
+;;;; Symbols
+
+(deftest ensure-symbol.1
+    (ensure-symbol :cons :cl)
+  cons
+  :external)
+
+(deftest ensure-symbol.2
+    (ensure-symbol "CONS" :alexandria)
+  cons
+  :inherited)
+
+(deftest ensure-symbol.3
+    (ensure-symbol 'foo :keyword)
+  :foo
+  :external)
+
+(deftest ensure-symbol.4
+    (ensure-symbol #\* :alexandria)
+  *
+  :inherited)
+
+(deftest format-symbol.1
+    (let ((s (format-symbol nil '#:x-~d 13)))
+      (list (symbol-package s)
+            (string= (string '#:x-13) (symbol-name s))))
+  (nil t))
+
+(deftest format-symbol.2
+    (format-symbol :keyword '#:sym-~a (string :bolic))
+  :sym-bolic)
+
+(deftest format-symbol.3
+    (let ((*package* (find-package :cl)))
+      (format-symbol t '#:find-~a (string 'package)))
+  find-package)
+
+(deftest make-keyword.1
+    (list (make-keyword 'zot)
+          (make-keyword "FOO")
+          (make-keyword #\Q))
+  (:zot :foo :q))
+
+(deftest make-gensym-list.1
+    (let ((*gensym-counter* 0))
+      (let ((syms (make-gensym-list 3 "FOO")))
+        (list (find-if 'symbol-package syms)
+              (equal '("FOO0" "FOO1" "FOO2")
+                     (mapcar 'symbol-name syms)))))
+  (nil t))
+
+(deftest make-gensym-list.2
+    (let ((*gensym-counter* 0))
+      (let ((syms (make-gensym-list 3)))
+        (list (find-if 'symbol-package syms)
+              (equal '("G0" "G1" "G2")
+                     (mapcar 'symbol-name syms)))))
+  (nil t))
+
+;;;; Type-system
+
+(deftest of-type.1
+    (locally
+        (declare (notinline of-type))
+    (let ((f (of-type 'string)))
+      (list (funcall f "foo")
+            (funcall f 'bar))))
+  (t nil))
+
+(deftest type=.1
+    (type= 'string 'string)
+  t
+  t)
+
+(deftest type=.2
+    (type= 'list '(or null cons))
+  t
+  t)
+
+(deftest type=.3
+    (type= 'null '(and symbol list))
+  t
+  t)
+
+(deftest type=.4
+    (type= 'string '(satisfies emptyp))
+  nil
+  nil)
+
+(deftest type=.5
+    (type= 'string 'list)
+  nil
+  t)
+
+(macrolet
+    ((test (type numbers)
+       `(deftest ,(format-symbol t '#:cdr5.~a (string type))
+            (let ((numbers ,numbers))
+              (values (mapcar (of-type ',(format-symbol t '#:negative-~a (string type))) numbers)
+                      (mapcar (of-type ',(format-symbol t '#:non-positive-~a (string type))) numbers)
+                      (mapcar (of-type ',(format-symbol t '#:non-negative-~a (string type))) numbers)
+                      (mapcar (of-type ',(format-symbol t '#:positive-~a (string type))) numbers)))
+          (t t t nil nil nil nil)
+          (t t t t nil nil nil)
+          (nil nil nil t t t t)
+          (nil nil nil nil t t t))))
+  (test fixnum       (list most-negative-fixnum       -42      -1     0     1     42      most-positive-fixnum))
+  (test integer      (list (1- most-negative-fixnum)  -42      -1     0     1     42      (1+ most-positive-fixnum)))
+  (test rational     (list (1- most-negative-fixnum)  -42/13   -1     0     1     42/13   (1+ most-positive-fixnum)))
+  (test real         (list most-negative-long-float   -42/13   -1     0     1     42/13   most-positive-long-float))
+  (test float        (list most-negative-short-float  -42.02   -1.0   0.0   1.0   42.02   most-positive-short-float))
+  (test short-float  (list most-negative-short-float  -42.02s0 -1.0s0 0.0s0 1.0s0 42.02s0 most-positive-short-float))
+  (test single-float (list most-negative-single-float -42.02f0 -1.0f0 0.0f0 1.0f0 42.02f0 most-positive-single-float))
+  (test double-float (list most-negative-double-float -42.02d0 -1.0d0 0.0d0 1.0d0 42.02d0 most-positive-double-float))
+  (test long-float   (list most-negative-long-float   -42.02l0 -1.0l0 0.0l0 1.0l0 42.02l0 most-positive-long-float)))
+
+;;;; Bindings
+
+(declaim (notinline opaque))
+(defun opaque (x)
+  x)
+
+(deftest if-let.1
+    (if-let (x (opaque :ok))
+            x
+            :bad)
+  :ok)
+
+(deftest if-let.2
+    (if-let (x (opaque nil))
+            :bad
+            (and (not x) :ok))
+  :ok)
+
+(deftest if-let.3
+    (let ((x 1))
+      (if-let ((x 2)
+               (y x))
+              (+ x y)
+              :oops))
+  3)
+
+(deftest if-let.4
+    (if-let ((x 1)
+             (y nil))
+            :oops
+            (and (not y) x))
+  1)
+
+(deftest if-let.5
+    (if-let (x)
+            :oops
+            (not x))
+  t)
+
+(deftest if-let.error.1
+    (handler-case
+        (eval '(if-let x
+                :oops
+                :oops))
+      (type-error ()
+        :type-error))
+  :type-error)
+
+(deftest when-let.1
+    (when-let (x (opaque :ok))
+      (setf x (cons x x))
+      x)
+  (:ok . :ok))
+
+(deftest when-let.2
+    (when-let ((x 1)
+               (y nil)
+               (z 3))
+      :oops)
+  nil)
+
+(deftest when-let.3
+    (let ((x 1))
+      (when-let ((x 2)
+                 (y x))
+        (+ x y)))
+  3)
+
+(deftest when-let.error.1
+    (handler-case
+        (eval '(when-let x :oops))
+      (type-error ()
+        :type-error))
+  :type-error)
+
+(deftest when-let*.1
+    (let ((x 1))
+      (when-let* ((x 2)
+                  (y x))
+        (+ x y)))
+  4)
+
+(deftest when-let*.2
+    (let ((y 1))
+      (when-let* (x y)
+        (1+ x)))
+  2)
+
+(deftest when-let*.3
+    (when-let* ((x t)
+                (y (consp x))
+                (z (error "OOPS")))
+      t)
+  nil)
+
+(deftest when-let*.error.1
+    (handler-case
+        (eval '(when-let* x :oops))
+      (type-error ()
+        :type-error))
+  :type-error)
+
+(deftest doplist.1
+    (let (keys values)
+      (doplist (k v '(a 1 b 2 c 3) (values t (reverse keys) (reverse values) k v))
+        (push k keys)
+        (push v values)))
+  t
+  (a b c)
+  (1 2 3)
+  nil
+  nil)
+
+(deftest count-permutations.1
+    (values (count-permutations 31 7)
+            (count-permutations 1 1)
+            (count-permutations 2 1)
+            (count-permutations 2 2)
+            (count-permutations 3 2)
+            (count-permutations 3 1))
+  13253058000
+  1
+  2
+  2
+  6
+  3)
+
+(deftest binomial-coefficient.1
+    (alexandria:binomial-coefficient 1239 139)
+  28794902202288970200771694600561826718847179309929858835480006683522184441358211423695124921058123706380656375919763349913245306834194782172712255592710204598527867804110129489943080460154)
+
+;; Exercise bignum case (at least on x86).
+(deftest binomial-coefficient.2
+    (alexandria:binomial-coefficient 2000000000000 20)
+  430998041177272843950422879590338454856322722740402365741730748431530623813012487773080486408378680853987520854296499536311275320016878730999689934464711239072435565454954447356845336730100919970769793030177499999999900000000000)
+
+(deftest copy-stream.1
+    (let ((data "sdkfjhsakfh weior763495ewofhsdfk sdfadlkfjhsadf woif sdlkjfhslkdfh sdklfjh"))
+      (values (equal data
+                     (with-input-from-string (in data)
+                       (with-output-to-string (out)
+                         (alexandria:copy-stream in out))))
+              (equal (subseq data 10 20)
+                     (with-input-from-string (in data)
+                       (with-output-to-string (out)
+                         (alexandria:copy-stream in out :start 10 :end 20))))
+              (equal (subseq data 10)
+                     (with-input-from-string (in data)
+                       (with-output-to-string (out)
+                         (alexandria:copy-stream in out :start 10))))
+              (equal (subseq data 0 20)
+                     (with-input-from-string (in data)
+                       (with-output-to-string (out)
+                         (alexandria:copy-stream in out :end 20))))))
+  t
+  t
+  t
+  t)
+
+(deftest extremum.1
+    (let ((n 0))
+      (dotimes (i 10)
+       (let ((data (shuffle (coerce (iota 10000 :start i) 'vector)))
+             (ok t))
+         (unless (eql i (extremum data #'<))
+           (setf ok nil))
+         (unless (eql i (extremum (coerce data 'list) #'<))
+           (setf ok nil))
+         (unless (eql (+ 9999 i) (extremum data #'>))
+           (setf ok nil))
+         (unless (eql (+ 9999 i) (extremum (coerce  data 'list) #'>))
+           (setf ok nil))
+         (when ok
+           (incf n))))
+      (when (eql 10 (extremum #(100 1 10 1000) #'> :start 1 :end 3))
+        (incf n))
+      (when (eql -1000 (extremum #(100 1 10 -1000) #'> :key 'abs))
+        (incf n))
+      (when (eq nil (extremum "" (lambda (a b) (error "wtf? ~S, ~S" a b))))
+        (incf n))
+      n)
+  13)
+
+(deftest starts-with-subseq.string
+    (starts-with-subseq "f" "foo" :return-suffix t)
+  t
+  "oo")
+
+(deftest starts-with-subseq.vector
+    (starts-with-subseq #(1) #(1 2 3) :return-suffix t)
+  t
+  #(2 3))
+
+(deftest starts-with-subseq.list
+    (starts-with-subseq '(1) '(1 2 3) :return-suffix t)
+  t
+  (2 3))
+
+(deftest starts-with-subseq.start1
+    (starts-with-subseq "foo" "oop" :start1 1)
+  t
+  nil)
+
+(deftest starts-with-subseq.start2
+    (starts-with-subseq "foo" "xfoop" :start2 1)
+  t
+  nil)
+
+(deftest format-symbol.print-case-bound
+    (let ((upper (intern "FOO-BAR"))
+          (lower (intern "foo-bar"))
+          (*print-escape* nil))
+      (values
+       (let ((*print-case* :downcase))
+         (and (eq upper (format-symbol t "~A" upper))
+               (eq lower (format-symbol t "~A" lower))))
+       (let ((*print-case* :upcase))
+         (and (eq upper (format-symbol t "~A" upper))
+               (eq lower (format-symbol t "~A" lower))))
+       (let ((*print-case* :capitalize))
+         (and (eq upper (format-symbol t "~A" upper))
+              (eq lower (format-symbol t "~A" lower))))))
+  t
+  t
+  t)
+
+(deftest iota.fp-start-and-complex-integer-step
+    (equal '(#C(0.0 0.0) #C(0.0 2.0) #C(0.0 4.0))
+           (iota 3 :start 0.0 :step #C(0 2)))
+  t)
+
+(deftest parse-ordinary-lambda-list.1
+    (multiple-value-bind (req opt rest keys allowp aux keyp)
+        (parse-ordinary-lambda-list '(a b c
+                                      &optional o1 (o2 42) (o3 42 o3-supplied?)
+                                      &key (k1) ((:key k2)) (k3 42 k3-supplied?))
+                                    :normalize t)
+      (and (equal '(a b c) req)
+           (equal '((o1 nil nil)
+                    (o2 42 nil)
+                    (o3 42 o3-supplied?))
+                  opt)
+           (equal '(((:k1 k1) nil nil)
+                    ((:key k2) nil nil)
+                    ((:k3 k3) 42 k3-supplied?))
+                  keys)
+           (not allowp)
+           (not aux)
+           (eq t keyp)))
+  t)
diff --git a/types.lisp b/types.lisp
new file mode 100644
index 000000000000..1942d0ecdf2a
--- /dev/null
+++ b/types.lisp
@@ -0,0 +1,137 @@
+(in-package :alexandria)
+
+(deftype array-index (&optional (length (1- array-dimension-limit)))
+  "Type designator for an index into array of LENGTH: an integer between
+0 (inclusive) and LENGTH (exclusive). LENGTH defaults to one less than
+ARRAY-DIMENSION-LIMIT."
+  `(integer 0 (,length)))
+
+(deftype array-length (&optional (length (1- array-dimension-limit)))
+  "Type designator for a dimension of an array of LENGTH: an integer between
+0 (inclusive) and LENGTH (inclusive). LENGTH defaults to one less than
+ARRAY-DIMENSION-LIMIT."
+  `(integer 0 ,length))
+
+;; This MACROLET will generate most of CDR5 (http://cdr.eurolisp.org/document/5/)
+;; except the RATIO related definitions and ARRAY-INDEX.
+(macrolet
+    ((frob (type &optional (base-type type))
+       (let ((subtype-names (list))
+             (predicate-names (list)))
+         (flet ((make-subtype-name (format-control)
+                  (let ((result (format-symbol :alexandria format-control
+                                               (symbol-name type))))
+                    (push result subtype-names)
+                    result))
+                (make-predicate-name (sybtype-name)
+                  (let ((result (format-symbol :alexandria '#:~A-p
+                                               (symbol-name sybtype-name))))
+                    (push result predicate-names)
+                    result))
+		(make-docstring (range-beg range-end range-type)
+		  (let ((inf (ecase range-type (:negative "-inf") (:positive "+inf"))))
+		    (format nil "Type specifier denoting the ~(~A~) range from ~A to ~A."
+			    type
+			    (if (equal range-beg ''*) inf (ensure-car range-beg))
+			    (if (equal range-end ''*) inf (ensure-car range-end))))))
+           (let* ((negative-name     (make-subtype-name '#:negative-~a))
+                  (non-positive-name (make-subtype-name '#:non-positive-~a))
+                  (non-negative-name (make-subtype-name '#:non-negative-~a))
+                  (positive-name     (make-subtype-name '#:positive-~a))
+                  (negative-p-name     (make-predicate-name negative-name))
+                  (non-positive-p-name (make-predicate-name non-positive-name))
+                  (non-negative-p-name (make-predicate-name non-negative-name))
+                  (positive-p-name     (make-predicate-name positive-name))
+                  (negative-extremum)
+                  (positive-extremum)
+                  (below-zero)
+                  (above-zero)
+                  (zero))
+             (setf (values negative-extremum below-zero
+                           above-zero positive-extremum zero)
+                   (ecase type
+                     (fixnum       (values 'most-negative-fixnum -1 1 'most-positive-fixnum 0))
+                     (integer      (values ''* -1       1        ''* 0))
+                     (rational     (values ''* '(0)     '(0)     ''* 0))
+                     (real         (values ''* '(0)     '(0)     ''* 0))
+                     (float        (values ''* '(0.0E0) '(0.0E0) ''* 0.0E0))
+                     (short-float  (values ''* '(0.0S0) '(0.0S0) ''* 0.0S0))
+                     (single-float (values ''* '(0.0F0) '(0.0F0) ''* 0.0F0))
+                     (double-float (values ''* '(0.0D0) '(0.0D0) ''* 0.0D0))
+                     (long-float   (values ''* '(0.0L0) '(0.0L0) ''* 0.0L0))))
+             `(progn
+                (deftype ,negative-name ()
+		  ,(make-docstring negative-extremum below-zero :negative)
+		  `(,',base-type ,,negative-extremum ,',below-zero))
+
+                (deftype ,non-positive-name ()
+		  ,(make-docstring negative-extremum zero :negative)
+		  `(,',base-type ,,negative-extremum ,',zero))
+
+                (deftype ,non-negative-name ()
+		  ,(make-docstring zero positive-extremum :positive)
+		  `(,',base-type ,',zero ,,positive-extremum))
+
+                (deftype ,positive-name ()
+		  ,(make-docstring above-zero positive-extremum :positive)
+		  `(,',base-type ,',above-zero ,,positive-extremum))
+
+                (declaim (inline ,@predicate-names))
+
+                (defun ,negative-p-name (n)
+                  (and (typep n ',type)
+                       (< n ,zero)))
+
+                (defun ,non-positive-p-name (n)
+                  (and (typep n ',type)
+                       (<= n ,zero)))
+
+                (defun ,non-negative-p-name (n)
+                  (and (typep n ',type)
+                       (<= ,zero n)))
+
+                (defun ,positive-p-name (n)
+                  (and (typep n ',type)
+                       (< ,zero n)))))))))
+  (frob fixnum integer)
+  (frob integer)
+  (frob rational)
+  (frob real)
+  (frob float)
+  (frob short-float)
+  (frob single-float)
+  (frob double-float)
+  (frob long-float))
+
+(defun of-type (type)
+  "Returns a function of one argument, which returns true when its argument is
+of TYPE."
+  (lambda (thing) (typep thing type)))
+
+(define-compiler-macro of-type (&whole form type &environment env)
+  ;; This can yeild a big benefit, but no point inlining the function
+  ;; all over the place if TYPE is not constant.
+  (if (constantp type env)
+      (with-gensyms (thing)
+        `(lambda (,thing)
+           (typep ,thing ,type)))
+      form))
+
+(declaim (inline type=))
+(defun type= (type1 type2)
+  "Returns a primary value of T is TYPE1 and TYPE2 are the same type,
+and a secondary value that is true is the type equality could be reliably
+determined: primary value of NIL and secondary value of T indicates that the
+types are not equivalent."
+  (multiple-value-bind (sub ok) (subtypep type1 type2)
+    (cond ((and ok sub)
+           (subtypep type2 type1))
+          (ok
+           (values nil ok))
+          (t
+           (multiple-value-bind (sub ok) (subtypep type2 type1)
+             (declare (ignore sub))
+             (values nil ok))))))
+
+(define-modify-macro coercef (type-spec) coerce
+  "Modify-macro for COERCE.")