From c3ad9ffd9a23e41e562ce624d44e9f40c4d0ebf5 Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Tue, 6 Feb 1990 17:27:59 +0000
Subject: [PATCH] Initial revision

---
 code/alieneval.lisp   | 1267 +++++++++++++++++++++++
 code/array.lisp       |  869 ++++++++++++++++
 code/c-call.lisp      |  935 +++++++++++++++++
 code/char.lisp        |  466 +++++++++
 code/clx-ext.lisp     |  591 +++++++++++
 code/debug-info.lisp  |  191 ++++
 code/debug.lisp       |  441 ++++++++
 code/defmacro.lisp    |  413 ++++++++
 code/defstruct.lisp   |  561 ++++++++++
 code/describe.lisp    |  318 ++++++
 code/error.lisp       | 1237 ++++++++++++++++++++++
 code/eval.lisp        |  366 +++++++
 code/extensions.lisp  |  349 +++++++
 code/fdefinition.lisp |   68 ++
 code/filesys.lisp     | 1278 +++++++++++++++++++++++
 code/foreign.lisp     |  281 +++++
 code/format.lisp      | 1514 +++++++++++++++++++++++++++
 code/gc.lisp          |  604 +++++++++++
 code/globals.lisp     |   56 +
 code/hash.lisp        |  429 ++++++++
 code/lispinit.lisp    | 1212 ++++++++++++++++++++++
 code/list.lisp        |  869 ++++++++++++++++
 code/load.lisp        | 1022 ++++++++++++++++++
 code/machdef.lisp     |  106 ++
 code/macros.lisp      | 1532 +++++++++++++++++++++++++++
 code/misc.lisp        |  126 +++
 code/package.lisp     | 1101 ++++++++++++++++++++
 code/pred.lisp        |  619 +++++++++++
 code/print.lisp       | 1267 +++++++++++++++++++++++
 code/purify.lisp      |  538 ++++++++++
 code/rand.lisp        |  128 +++
 code/reader.lisp      | 1302 +++++++++++++++++++++++
 code/save.lisp        |  114 ++
 code/search-list.lisp |  154 +++
 code/seq.lisp         | 2281 +++++++++++++++++++++++++++++++++++++++++
 code/sharpm.lisp      |  456 ++++++++
 code/sort.lisp        |  442 ++++++++
 code/stream.lisp      | 1043 +++++++++++++++++++
 code/string.lisp      |  608 +++++++++++
 code/struct.lisp      |  156 +++
 code/symbol.lisp      |  189 ++++
 code/sysmacs.lisp     |  274 +++++
 code/time.lisp        |  404 ++++++++
 code/tty-inspect.lisp |  195 ++++
 tools/worldcom.lisp   |  118 +++
 tools/worldload.lisp  |  164 +++
 46 files changed, 28654 insertions(+)
 create mode 100644 code/alieneval.lisp
 create mode 100644 code/array.lisp
 create mode 100644 code/c-call.lisp
 create mode 100644 code/char.lisp
 create mode 100644 code/clx-ext.lisp
 create mode 100644 code/debug-info.lisp
 create mode 100644 code/debug.lisp
 create mode 100644 code/defmacro.lisp
 create mode 100644 code/defstruct.lisp
 create mode 100644 code/describe.lisp
 create mode 100644 code/error.lisp
 create mode 100644 code/eval.lisp
 create mode 100644 code/extensions.lisp
 create mode 100644 code/fdefinition.lisp
 create mode 100644 code/filesys.lisp
 create mode 100644 code/foreign.lisp
 create mode 100644 code/format.lisp
 create mode 100644 code/gc.lisp
 create mode 100644 code/globals.lisp
 create mode 100644 code/hash.lisp
 create mode 100644 code/lispinit.lisp
 create mode 100644 code/list.lisp
 create mode 100644 code/load.lisp
 create mode 100644 code/machdef.lisp
 create mode 100644 code/macros.lisp
 create mode 100644 code/misc.lisp
 create mode 100644 code/package.lisp
 create mode 100644 code/pred.lisp
 create mode 100644 code/print.lisp
 create mode 100644 code/purify.lisp
 create mode 100644 code/rand.lisp
 create mode 100644 code/reader.lisp
 create mode 100644 code/save.lisp
 create mode 100644 code/search-list.lisp
 create mode 100644 code/seq.lisp
 create mode 100644 code/sharpm.lisp
 create mode 100644 code/sort.lisp
 create mode 100644 code/stream.lisp
 create mode 100644 code/string.lisp
 create mode 100644 code/struct.lisp
 create mode 100644 code/symbol.lisp
 create mode 100644 code/sysmacs.lisp
 create mode 100644 code/time.lisp
 create mode 100644 code/tty-inspect.lisp
 create mode 100644 tools/worldcom.lisp
 create mode 100644 tools/worldload.lisp

diff --git a/code/alieneval.lisp b/code/alieneval.lisp
new file mode 100644
index 000000000..179bc392c
--- /dev/null
+++ b/code/alieneval.lisp
@@ -0,0 +1,1267 @@
+;;; -*- Log: code.log; Package: Lisp -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;;    This file contains any the part of the Alien implementation that
+;;; is not part of the compiler.
+;;;
+(in-package 'lisp)
+(in-package 'system)
+(export '(*alien-eval-when* make-alien alien-type alien-size alien-address
+			    copy-alien dispose-alien defalien alien-value
+			    alien-bind defoperator alien-index alien-indirect
+			    bits bytes words long-words port perq-string
+			    boolean defenumeration enumeration
+			    system-area-pointer pointer alien alien-access
+			    alien-assign alien-sap define-alien-stack
+			    with-stack-alien null-terminated-string c-procedure
+			    unstructured))
+(in-package 'lisp)
+
+(defun concat-pnames* (name1 name2)
+  (if name1
+      (make-symbol (concatenate 'simple-string (symbol-name name1)
+				(symbol-name name2)))
+      name2))
+
+#-new-compiler
+(eval-when (compile)
+  (setq lisp::*bootstrap-defmacro* :both))
+
+;;; The number of bits corresponding to a change of 1 in the value of a SAP.
+;;;
+(defconstant alien-address-unit 8)
+
+;;; The address pointed to by the SAP in an alien is always a multiple of this
+;;; number of bits.
+;;;
+(defconstant alien-alignment 16)
+
+(defvar *alien-eval-when* '(compile load eval)
+  "This is a list of the times to eval Alien compiler info.")
+
+(defun %print-alien-value (s stream d)
+  (declare (ignore d))
+  (let ((offset (alien-value-offset s)))
+    (format stream
+	    "#<Alien value, Address = #x~X~:[+~D/8~;~*~], Size = ~D, Type = ~S>"
+	    (%primitive sap-int (alien-value-sap s)) (zerop offset) offset
+	    (alien-value-size s) (alien-value-type s))))
+
+(defun %print-alien-info (s stream d)
+  (declare (ignore s d))
+  (write-string "#<Alien-Info>" stream))
+
+
+;;;; Interpreter stubs for SAP functions:
+
+#+new-compiler (progn
+(defun sap-int (sap)
+  "Converts a System Area Pointer into an integer."
+  (sap-int sap))
+
+(defun int-sap (int)
+  "Converts an integer into a System Area Pointer."
+  (int-sap int))
+
+(defun sap-ref-8 (sap offset)
+  "Returns the 8-bit byte at Offset bytes from SAP."
+  (sap-ref-8 sap offset))
+
+(defun sap-ref-16 (sap offset)
+  "Returns the 16-bit word at Offset words from SAP."
+  (sap-ref-16 sap offset))
+
+(defun sap-ref-32 (sap offset)
+  "Returns the 32-bit dualword at Offset words from SAP."
+  (sap-ref-32 sap offset))
+
+(defun (setf sap-ref-8) (sap offset new-value)
+  (setf (sap-ref-8 sap offset) new-value))
+
+(defun (setf sap-ref-16) (sap offset new-value)
+  (setf (sap-ref-16 sap offset) new-value))
+
+(defun (setf sap-ref-32) (sap offset new-value)
+  (setf (sap-ref-32 sap offset) new-value))
+
+); #+New-Compiler
+
+
+;;;; Miscellaneous primitives:
+
+;;; Alien-Assign  --  Public
+;;;
+;;;    Just blt the bytes from one to the other...
+;;;
+(defun alien-assign (to-alien from-alien)
+  "Copy the data in From-Alien into To-Alien.  The two alien values
+  must be of the same size and type."
+  (declare (type alien-value to-alien from-alien))
+  (unless (equal (alien-value-type to-alien) (alien-value-type from-alien))
+    (error "Arguments to Alien-Assign are of different types:~%~S~%~S"
+	   to-alien from-alien))
+  (let ((size (alien-value-size to-alien))
+	(src-off (alien-value-offset from-alien))
+	(dst-off (alien-value-offset to-alien)))
+    (unless (= size (alien-value-size from-alien))
+      (error "Arguments to Alien-Assign are of different sizes:~%~S~%~S"
+	     to-alien from-alien))
+    (unless (zerop (logand size 7))
+      (error "Size of assigned Alien is not a byte multiple:~%~S"
+	     from-alien))
+    (unless (zerop (logand src-off 7))
+      (error "Alien is not byte aligned:~%~S" from-alien))
+    (unless (zerop (logand dst-off 7))
+      (error "Alien is not byte aligned:~%~S" to-alien))
+    (let ((dst-start (ash dst-off -3)))
+      (%primitive byte-blt (alien-value-sap from-alien) (ash src-off -3)
+		  (alien-value-sap to-alien) dst-start
+		  (+ dst-start (ash size -3))))
+    to-alien))
+
+
+;;; Alien-Type, Alien-Size, Alien-Address, Alien-SAP  --  Public
+;;;
+;;;    Return the corresponding fields out of the Alien-Value structure.
+;;; Convert the address back into rational form.
+;;;
+(defun alien-type (alien)
+  "Return the type of the Alien Value."
+  (check-type alien alien-value)
+  (alien-value-type alien))
+
+(defun alien-size (alien)
+  "Return the size in bits of the Alien." 
+  (check-type alien alien-value)
+  (alien-value-size alien))
+
+(defun alien-address (alien)
+  "Return the address of the data for Alien."
+  (check-type alien alien-value)
+  (+ (%primitive sap-int (alien-value-sap alien))
+     (/ (alien-value-offset alien) alien-address-unit)))
+
+(defun alien-sap (alien)
+  "Return the system-area-pointer which corresponds to Alien.  Signal an
+  error if the alien's address is not word-aligned."
+  (check-type alien alien-value)
+  (unless (zerop (alien-value-offset alien))
+    (error "Argument to Alien-SAP is not word-aligned:~%~S" alien))
+  (alien-value-sap alien))
+
+
+;;;; Interface macros:
+
+;;; Defalien  --  Public
+;;;
+;;;    Dump the right compiler info and code to create the value at
+;;; load-time.
+;;;
+(defmacro defalien (name type size &optional (address :static))
+  "defalien Name Type Size [address]
+  Define a global Alien variable with the specified Name, Type, Size and
+  Address.  If Address is not supplied allocate storage to hold it."
+  `(progn
+    (eval-when (load eval)
+      (defparameter ,name (make-alien ',type ,size ,address)))
+    (eval-when ,*alien-eval-when*
+      (setf (info variable alien-value ',name)
+	    (make-ct-a-val
+	     :type ',type
+	     :size ,size
+	     :offset ,(if (numberp address)
+			  (rem (* address alien-address-unit) alien-alignment)
+			  0)
+	     :sap `(alien-value-sap ,',name)
+	     :alien ',name)))))
+
+
+;;; Define-Alien-Stack  --  Public
+;;;
+;;;    Define some variables and a function to grow the stack.  Put good
+;;; stuff on the property list.
+;;;
+(defmacro define-alien-stack (name type size)
+  "Define-Stack-Alien Name Type Size
+  Defines a new alien stack for use with the With-Stack-Alien macro.
+  The aliens have the specifed Type and Size, and are static."
+  (let ((n-head (concat-pnames name '-alien-stack-head))
+	(n-current (concat-pnames name '-alien-stack))
+	(grow-fun (concat-pnames name '-grow-stack)))
+  `(progn
+    (eval-when ,*alien-eval-when*
+      (setf (info alien-stack info ',name)
+	    (make-stack-info :head ',n-head  :current ',n-current
+			     :grow ',grow-fun  :type ',type
+			     :size ,size)))
+    (defvar ,n-head ())
+    (defvar ,n-current ())
+    (defun ,grow-fun ()
+      (let ((new (list (make-alien ',type ,size :static))))
+	(setq ,n-head (nconc ,n-head new)  ,n-current new)
+	(car new))))))
+
+
+;;; Defoperator  --  Public
+;;;
+;;;    Make the Alien-Info for the compiler and the function for the
+;;; interpreter.
+;;;
+(defmacro defoperator ((name result-type) args body)
+  (do ((arg args (cdr arg))
+       (argnames ())
+       (arg-types ())
+       (n 0 (1+ n)))
+      ((null arg)
+       `(eval-when ,*alien-eval-when*
+	  (setf (info function alien-operator ',name)
+		(make-alien-info #'(lambda ,(nreverse argnames) ,body)
+				 ,(length args) ',arg-types ',result-type))
+	  (setf (info function source-transform ',name)
+		#'c::alien=>lisp-transform)
+	  (defun ,name (&rest dummy-arglist)
+	    (displace-operator-definition ',name dummy-arglist))))
+    (cond
+     ((symbolp (car arg))
+      (push (car arg) argnames))
+     (t
+      (push (cons n (cadar arg)) arg-types) 
+      (push (caar arg) argnames)))))
+
+#-new-compiler
+(eval-when (compile)
+  (setq lisp::*bootstrap-defmacro* nil))
+
+
+;;;; Alien allocation:
+
+(eval-when (compile)
+  (dolist (x '(system-space-start alien-allocation-end))
+    (remprop x 'lisp::%constant)))
+
+;;;    In order to improve memory locality static alien values are allocated
+;;; contiguously in a pre-validated area at the beginning of system space.  We
+;;; keep a free pointer to the next word we can allocate.
+;;;
+(defparameter system-space-start
+  (%primitive make-immediate-type 0 %static-alien-area)
+  "The address of the first statically allocated alien.")
+
+(defparameter alien-allocation-end
+  (%primitive make-immediate-type #x40000 %static-alien-area)
+  "The end of statically allocated aliens.")
+
+(defvar *current-alien-free-pointer* system-space-start
+  "The next word in system space for static alien allocation.")
+
+;;; Allocate-Static-Alien  --  Internal
+;;;
+;;;    Allocate enough storage to hold the specified number of bits
+;;; and return the address.
+;;;
+(defun allocate-static-alien (bits)
+  (declare (fixnum bits))
+  (let* ((alien *current-alien-free-pointer*)
+	 (bytes (logand (ash (the fixnum (+ bits 31)) -3) (lognot 3)))
+	 (new (%primitive sap+ *current-alien-free-pointer* bytes)))
+    (when (%primitive pointer> new alien-allocation-end)
+      (error "Not enough room to allocate a ~D bit alien." bits))
+    (setq *current-alien-free-pointer* new)
+    alien))
+
+
+;;; Make-Alien  --  Public
+;;;
+;;;    Create an Alien value structure, validating memory to hold the data
+;;; if necessary.  We convert the rational address into a word address +
+;;; bit offset.
+;;;
+(defun make-alien (type size &optional (address :dynamic))
+  "Return an Alien value of the specified Type, whose size is Size bits.
+  Address is the word address of the value to create, if this is not
+  supplied then memory is allocated to contain the data."
+  (case address
+    (:dynamic
+     (setq address (do-validate 0 (ash size -3) -1)))
+    (:static
+     (setq address (allocate-static-alien size)))
+    (t
+     (if (not (integerp address))
+	 (setq address (%primitive sap-int address)))
+     (check-type address (rational 0))))
+  (check-type size (integer 0))
+  (if (numberp address)
+      (multiple-value-bind (base frac) (truncate address)
+	(let ((offset (* frac alien-address-unit)))
+	  (unless (integerp frac)
+	    (error "Address ~S does not fall on a bit position." address))
+	  (make-alien-value (%primitive int-sap base) offset size type)))
+      (make-alien-value address 0 size type)))
+
+
+;;; Copy-Alien  --  Public
+;;;
+;;;   Validate some memory and byte-blt the contents to it.  Since we just move
+;;; words we preserve a nonzero bit-offset when it might be desirable to
+;;; eliminate it, but that is more trouble than it is worth, since non-aligned
+;;; fields are probably rarely copied.
+;;;
+(defun copy-alien (alien)
+  "Copy the storage pointed to by Alien and return a new alien value that
+  describes it."
+  (check-type alien alien-value)
+  (let* ((offset (alien-value-offset alien))
+	 (length (alien-value-size alien))
+	 (bytes (ash (+ length offset 15) -3))
+	 (new (%primitive int-sap (do-validate 0 bytes -1))))
+    (%primitive byte-blt (alien-value-sap alien) (ash offset -3)
+		new 0 bytes)
+    (make-alien-value new offset length (alien-value-type alien))))
+
+
+;;; Dispose-Alien  --  Public
+;;;
+;;;    Invalidate the memory pointed to by unless it is a statically
+;;; allocated alien.
+;;;
+(defun dispose-alien (alien)
+  "Release the storage allocated for Alien."
+  (check-type alien alien-value)
+  (let ((address (alien-value-sap alien)))
+    (unless (not (or (%primitive pointer< address system-space-start)
+		     (%primitive pointer> address alien-allocation-end)))
+      (gr-call mach:vm_deallocate *task-self* address
+	       (logand #x-200 (ash (+ (alien-value-size alien) #xFFF) -3))))))
+
+
+;;;; Operator definition primitives:
+
+;;; Alien-Index  --  Public
+;;;
+;;;    Check that the selected field fits within the Alien, and add it
+;;; in if it does.
+;;;
+(defun alien-index (alien offset size)
+  "Return a new Alien value that is Offset bits within Alien, and is
+  Size bits long."
+  (check-type alien alien-value)
+  (check-type offset (integer 0))
+  (check-type size (integer 0))
+  (when (> (+ offset size) (alien-value-size alien))
+    (error "~S is too small to extract a ~A bit field at ~A."
+	   alien size offset))
+  (multiple-value-bind (words bits)
+		       (truncate (+ offset (alien-value-offset alien)) 8)
+    (make-alien-value
+     (%primitive int-sap (+ words (%primitive sap-int (alien-value-sap alien))))
+     bits
+     size
+     nil)))
+
+;;; Alien-Indirect  --  Public
+;;;
+;;;    Check that Alien is word-aligned and 32 bits long.  If it is, grab
+;;; the value.  Check that the value falls within the system area.  If
+;;; it does then make a new Alien-Value out of it.
+;;;
+(defun alien-indirect (alien size)
+  "Return a new Alien value that points to what the value of Alien points to
+  which is Size bits long."
+  (check-type alien alien-value)
+  (check-type size (integer 0))
+  (unless (= (alien-value-size alien) 32)
+    (error "~S is not thirty-two bits long." alien))
+  (unless (zerop (alien-value-offset alien))
+    (error "~S is not word aligned."))
+  (let* ((sap (alien-value-sap alien))
+	 (value (logior (ash (%primitive 16bit-system-ref sap 0) 16)
+			(%primitive 16bit-system-ref sap 1))))
+#|
+    (unless (<= system-space-start value most-positive-fixnum)
+      (error "The value of ~S, #x~X, does not point into system space."
+	     alien value))
+|#
+    (make-alien-value (%primitive int-sap value) 0 size nil)))
+
+
+;;; Bits, Bytes, Words, Long-Words  --  Public
+;;;
+;;;
+(macrolet ((frob (name n)
+	     `(progn
+		(proclaim '(inline ,name))
+		(defun ,name (n)
+		  (declare (type (integer 0 ,(truncate most-positive-fixnum n))
+				 n))
+		  (* n ,n)))))
+  (frob bits 1)
+  (frob bytes 8)
+  (frob words 16)
+  (frob long-words 32))
+
+
+;;;; General case versions of compiler internal functions:
+
+;;; %Alien-Indirect  --  Internal
+;;;
+;;;    Alien-Indirect is transformed into this.  Calls can take place at
+;;; run-time when the operation can't be proven safe at compile time.
+;;;
+(defun %alien-indirect (size sap offset exp)
+  (unless (eql size 32)
+    (error "Argument to Alien-Indirect is ~D bits, 32:~% ~S." size exp))
+  (unless (zerop (logand offset #x1F))
+    (error "Offset ~D to Alien-Indirect is not long-word-aligned:~% ~S."
+	   offset exp))
+  (%primitive sap-system-ref sap (ash offset -4)))
+
+
+;;; %Aligned-SAP  --  Internal
+;;;
+;;;    Various things transform into this when the alien is declared to be
+;;; aligned.  In this case, we absorb the offset into the SAP, and make the
+;;; bound offset 0.
+;;;
+(defun %aligned-sap (sap offset form)
+  (unless (zerop (logand offset #xF))
+    (error "Offset ~S was declared to be word aligned, but isn't:~% ~S"
+	   offset form))
+  (%primitive sap+ sap (ash offset -3)))
+
+#+new-compiler
+;;; Naturalize-Integer  --  Internal
+;;;
+;;;    Read a possibly signed integer somewhere.  For the 16 and 32 bit
+;;; cases we let the transform do the work, for random fields we do it
+;;; by hand.
+;;;
+(defun naturalize-integer (signed sap offset size form)
+  (multiple-value-bind (q r) (truncate offset 16)
+    (cond
+     ((> size 15)
+      (unless (zerop r)
+	(error "Offset ~D for ~D bit access is not word-aligned:~% ~S"
+	       offset size form))
+      (case size
+	(32
+	 (if signed
+	     (%primitive signed-32bit-system-ref sap (ash q 4))
+	     (%primitive unsigned-32bit-system-ref sap (ash q 4))))
+	(16
+	 (if signed
+	     (naturalize-integer t sap (ash q 4) 16 nil)
+	     (naturalize-integer nil sap (ash q 4) 16 nil)))
+	(t
+	 (error "Access of ~D bit integers is not supported." size))))
+     (t
+      (when (> (+ size r) 16)
+	(error "~D bit field at ~D offset crosses a word boundry:~% ~S"
+	       size offset form))
+      (if signed
+	  (let ((val (ldb (byte size (- 16 size r))
+			  (%primitive 16bit-system-ref sap q))))
+	    (if (logbitp val (1- size))
+		(logior val (ash -1 size))
+		val))
+	  (ldb (byte size (- 16 size r))
+	       (%primitive 16bit-system-ref sap q)))))))
+
+#+new-compiler
+;;; Deport-Integer  --  Internal
+;;;
+;;;    Like Naturalize-Integer, but writes an integer.
+;;;
+(defun deport-integer (signed sap offset size value form)
+  (declare (ignore signed))
+  (multiple-value-bind (q r) (truncate offset 16)
+    (declare (fixnum r))
+    (cond
+     ((> size 15)
+      (unless (zerop r)
+	(error "Offset ~D for ~D bit store is not word-aligned:~% ~S"
+	       offset size form))
+      (case size
+	(32
+	 (%primitive signed-32bit-system-set sap q value))
+	(16
+	 (%primitive 16bit-system-set sap q value))
+	(t
+	 (error "Storing of ~D bit integers is not supported:~% ~S"
+		size form))))
+     ((= size 8)
+      (setq q (ash q 1))
+      (when (= r 8)
+	(setq q (1+ q))
+	(setq r 0))
+      (when (/= r 0)
+	(error "8 bit field at ~D offset crosses a byte boundary:~% ~S"
+	       offset form))
+      (%primitive 8bit-system-set sap q value))
+     ((> size 7)
+      (when (> (+ size r) 16)
+	(error "~D bit field at ~D offset crosses a word boundry:~% ~S"
+	       size offset form))
+      (%primitive 16bit-system-set sap q
+		  (dpb value (byte size (- 16 size r))
+		       (%primitive 16bit-system-ref sap q))))
+     (T
+      (multiple-value-bind (nq nr) (truncate offset 8)
+	(when (> (+ size nr) 8)
+	  (error "~D bit field at ~D offset crosses a byte boundry:~% ~S"
+		 size offset form))
+	(%primitive 8bit-system-set sap nq
+		    (dpb value (byte size (- 8 size nr))
+			 (%primitive 8bit-system-ref sap nq)))))))
+  nil)
+
+
+;;; Naturalize and Deport Boolean  --  Internal
+;;;
+;;;    Handle the general case of boolean access.  The transforms
+;;; should pick off the normal cases.
+;;;
+#+new-compiler
+(defun naturalize-boolean (sap offset size form)
+  (declare (notinline naturalize-integer))
+  (not (zerop (naturalize-integer nil sap offset size form))))
+;;;
+#+new-compiler
+(defun deport-boolean (sap offset size value form)
+  (declare (notinline deport-integer))
+  (deport-integer nil sap offset size (if value 1 0) form)
+  nil)
+
+;;; Check<=, Check=  --  Internal
+;;;
+;;;    Interpreter stubs for functions normally open-coded.  Note that the
+;;; compiler will constant-fold these, possibly producing an error at compile
+;;; time.
+;;;
+(defun check<=  (x y) (check<= x y))
+(defun check= (x y)
+  #|
+  (check= x y)
+  |#
+  ;### Bootstrap hack:
+  (unless (and (fixnump x) (>= x 0)
+	       (fixnump y) (>= y 0)
+	       (= x y))
+    (error "Not ~S not = to ~S at compile time." x y)))
+
+
+;;;; Utility functions used by macros and special forms:
+
+;;; Check-Alien-Type  --  Internal
+;;;
+;;;    Check that Alien is of the specified Alien type, and give an
+;;; error if it is not. 
+;;;
+(defun check-alien-type (alien type)
+  (unless (alien-value-p alien)
+    (error "~S is not an Alien value." alien))
+  (unless (equal (alien-value-type alien) type)
+    (error "Wrong Alien type ~S, should have been of type ~S."
+	   (alien-value-type alien) type))
+  alien)
+
+
+;;; Assert-Alien-Type  --  Internal
+;;;
+;;;    Make a new Alien value having the specified type.
+;;;
+(defun assert-alien-type (alien type)
+  (unless (alien-value-p alien)
+    (error "~S is not an Alien value." alien))
+  (make-alien-value (alien-value-sap alien)
+		    (alien-value-offset alien)
+		    (alien-value-size alien)
+		    type))
+
+
+;;; Displace-Operator-Definition  --  Internal
+;;;
+;;;    To save space and load & compile time for defoperators, we don't
+;;; actually generate the function for the operator until it is called.
+;;; This results in a significant space savings at the cost of
+;;; always running the operator definition interpreted when called
+;;; that way.
+;;;
+(defun displace-operator-definition (name actual-args)
+  (let ((info (info function alien-operator name)))
+    (unless info
+      (error "Operator ~S has no Alien-Operator-Info property."))
+    (let ((num-args (alien-info-num-args info))
+	  (arg-types (alien-info-arg-types info)))
+      (do ((i 0 (1+ i))
+	   (args ())
+	   (binds ()))
+	  ((= i num-args)
+	   (let* ((args (nreverse args))
+		  (res (coerce `(lambda ,args
+				  (alien-bind ,(nreverse binds)
+				    (assert-alien-type
+				     ,(apply (alien-info-function info) args)
+				     ',(alien-info-result-type info))))
+			       'function)))
+	     (setf (symbol-function name) res)
+	     (apply res actual-args)))
+	(let ((type (assoc i arg-types))
+	      (sym (gensym)))
+	  (push sym args)
+	  (if type
+	      (push `(,sym ,sym ,(cdr type)) binds)))))))
+
+
+;;;; Alien access method definition:
+;;;
+;;;    We describe how to access and store at an Alien's address in
+;;; a way that permits the same code to be use both for the compiler
+;;; and the interpreter.  What we do is have experts that ask things
+;;; about the alien value and return a piece of code to do the access.
+;;;
+;;;
+(defvar *alien-access-table* (make-hash-table :test #'eq)
+  "Hashtable from lisp types to Alien access functions.")
+(defvar *alien-only-access-table* (make-hash-table :test #'eq)
+  "Hashtable from alien types to Alien access functions.")
+(defvar *alien-to-lisp-types* (make-hash-table :test #'eq)
+  "Hashtable we use to tell whether there is a unique lisp-type
+   for a given alien-type.")
+
+(defmacro mostcar (x)
+  `(if (listp ,x) (car ,x) ,x))
+
+
+;;; %Define-Alien-Access  --  Internal
+;;;
+(defun %define-alien-access (lisp-type atypes fun)
+  (dolist (type atypes)
+    (let ((res (gethash type *alien-to-lisp-types*)))
+      (cond ((not res)
+	     (setf (gethash type *alien-to-lisp-types*) lisp-type))
+	    ((eq res lisp-type))
+	    (t
+	     (setf (gethash type *alien-to-lisp-types*) '%conflict%))))
+
+    (setf (gethash type *alien-only-access-table*) fun)
+    (setf (gethash lisp-type *alien-access-table*) fun)))
+
+
+;;; Get-Alien-Access-Method  --  Internal
+;;;
+;;;    Returns the alien-access method corresponding to Alien-Type and
+;;; Lisp-Type or dies trying.
+;;;
+(defun get-alien-access-method (alien-type lisp-type)
+  (let* ((alien-type (mostcar alien-type))
+	 (lisp-type (mostcar lisp-type))
+	 (unique? (gethash alien-type *alien-to-lisp-types*)))
+    (cond
+     ((not unique?)
+      (error "Alien type ~S does not correspond to any Lisp type." alien-type))
+     ((and (null lisp-type)
+	   (not (eq unique? '%conflict%))
+	   (gethash alien-type *alien-only-access-table*)))
+     ((not (eq unique? '%conflict%))
+      (gethash unique? *alien-access-table*))
+     ((not lisp-type)
+      (error "Lisp-Type must be specified with Alien type ~S." alien-type))
+     ((gethash lisp-type *alien-access-table*))
+     (t
+      (error "~S is not a Lisp-Type known to Alien-Access."
+	     lisp-type)))))
+
+
+;;; Define-Alien-Access  --  Internal
+;;;
+(defmacro define-alien-access ((lisp-type &optional (atype lisp-type)
+					  &rest more-types)
+			       (alien-var kind-var value-var
+					  &optional
+					  (source-var (gensym) source-p))
+			       &body body)
+  "Define-Alien-Access (Lisp-Type {Alien-Type}*) (Alien-Var Kind-Var Value-Var)
+		       {form}*
+
+  Define a new type for Alien-Access.  When Alien-Access is given the specified
+  Lisp-Type and the alien is one of the specified Alien-Types, then body will
+  be evaluated to get an expression that does the the appropriate access/store.
+  If no Alien-Type is supplied, then the accepted Alien type is Lisp-Type.  If
+  the type of the Alien is a list, then we use the car as the type.
+
+  Alien-Var
+      Bound to the Alien type of the Alien value to access.
+
+  Kind-Var
+      Bound to :read or :write, indicating whether to read or store a value.
+
+  Value-Var
+      When Kind-Var is :write, this is bound to an expression to evaluate to
+      obtain the value to be stored.
+
+  Source-Var
+      If specified, this is bound to the original Alien-Access form
+      (for use in error messages.)
+
+  In order to obtain the Alien value at which the access is to be done, the
+  local With-Alien macro should be used:
+
+  With-Alien (Sap-Var) (Offset-Var {Key Value}*) (Size-Var {Key Value}*)
+              {Form}*
+  This macro is for use within the body of a Define-Alien-Access.  It
+  analyzes and verifies assertions on the alien value to be accessed.
+  Sap-Var, Offset-Var and Size-Var are bound to expressions for the
+  system-area-pointer to the value, the offset from it in bits and
+  the size of the Alien in bits.
+
+  The keyword arguments for the offset and size may be used to place
+  constraints on the values they may assume.  If the value
+  is Nil, that is taken to be a null constraint.  The following
+  keys are defined:
+   :unit      -- A integer (default 16).
+		 Asserts that the value is a multiple of this number, and
+		 that the value is to be divided by this number before any
+		 other options are processed.
+   :constant  -- An integer (default Nil).
+		 Asserts that the value must be exactly the supplied value.
+   :minimum   -- An integer (default Nil).
+		 Asserts that the value may not be less than the supplied
+		 value.
+
+  The value of With-Alien is the value of the last form."
+
+  (let ((n-sap (gensym))
+	(n-offset (gensym))
+	(n-size (gensym)))
+    `(%define-alien-access
+      ',lisp-type '(,atype ,@more-types)
+      #'(lambda (,n-sap ,n-offset ,n-size ,alien-var ,kind-var ,value-var
+			,source-var)
+	  ,@(unless source-p
+	     `((declare (ignore ,source-var))))
+
+	  (unless (memq (mostcar ,alien-var) '(,atype ,@more-types))
+	    (error "Wrong Alien type ~S, should have been ~S~
+	            ~{~#[~; or~:;,~] ~S~}."
+		   ,alien-var ',atype ',more-types))
+	  
+	  (macrolet ((with-alien ((sap)
+				  (offset &key
+					  ((:unit ounit) 16))
+				  (size &key
+					((:constant sconst) nil)
+					((:minimum smin) nil)
+					((:unit sunit) 16))
+				  &body (body decls))
+		       (%with-alien sap offset ounit
+				    size sconst smin sunit
+				    ',n-sap ',n-offset ',n-size
+				    body decls)))
+	    ,@body)))))
+
+
+(eval-when (compile load eval)
+
+(defun %with-alien (sap offset ounit size sconst smin sunit
+			n-sap n-offset n-size body decls)
+  (let ((sunit (or sunit 1))
+	(ounit (or ounit 1))
+	(n-scaled-offset (gensym))
+	(n-scaled-size (gensym)))
+    `(let ((,sap ,n-sap)
+	   (,offset ',n-scaled-offset)
+	   (,size ',n-scaled-size))
+       ,@decls
+       `(let ((,',n-scaled-offset (/ ,,n-offset ,,ounit))
+	      (,',n-scaled-size (/ ,,n-size ,,sunit)))
+	  ,',n-scaled-size ; Ignorable...
+	  ,@',(when sconst
+		`((check= ,n-scaled-size ,sconst)))
+	  ,@',(when smin
+		`((check<= ,smin ,n-scaled-size)))
+	  ,,@body))))
+
+); Eval-When (Compile Load Eval)
+
+
+;;; Alien-Access  --  Public
+;;;
+;;;    This is only called when we can't open-code because the types aren't
+;;; constant (or are erroneous.)  In this case, we must look up the access
+;;; method at run-time, compute the access form, then eval it.
+;;;
+(defun alien-access (alien &optional lisp-type)
+  "Converts the bits described by Alien into an object of type Lisp-Type,
+  or dies trying."
+  (declare (type alien-value alien))
+  (let* ((alien-type (alien-value-type alien))
+	 (access (get-alien-access-method alien-type lisp-type))
+	 (n-sap (gensym))
+	 (n-offset (gensym))
+	 (n-size (gensym)))
+    (eval
+     `(let ((,n-sap ',(alien-value-sap alien))
+	    (,n-offset ',(alien-value-offset alien))
+	    (,n-size ',(alien-value-size alien)))
+	,(funcall access n-sap n-offset n-size alien-type :read nil
+		  'alien-access)))))
+
+(defsetf alien-access %set-alien-access
+  "Stores the representation of the value into the alien.")
+
+;;; %Set-Alien-Access  --  Public
+;;;
+;;;    Like Alien-Access, only we call the expert with :write and return
+;;; the new value.
+;;;
+(defun %set-alien-access (alien lisp-type &optional (new-value nil nvp))
+  (declare (type alien-value alien))
+  (let* ((lisp-type (if nvp lisp-type nil))
+	 (new-value (if nvp new-value lisp-type))
+	 (alien-type (alien-value-type alien))
+	 (access (get-alien-access-method alien-type lisp-type))
+	 (n-sap (gensym))
+	 (n-offset (gensym))
+	 (n-size (gensym))
+	 (n-nval (gensym)))
+    (eval
+     `(let ((,n-sap ',(alien-value-sap alien))
+	    (,n-offset ',(alien-value-offset alien))
+	    (,n-size ',(alien-value-size alien))
+	    (,n-nval ,new-value))
+	,(funcall access n-sap n-offset n-size alien-type :write n-nval
+		  '(setf alien-access))))
+    new-value))
+
+
+;;;; Miscellaneous alien access methods:
+
+;;; Alien-Access expert for Port  --  Internal
+;;;
+;;;    Just find the place and grab or store a 32-bit port, depending
+;;; on the access kind, treating ports as 32-bit signed integers. --JRG
+;;;
+(define-alien-access (port) (type kind value form)
+  ;;
+  ;; We want to know if the offset is constant, and the size must be two
+  ;; words.
+  (with-alien (sap)
+	      (offset :unit nil)
+	      (size :constant 32
+		    :unit nil)
+    (declare (ignore size))
+    (if (eq kind :read)
+	`(naturalize-integer t ,sap ,offset 32 ',form)
+	`(deport-integer t ,sap ,offset 32 ,value ',form))))
+
+;;; Alien-Access expert for String-Char  --  Internal
+;;;
+;;;    Kind of easy, but we need to deal with random bit positions.  What we do
+;;; is call Naturalize-Integer or Deport-Integer to do the access, and just do
+;;; the type conversion.
+;;;
+(define-alien-access (string-char) (type kind value form)
+  (with-alien (sap)
+	      (offset :unit nil)
+	      (size :unit nil :minimum 8)
+    (if (eq kind :read)
+	`(code-char (naturalize-integer nil ,sap ,offset ,size ',form))
+	`(deport-integer nil ,sap ,offset ,size (char-code ,value) ',form))))
+
+;;; Alien-Access experts for Unsigned-Byte, Signed-Byte  --  Internal
+;;;
+;;;    Like, just call Naturalize or Deport Integer.
+;;;
+(define-alien-access (unsigned-byte) (type kind value form)
+  (with-alien (sap)
+	      (offset :unit nil)
+	      (size :minimum (cadr type)
+		    :unit nil)
+    (if (eq kind :read)
+	`(naturalize-integer nil ,sap ,offset ,size ',form)
+	`(deport-integer nil ,sap ,offset ,size ,value ',form))))
+;;;
+(define-alien-access (signed-byte) (type kind value form)
+  (with-alien (sap)
+	      (offset :unit nil)
+	      (size :minimum (cadr type)
+		    :unit nil)
+    (if (eq kind :read)
+	`(naturalize-integer t ,sap ,offset ,size ',form)
+	`(deport-integer t ,sap ,offset ,size ,value ',form))))
+
+#| 
+I didn't write this, and it is wrong, since it assumes the size is constant.
+In fact, it will never be constant at this point in the new compiler.  I also
+don't know that it is supposed to be used for.  I suspect it is a PERQ crock.
+
+(define-alien-access (unstructured) (type kind value)
+  (with-alien (sap)
+	      (offset :unit nil)
+	      (size :unit nil
+		    :minimum (cadr type))
+    (if (eq kind :read)
+	(if (<= size 32)
+	    `(naturalize-integer nil ,sap ,offset ,size)
+	    (if (and (= (mod offset 32) 0) (= (mod size 32) 0))
+		(do ((i 32 (+ i 32))
+		     (form `(naturalize-integer nil ,sap ,offset 32)))
+		    ((>= i size) form)
+		  (setq form
+			`(logior (ash ,form 32)
+				 (naturalize-integer nil ,sap
+						     ,(+ offset i) 32))))
+		(error
+		 "Unstructured aliens of size ~D and offset ~D not supported."
+		 size offset)))
+	(if (<= size 32)
+	    `(deport-integer nil ,sap ,offset ,size ,value)
+	    (if (and (= (mod offset 32) 0) (= (mod size 32) 0))
+		(do ((i (- size 32) (- i 32))
+		     (shift 0 (- shift 32))
+		     (form ()))
+		    ((< i 0) (nreverse form))
+		  (push `(deport-integer nil ,sap ,(+ offset i) 32
+					 (logand (ash ,value ,shift)
+						 #xFFFFFFFF))
+			form))
+		(error
+		 "Unstructured aliens of size ~D and offset ~D not supported."
+		 size offset)))))))
+
+|#
+
+;;; Alien-Access expert for Boolean  --  Internal 
+;;;
+;;;    A boolean is a single bit, represented in Lisp as T or NIL.
+;;;
+(define-alien-access (boolean) (type kind value form)
+  (with-alien (sap)
+	      (offset :unit 1)
+	      (size :unit 1  :minimum 1)
+    (if (eq kind :read)
+	`(naturalize-boolean ,sap ,offset ,size ',form)
+	`(deport-boolean ,sap ,offset ,size ,value ',form))))
+
+
+;;; Alien-Access expert for short-floats
+;;;
+(define-alien-access (short-float) (type kind value)
+  (with-alien (sap)
+	      (offset)
+	      (size :constant 2)
+    (declare (ignore size))
+    (if (eq kind :read)
+	`(%primitive int-sap
+	  (logior (ash (%primitive unsigned-32bit-system-ref ,sap ,offset)
+		       (- clc::short-float-shift-16))
+		  (ash clc::short-float-4bit-type
+		       (- 32 clc::short-float-shift-16))))
+	(let ((var (gensym)))
+	  `(let ((,var (float ,value 1.0s0)))
+	     (setq ,var (ash (%primitive sap-int ,var) clc::short-float-shift-16))
+	     (%primitive signed-32bit-system-set ,sap ,offset ,var))))))
+
+
+;;; Alien-Access expert for long-floats
+;;;
+(define-alien-access (long-float) (type kind value)
+  (with-alien (sap)
+	      (offset)
+	      (size :constant 4)
+    (declare (ignore size))
+    (if (eq kind :read)
+	(let ((var (gensym)))
+	  `(let ((,var (%primitive float-long 0)))
+	     (%primitive 16bit-system-set ,var 2
+			 (%primitive 16bit-system-ref ,sap ,offset))
+	     (%primitive 16bit-system-set ,var 3
+			 (%primitive 16bit-system-ref ,sap (1+ ,offset)))
+	     (%primitive 16bit-system-set ,var 4
+			 (%primitive 16bit-system-ref ,sap (+ ,offset 2)))
+	     (%primitive 16bit-system-set ,var 5
+			 (%primitive 16bit-system-ref ,sap (+ ,offset 3)))
+	     ,var))
+	(let ((var (gensym)))
+	  `(let ((,var (float ,value 1.0L0)))
+	     (%primitive 16bit-system-set ,sap ,offset
+			 (%primitive 16bit-system-ref ,var 2))
+	     (%primitive 16bit-system-set ,sap (1+ ,offset)
+			 (%primitive 16bit-system-ref ,var 3))
+	     (%primitive 16bit-system-set ,sap (+ ,offset 2)
+			 (%primitive 16bit-system-ref ,var 4))
+	     (%primitive 16bit-system-set ,sap (+ ,offset 3)
+			 (%primitive 16bit-system-ref ,var 5)))))))
+
+;;; Alien-access expert for procedure objects.  These should be used
+;;; with caution.
+;;;
+(define-alien-access (c-procedure) (type kind value)
+  (with-alien (sap)
+	      (offset)
+	      (size :constant 2)
+    (declare (ignore size))
+    (if (eq kind :read)
+	`(error "It is illegal to reference a c-procedure object.")
+	`(%primitive set-c-procedure-pointer ,sap ,offset ,value))))
+
+
+;;;; Strings accesses:
+
+;;; Alien-Access expert for String  --  Internal
+;;;
+;;;    Read a Perq-String into a string or write a string out into
+;;; a Perq-String.
+;;;
+(define-alien-access (simple-string perq-string) (type kind n-value)
+  (with-alien (n-sap)
+	      (n-offset :unit 8)
+	      (size :unit 8
+		    :minimum (1+ (cadr type)))
+    (declare (ignore size))
+    (if (eq kind :read)
+	(let ((size (gensym))
+	      (str (gensym)))
+	  `(let* ((,size (%primitive 8bit-system-ref ,n-sap ,n-offset))
+		  (,str (make-string ,size)))
+	     (%primitive byte-blt ,n-sap (1+ ,n-offset) ,str 0 ,size)
+	     ,str))
+	(let ((len (gensym))
+	      (1+off (gensym)))
+	  `(let ((,len (length (the simple-string
+				    ,n-value)))
+		 (,1+off (1+ ,n-offset)))
+	     (check<= ,len ,(cadr type))
+	     (%primitive 8bit-system-set ,n-sap ,n-offset ,len)
+	     (%primitive byte-blt ,n-value 0 ,n-sap ,1+off
+			 (+ ,1+off ,len)))))))
+
+
+;;; Alien-Access expert for null terminated string  --  Internal
+;;;
+;;;    Read a null terminated string into a string or write a string out into
+;;; a null terminated string.
+;;;
+(define-alien-access (simple-string null-terminated-string) (type kind n-value)
+  (with-alien (n-sap)
+	      (n-offset :unit 8)
+	      (size :unit 8
+		    :minimum (cadr type))
+    (declare (ignore size))
+    (if (eq kind :read)
+	(let ((size (gensym))
+	      (str (gensym)))
+	  `(let* ((,size (the fixnum
+			      (- (the fixnum
+				      (%primitive find-character
+						  ,n-sap ,n-offset
+						  most-positive-fixnum 0))
+				 (the fixnum ,n-offset))))
+		  (,str (make-string ,size)))
+	     (%primitive byte-blt ,n-sap ,n-offset ,str 0 ,size)
+	     ,str))
+	(let ((len (gensym))
+	      (end (gensym)))
+	  `(let* ((,len (the fixnum (1+ (length (the simple-string
+						     ,n-value)))))
+		  (,end (the fixnum (+ (the fixnum ,len) ,n-offset))))
+	     (declare (fixnum ,len ,end))
+	     (check<= ,len ,(cadr type))
+	     (%primitive byte-blt ,n-value 0 ,n-sap ,n-offset ,end)
+	     (%primitive 8bit-system-set ,n-sap
+			 (the fixnum (1+ ,end)) 0))))))
+
+
+;;;; Pointer alien access:
+
+;;; Alien-Access expert for System-Area-Pointer  --  Internal
+;;;
+;;;    Get or store a pointer.  In the store case this is the same
+;;; as Pointer.
+;;;
+(define-alien-access (system-area-pointer system-area-pointer alien)
+  (type kind value)
+  (with-alien (sap)
+	      (offset)
+	      (size :constant 2)
+    (declare (ignore size))
+    (if (eq kind :read)
+	`(%primitive sap-system-ref ,sap ,offset)
+	`(%primitive pointer-system-set ,sap ,offset ,value))))
+
+;;; Alien-Access expert for (Alien <type> [<bits>])  --  Internal
+;;;
+;;;    Get or store an alien value.  On read, we cons up a value, getting
+;;; the size of out the type.  On write, we just store the SAP.
+;;;
+(define-alien-access (alien) (type kind value)
+  (with-alien (sap)
+	      (offset)
+	      (size :constant 2)
+    (declare (ignore size))
+    (unless (and (consp type) (consp (cdr type)))
+      (error "Bad type for accessing as an Alien: ~S" type))
+    (let ((atype (second type))
+	  (size (third type)))
+      (cond
+       ((eq kind :read)
+	(unless size
+	  (error "Size not specified when reading alien type: ~S" type))
+	(unless (and (integerp size) (>= size 0))
+	  (error "Size is not a positive integer: ~S" type))
+	`(make-alien-value
+	  (%primitive sap-system-ref ,sap ,offset)
+	  0
+	  ,size
+	  ',atype))
+       (t
+	`(%primitive pointer-system-set ,sap ,offset
+		     (alien-value-sap ,value)))))))
+
+;;; Alien-Access expert for (Pointer xxx)  --  Internal
+;;;
+;;;    We can't read pointers, and can only store pointers to unboxed
+;;; things.
+;;;
+(define-alien-access (pointer pointer alien) (type kind value)
+  (with-alien (sap)
+	      (offset)
+	      (size :constant 2)
+    (declare (ignore size))
+    (when (eq kind :read)
+      (error "Cannot read with Pointer Alien type:~%~S" type))
+    `(%primitive pointer-system-set ,sap ,offset ,value)))
+
+
+;;;; Enumeration Alien access:
+
+(compiler-let ((lisp::*bootstrap-defmacro* t))
+
+;;; Defenumeration  --  Public
+;;;
+;;;    Cons up the from alist, keeping track of the minimum and maximum
+;;; values, then decide whether to use a vector or alist to mapping.
+;;;
+(defmacro defenumeration (name &rest elements)
+  "Defenumeration Name {{Element}+ | {(Element Value)}+}
+  Define an enumeration for use with Alien-Access and the Enumeration
+  Alien type."
+  (let ((min nil)
+	(max nil)
+	(from-alist ()))
+    (declare (list from-alist))
+    (when (null elements)
+      (error "An anumeration must contain at least one element."))
+    (if (listp (car elements))
+	(dolist (el elements)
+	  (unless (listp el)
+	    (error "Element value is not specified: ~S." el))
+	  (push (cons (first el) (second el)) from-alist))
+	(let ((num -1))
+	  (dolist (el elements)
+	    (push (cons el (incf num)) from-alist))))
+    (do ((el from-alist (cdr el)))
+	((null el))
+      (let ((sym (caar el))
+	    (val (cdar el)))
+	(unless (keywordp sym)
+	  (error "Enumeration element ~S is not a keyword." sym))
+	(unless (integerp val)
+	  (error "Element value ~S is not an integer." val))
+	(unless (and max (> max val)) (setq max val))
+	(unless (and min (< min val)) (setq min val))
+	(when (rassoc val (cdr el))
+	  (error "Element value ~S used more than once." val))
+	(when (assq sym (cdr el))
+	  (error "Enumeration element ~S used more than once." sym))))
+    (let* ((signed (minusp min))
+	   (to (intern (concatenate 'simple-string (string name)
+				    "-TO-ENUMERATION-" (string (gensym)))))
+	   (from (intern (concatenate 'simple-string (string name)
+				      "-FROM-ENUMERATION-" (string (gensym)))))
+	   (info (make-enumeration-info :signed signed
+					:size (if signed
+						  (1+ (max (integer-length min)
+							   (integer-length max)))
+						  (integer-length max))
+					:from from  :to to))
+	   to-thing)
+      (cond
+       ;;
+       ;; If range is at least 20% dense, use vector mapping.  Crossover
+       ;; point solely on basis of space would be 25%.  Vector mapping
+       ;; is always faster, so give the benefit of the doubt.
+       ((< 0.2 (/ (float (length from-alist)) (float (- max min))))
+	;;
+	;; If offset is small and ignorable, ignore it to save time.
+	(when (< 0 min 10) (setq min 0))
+	(setq to-thing (make-array (1+ (- max min))))
+	(dolist (el from-alist)
+	  (setf (svref to-thing (- (cdr el) min)) (car el)))
+	(setf (enumeration-info-kind info) :vector)
+	(setf (enumeration-info-offset info) (- min)))
+       (t
+	(setf (enumeration-info-kind info) :alist)
+	(setq to-thing (mapcar #'(lambda (x) (cons (cdr x) (car x))) from-alist))))
+      `(progn
+	(eval-when (compile load eval)
+	  (proclaim '(special ,to ,from))
+	  (set ',to ',to-thing)
+	  (set ',from ',from-alist))
+	(eval-when ,*alien-eval-when*
+	  (setf (info enumeration info ',name) ',info))
+	',name))))
+
+); compiler-let
+
+;;; Enumeration-Error  --  Internal
+;;;
+;;;    Tell the luser what permissable values the enumeration has when she
+;;; gives us something bogus.  We even give them a chance to specify
+;;; something else.
+;;;
+(defun enumeration-error (alist)
+  (loop
+   (cerror "Prompt for a new value."
+	   "Enumeration value is not one of the following: ~{~<~%  ~:;~S ~>~}"
+	  (mapcar #'car alist))
+   (write-string "New value: " *query-io*)
+   (let* ((response (read *query-io*))
+	  (res (cdr (assq response alist))))
+     (when res (return res)))))
+
+
+(define-alien-access (enumeration) (type kind value form)
+  (let* ((enum (cadr type))
+	 (info (or (info enumeration info enum)
+		   (error "~S is not a defined enumeration." enum)))
+	 (signed (enumeration-info-signed info))
+	 (to (enumeration-info-to info))
+	 (from (enumeration-info-from info)))
+    (with-alien (sap)
+		(offset :unit nil)
+		(size :unit nil
+		      :minimum (enumeration-info-size info))
+      (if (eq kind :read)
+	  (ecase (enumeration-info-kind info)
+	    (:vector
+	     `(svref ,to
+		     (+ ,(enumeration-info-offset info)
+			(naturalize-integer ,signed ,sap ,offset ,size
+					    ',form))))
+	    (:alist
+	     `(cdr (assoc (naturalize-integer ,signed ,sap ,offset ,size
+					      ',form)
+			  ,to))))
+	  `(deport-integer
+	    ,signed ,sap ,offset ,size
+	    (or (cdr (assq ,value ,from))
+		(enumeration-error ,from))
+	    ',form)))))
+
diff --git a/code/array.lisp b/code/array.lisp
new file mode 100644
index 000000000..3ee656af4
--- /dev/null
+++ b/code/array.lisp
@@ -0,0 +1,869 @@
+;;; -*- Log: code.log; Package: Lisp -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; Functions to implement arrays for Spice Lisp 
+;;; Written by Skef Wholey.
+;;;
+(in-package "LISP")
+
+(export '(array-rank-limit array-dimension-limit array-total-size-limit
+	  make-array vector aref array-element-type array-rank
+	  array-dimension array-dimensions array-in-bounds-p
+	  array-row-major-index array-total-size svref bit sbit
+	  bit-and bit-ior bit-xor bit-eqv bit-nand bit-nor bit-andc1 bit-andc2
+	  bit-orc1 bit-orc2 bit-not array-has-fill-pointer-p
+	  fill-pointer vector-push vector-push-extend vector-pop adjust-array
+          adjustable-array-p row-major-aref))
+
+(defconstant array-rank-limit 65529
+  "The exclusive upper bound on the rank of an array.")
+
+(defconstant array-dimension-limit most-positive-fixnum
+  "The exclusive upper bound any given dimension of an array.")
+
+(defconstant array-total-size-limit most-positive-fixnum
+  "The exclusive upper bound on the total number of elements in an array.")
+
+
+;;; Random function used by WITH-ARRAY-DATA, which has to be defined in
+;;; init.lisp.
+;;;
+(defun find-data-vector (array)
+  (do ((data array (%primitive header-ref data %array-data-slot))
+       (cumulative-offset 0
+			  (the fixnum
+			       (+ cumulative-offset
+				  (the fixnum
+				       (or (%primitive header-ref data
+						       %array-displacement-slot)
+					   0))))))
+      ((not (array-header-p data))
+       (values data cumulative-offset))
+    (declare (fixnum cumulative-offset))))
+
+
+
+(defun make-array (dimensions &key
+			      (element-type t)
+			      (initial-element nil initial-element-p)
+			      initial-contents adjustable fill-pointer
+			      displaced-to displaced-index-offset)
+  "Creates an array of the specified Dimensions.  See manual for details."
+  (unless (listp dimensions) (setq dimensions (list dimensions)))
+  (let ((array-rank (length (the list dimensions))))
+    (declare (fixnum array-rank))
+    (if (eq fill-pointer t) (setq fill-pointer (car dimensions)))
+    (if (and fill-pointer (> array-rank 1))
+	(error "Multidimensional arrays can't have fill pointers."))
+    (cond (displaced-to
+	   ;; If the array is displaced, make a header and fill it up.
+	   (unless (subtypep element-type (array-element-type displaced-to))
+	     (error "One can't displace an array of type ~S into another of ~
+		    type ~S." element-type (array-element-type displaced-to)))
+	   (if (or initial-element initial-contents)
+	       (error "The :initial-element or initial-contents option may not ~
+		       be specified with :displaced-to."))
+	   (let ((displacement (or displaced-index-offset 0))
+		 (array-size (array-linear-length dimensions)))
+	     (declare (fixnum displacement array-size))
+	     (if (< (the fixnum (array-total-size displaced-to))
+		    (the fixnum (+ displacement array-size)))
+		 (error "The :displaced-to array is too small."))
+	     (set-array-header (%primitive alloc-array array-rank)
+			       displaced-to array-size
+			       (or fill-pointer array-size)
+			       displacement dimensions t)))
+	  ((and (not adjustable) (= array-rank 1) (not fill-pointer))
+	   ;; If the array can be represented as a simple thing, do that.
+	   (if (and initial-element-p initial-contents)
+	       (error "The :initial-contents option may not be specified with ~
+		       :initial-element."))
+	   (data-vector-from-inits dimensions (car dimensions) array-rank
+				   element-type initial-contents
+				   initial-element initial-element-p))
+	  (t
+	   ;; Otherwise, build a complex array.
+	   (if (and initial-element-p initial-contents)
+	       (error "The :initial-contents option may not be specified with ~
+		       :initial-element."))
+	   (let* ((array-size (array-linear-length dimensions))
+		  (array (%primitive alloc-array array-rank))
+		  (array-data (data-vector-from-inits
+			       dimensions array-size array-rank element-type
+			       initial-contents initial-element
+			       initial-element-p)))
+	     (set-array-header array array-data array-size
+			       (or fill-pointer array-size)
+			       0 ;displacement
+			       dimensions nil))))))
+
+;;; Some people out there are still calling MAKE-VECTOR:
+;;;
+(setf (symbol-function 'make-vector) #'make-array)
+
+(defun vector (&rest objects)
+  "Constructs a simple-vector from the given objects."
+  (coerce (the list objects) 'simple-vector))
+
+;;; DATA-VECTOR-FROM-INITS returns a simple vector that has the specified array
+;;; characteristics.  Dimensions is only used to pass to COPY-CONTENTS-AUX
+;;; for error checking on the structure of initial-contents.
+;;;
+(defun data-vector-from-inits (dimensions total-size rank element-type
+			       initial-contents initial-element
+			       initial-element-p)
+  (let ((data (cond ((subtypep element-type 'string-char)
+		     (%primitive alloc-string total-size))
+		    ((subtypep element-type '(unsigned-byte 32))
+		     (%primitive alloc-i-vector total-size
+				 (element-type-to-access-code element-type)))
+		    (t
+		     (%primitive alloc-g-vector total-size initial-element)))))
+    (cond (initial-element-p
+	   (unless (simple-vector-p data)
+	     (unless (typep initial-element element-type)
+	       (error "~S cannot be used to initialize an array of type ~S."
+		      initial-element element-type))
+	     (fill (the vector data) initial-element)))
+	  (initial-contents
+	   (copy-contents-aux dimensions initial-contents element-type
+			      rank 0 data)))
+    data))
+
+;;; COPY-CONTENTS-AUX spins down into the Data vector and the Initial-Contents
+;;; filling the former from the latter.
+;;;
+(defun copy-contents-aux (dimensions initial-contents element-type
+			  depth index data)
+  (declare (fixnum depth index))
+  (cond ((= depth 0)
+	 (unless (typep initial-contents element-type)
+	   (error "~S cannot be used to initialize an array of element-type ~S."
+		  initial-contents element-type))
+	 (setf (aref data index) initial-contents)
+	 (the fixnum (1+ index)))
+	((listp initial-contents)
+	 (unless (= (length (the list initial-contents)) (car dimensions))
+	   (error "This part of initial-contents, ~S, is an unappropriate ~
+		   length for the dimension, ~S."
+		  initial-contents (car dimensions)))
+	 (do ((initial-contents initial-contents (cdr initial-contents))
+	      (next-dimensions (cdr dimensions))
+	      (next-depth (the fixnum (1- depth))))
+	     ((null initial-contents) index)
+	   (declare (list initial-contents))
+	   (setq index (copy-contents-aux
+			next-dimensions (car initial-contents) element-type
+			next-depth index data))))
+	((vectorp initial-contents)
+	 (unless (= (length (the vector initial-contents)) (car dimensions))
+	   (error "This part of initial-contents, ~S, is an unappropriate ~
+		   length for the dimension, ~S."
+		  initial-contents (car dimensions)))
+	 (do ((i-index 0 (1+ i-index))
+	      (i-end (length (the vector initial-contents)))
+	      (next-dimensions (cdr dimensions))
+	      (next-depth (the fixnum (1- depth))))
+	     ((= i-index i-end) index)
+	   (declare (fixnum i-index i-end))
+	   (setq index (copy-contents-aux
+			next-dimensions (aref initial-contents index)
+			element-type next-depth index data))))
+	(t
+	 (error "~S is not a sequence, and cannot be used to initialize~%~
+		the contents of an array." initial-contents))))
+
+;;; ELEMENT-TYPE-TO-ACCESS-CODE returns the Spice Lisp I-Vector access code to
+;;; be used for the data vector of an array with the given access code.
+;;;
+(defun element-type-to-access-code (type)
+  (cond ((subtypep type 'bit) 0)
+	((subtypep type '(unsigned-byte 2)) 1)
+	((subtypep type '(unsigned-byte 4)) 2)
+	((subtypep type '(unsigned-byte 8)) 3)
+	((subtypep type '(unsigned-byte 16)) 4)
+	((subtypep type '(unsigned-byte 32)) 5)
+	(t (error "Unexpected array element type -- ~S." type))))
+
+
+;;; ARRAY-LINEAR-LENGTH returns the number of elements an array with the
+;;; specified dimensions would have.
+;;;
+(defun array-linear-length (dimensions)
+  (do ((dimensions dimensions (cdr dimensions))
+       (length 1))
+      ((null dimensions) length)
+    (declare (fixnum length))
+    (setq length (* length (the fixnum (car dimensions))))))
+
+(defun aref (array &rest subscripts)
+  "Returns the element of the Array specified by the Subscripts."
+  (if (and subscripts (null (cdr subscripts)))
+      (aref array (car subscripts))
+      (do ((subscripts (nreverse (the list subscripts)) (cdr subscripts))
+	   (dim-index (1- (the fixnum (%primitive header-length array)))
+		      (1- dim-index))
+	   (chunk-size 1)
+	   (result 0))
+	  ((= (the fixnum dim-index) %array-dim-base)
+	   (if (atom subscripts)
+	       (with-array-data ((data array) (start) (end))
+		 (declare (ignore end))
+		 (aref data (the fixnum (+ start result))))
+	       (error "Too many subscripts for array reference.")))
+	(declare (fixnum dim-index chunk-size result))
+	(let ((axis (%primitive header-ref array dim-index)))
+	  (declare (fixnum axis))
+	  (cond ((atom subscripts)
+		 (error "Too few subscripts for array reference."))
+		((not (< -1 (the fixnum (car subscripts)) axis))
+		 (error "Subscript ~S is out of bounds." (car subscripts)))
+		(t
+		 (setq result (the fixnum
+				   (+ result
+				      (the fixnum
+					   (* (the fixnum (car subscripts))
+					      chunk-size)))))
+		 (setq chunk-size (* chunk-size axis))))))))
+
+(defun %aset (array &rest stuff)
+  (if (and (cdr stuff) (null (cddr stuff)))
+      (setf (aref array (car stuff)) (cadr stuff))
+      (let ((rstuff (nreverse (the list stuff))))
+	(do ((subscripts (cdr rstuff) (cdr subscripts))
+	     (dim-index (1- (the fixnum (%primitive header-length array)))
+			(1- dim-index))
+	     (chunk-size 1)
+	     (result 0))
+	    ((= dim-index %array-dim-base)
+	     (if (atom subscripts)
+		 (with-array-data ((data array) (start) (end))
+		   (declare (ignore end))
+		   (setf (aref data (+ start result)) (car rstuff)))
+		 (error "Too many subscripts for array reference.")))
+	  (declare (fixnum dim-index chunk-size result))
+	  (let ((axis (%primitive header-ref array dim-index)))
+	    (declare (fixnum axis))
+	    (cond ((atom subscripts)
+		   (error "Too few subscripts for array reference."))
+		  ((not (< -1 (the fixnum (car subscripts)) axis))
+		   (error "Subscript ~S is out of bounds."
+			  (car subscripts)))
+		  (t
+		   (setq result (+ result
+				   (the fixnum (* (the fixnum (car subscripts))
+						  chunk-size))))
+		   (setq chunk-size (* chunk-size axis)))))))))
+
+
+;;; %Apply-aset is called when (setf (apply #'aref ...) new-value) is
+;;; called.
+
+(defun %apply-aset (new-value array &rest stuff)
+  (if (null (cdr stuff))
+      (setf (aref array (car stuff)) new-value)
+      (let ((rstuff (nreverse (the list stuff))))
+	(do ((subscripts rstuff (cdr subscripts))
+	     (dim-index (1- (the fixnum (%primitive header-length array)))
+			(1- dim-index))
+	     (chunk-size 1)
+	     (result 0))
+	    ((= dim-index %array-dim-base)
+	     (if (atom subscripts)
+		 (with-array-data ((data array) (start) (end))
+				  (declare (ignore end))
+				  (setf (aref data (+ start result)) new-value))
+		 (error "Too many subscripts for array reference.")))
+	  (declare (fixnum dim-index chunk-size result))
+	  (let ((axis (%primitive header-ref array dim-index)))
+	    (declare (fixnum axis))
+	    (cond ((atom subscripts)
+		   (error "Too few subscripts for array reference."))
+		  ((not (< -1 (the fixnum (car subscripts)) axis))
+		   (error "Subscript ~S is out of bounds."
+			  (car subscripts)))
+		  (t
+		   (setq result (+ result
+				   (the fixnum (* (the fixnum (car subscripts))
+						  chunk-size))))
+		   (setq chunk-size (* chunk-size axis)))))))))
+
+(defun array-element-type (array)
+  "Returns the type of the elements of the array"
+  (cond ((bit-vector-p array)
+	 '(mod 2))
+	((stringp array)
+	 'string-char)
+	((simple-vector-p array)
+	 t)
+	((array-header-p array)
+	 (with-array-data ((data array) (start) (end))
+	   (declare (ignore start end))
+	   (array-element-type data)))
+	((vectorp array)
+	 (case (%primitive get-vector-access-code array)
+	   (0 'bit)
+	   (1 '(unsigned-byte 2))
+	   (2 '(unsigned-byte 4))
+	   (3 '(unsigned-byte 8))
+	   (4 '(unsigned-byte 16))
+	   (5 '(unsigned-byte 32))))
+	(t (error "~S is not an array." array))))
+
+(defun array-rank (array)
+  "Returns the number of dimensions of the Array."
+  (if (array-header-p array)
+      (the fixnum (- (the fixnum (%primitive header-length array))
+		     %array-first-dim-slot))
+      1))
+
+(defun array-dimension (array axis-number)
+  "Returns length of dimension Axis-Number of the Array."
+  (declare (fixnum axis-number))
+  (if (array-header-p array)
+      (if (and (>= axis-number 0)
+	       (< axis-number (the fixnum (array-rank array))))
+	  (%primitive header-ref array (the fixnum (+ %array-first-dim-slot axis-number)))
+	  (error "~S is an illegal axis number." axis-number))
+      (if (= axis-number 0)
+	  (%primitive vector-length array)
+	  (error "~S is an illegal axis number." axis-number))))
+
+(defun array-dimensions (array)
+  "Returns a list whose elements are the dimensions of the array"
+  (if (array-header-p array)
+      (do ((index %array-first-dim-slot (1+ index))
+	   (end (%primitive header-length array))
+	   (result ()))
+	  ((= index end) (nreverse result))
+	(declare (fixnum index end))
+	(push (%primitive header-ref array index) result))
+      (list (%primitive vector-length array))))
+
+(defun array-total-size (array)
+  "Returns the total number of elements in the Array."
+  (if (array-header-p array)
+      (%primitive header-ref array %array-length-slot)
+      (%primitive vector-length array)))
+
+(defun array-in-bounds-p (array &rest subscripts)
+  "Returns T if the Subscipts are in bounds for the Array, Nil otherwise."
+  (if (array-header-p array)
+      (do ((dim-index %array-first-dim-slot (1+ dim-index))
+	   (dim-index-limit (+ %array-first-dim-slot
+			       (the fixnum (array-rank array))))
+	   (subs subscripts (cdr subs)))
+	  ((= dim-index dim-index-limit)
+	   (atom subs))
+	(declare (fixnum dim-index dim-index-limit))
+	(if (atom subs)
+	    (return nil)
+	    (if (not (< -1
+			(the fixnum (car subs))
+			(the fixnum (%primitive header-ref array dim-index))))
+		(return nil))))
+      (and (null (cdr subscripts))
+	   (< -1
+	      (the fixnum (car subscripts))
+	      (the fixnum (%primitive vector-length array))))))
+
+(defun array-row-major-index (array &rest subscripts)
+  "Returns the index into the Array's data vector for the given subscripts."
+  (if (array-header-p array)
+      (do ((subscripts (nreverse (the list subscripts)) (cdr subscripts))
+	   (dim-index (1- (the fixnum (%primitive header-length array)))
+		      (1- dim-index))
+	   (chunk-size 1)
+	   (result 0))
+	  ((= dim-index %array-dim-base)
+	   (if (atom subscripts)
+	       result
+	       (error "Too many subscripts for array reference.")))
+	(declare (fixnum dim-index chunk-size result))
+	(let ((axis (%primitive header-ref array dim-index)))
+	  (declare (fixnum axis))
+	  (cond ((null subscripts)
+		 (error "Too few subscripts for array reference."))
+		((not (< -1 (the fixnum (car subscripts)) axis))
+		 (error "Subscript ~S is out of bounds." (car subscripts)))
+		(t
+		 (setq result (+ result
+				 (the fixnum (* (the fixnum (car subscripts))
+						chunk-size))))
+		 (setq chunk-size (* chunk-size axis))))))
+      (cond ((null subscripts)
+	     (error "Too few subscripts for array reference."))
+	    ((not (< -1
+		     (the fixnum (car subscripts))
+		     (length (the simple-array array))))
+	     (error "Subscript ~S is out of bounds." (car subscripts)))
+	    (t
+	     (car subscripts)))))
+
+
+(defun adjustable-array-p (array)
+  "Returns T if the given Array is adjustable, or Nil otherwise."
+  (array-header-p array))
+
+
+(defun row-major-aref (array index)
+  "Returns the element of array corressponding to the row-major index.  This is
+   SETF'able."
+  (with-array-data ((data array) (start) (end))
+    (declare (ignore end))
+    (aref data (+ start index))))
+
+(defsetf row-major-aref %set-row-major-aref)
+
+(defun %set-row-major-aref (array index new-value)
+  (with-array-data ((data array) (start) (end))
+    (declare (ignore end))
+    (setf (aref data (+ start index)) new-value)))
+
+(defun svref (simple-vector index)
+  "Returns the Index'th element of the given Simple-Vector."
+  (svref simple-vector index))
+
+(defun %svset (simple-vector index new)
+  (setf (svref simple-vector index) new))
+
+;;; The following function is used when (setf (apply #'svref ...) new
+;;; is compiled.
+
+(defun %apply-svset (new simple-vector index)
+  (setf (svref simple-vector index) new))
+
+(defun array-has-fill-pointer-p (array)
+  "Returns T if the given Array has a fill pointer, or Nil otherwise."
+  (and (vectorp array) (array-header-p array)))
+
+(defun fill-pointer (vector)
+  "Returns the Fill-Pointer of the given Vector."
+  (if (and (vectorp vector) (array-header-p vector))
+      (%primitive header-ref vector %array-fill-pointer-slot)
+      (error "~S is not an array with a fill-pointer." vector)))
+
+(defun %set-fill-pointer (vector new)
+  (declare (fixnum new))
+  (if (and (vectorp vector) (array-header-p vector))
+      (if (> new (the fixnum (%primitive header-ref vector %array-length-slot)))
+	  (error "New fill pointer, ~S, is larger than the length of the vector."
+		 new)
+	  (%primitive header-set vector %array-fill-pointer-slot new))
+      (error "~S is not an array with a fill-pointer." vector)))
+
+(defun vector-push (new-el array)
+  "Attempts to set the element of Array designated by the fill pointer
+   to New-El and increment fill pointer by one.  If the fill pointer is
+   too large, Nil is returned, otherwise the new fill pointer value is 
+   returned."
+  (if (array-header-p array)
+      (let ((fill-pointer (%primitive header-ref array %array-fill-pointer-slot)))
+	(declare (fixnum fill-pointer))
+	(cond ((= fill-pointer
+		  (the fixnum (%primitive header-ref array %array-length-slot)))
+	       nil)
+	      (t (%primitive header-set array %array-fill-pointer-slot
+			     (1+ fill-pointer))
+		 (with-array-data ((data array) (start) (end))
+		   (declare (ignore end))
+		   (setf (aref data (+ fill-pointer start)) new-el))
+		 fill-pointer)))
+      (error "~S: Object has no fill pointer." array)))
+
+(defun vector-push-extend (new-el array &optional (extension (length array)))
+  "Like Vector-Push except that if the fill pointer gets too large, the
+   Array is extended rather than Nil being returned."
+  (declare (fixnum extension))
+  (if (array-header-p array)
+      (let ((length (%primitive header-ref array %array-length-slot))
+	    (fill-pointer (%primitive header-ref array %array-fill-pointer-slot)))
+	(declare (fixnum length fill-pointer))
+	(with-array-data ((data array) (start) (end))
+	  (declare (ignore end))
+	  (if (= fill-pointer length)
+	      (do* ((new-index 0 (1+ new-index))
+		    (new-length (let ((l (+ length extension)))
+				  (declare (fixnum l))
+				  (if (zerop l) 1 l)))
+		    (old-index start (1+ old-index))
+		    (new-data (make-array (if (zerop new-length) 1 new-length)
+					  :element-type (array-element-type
+							 array))))
+		   ((= new-index length)
+		    (setq data new-data)
+		    (setq start 0)
+		    (set-array-header array data new-length
+				      (1+ fill-pointer) start new-length nil))
+		(declare (fixnum new-index new-length old-index))
+		(setf (aref new-data new-index) (aref data old-index)))
+	      (%primitive header-set array
+			  %array-fill-pointer-slot (1+ fill-pointer)))
+	  (setf (aref data (+ fill-pointer start)) new-el)
+	  fill-pointer))
+      (error "~S has no fill pointer." array)))
+
+(defun vector-pop (array)
+  "Attempts to decrease the fill-pointer by 1 and return the element
+   pointer to by the new fill pointer.  If the new value of the fill
+   pointer is 0, an error occurs."
+  (if (array-header-p array)
+      (let ((fill-pointer (%primitive header-ref array %array-fill-pointer-slot)))
+	(declare (fixnum fill-pointer))
+	(cond ((< fill-pointer 1)
+	       (error "Fill-pointer reached 0."))
+	      (t
+	       (let ((fill-pointer (1- fill-pointer)))
+		 (declare (fixnum fill-pointer))
+		 (with-array-data ((data array) (start) (end))
+		   (declare (ignore end))
+		   (%primitive header-set array %array-fill-pointer-slot
+			       fill-pointer)
+		   (aref data (+ fill-pointer start)))))))
+      (error "~S: Object has no fill pointer." array)))
+
+
+
+(defun get-new-fill-pointer (new-array-size fill-pointer old-fill-pointer)
+  (cond ((not fill-pointer)
+	 old-fill-pointer)
+	((numberp fill-pointer)
+	 fill-pointer)
+	(t new-array-size)))
+
+(defun adjust-array (array dimensions &key
+			   (element-type (array-element-type array))
+			   (initial-element nil initial-element-p)
+			   initial-contents fill-pointer
+			   displaced-to displaced-index-offset)
+  "Adjusts the Array's dimensions to the given Dimensions and stuff."
+  (unless (listp dimensions) (setq dimensions (list dimensions)))
+  (cond ((not (array-header-p array))
+	 (error "~S is not an adjustable array." array))
+	((/= (the fixnum (length (the list dimensions)))
+	     (the fixnum (array-rank array)))
+	 (error "Number of dimensions not equal to rank of array."))
+	((not (subtypep element-type (array-element-type array)))
+	 (error "New element type, ~S, is incompatible with old."
+		element-type)))
+  (let ((array-rank (length (the list dimensions)))
+	(old-fill-pointer (fill-pointer array)))
+    (declare (fixnum array-rank))
+    (when (and fill-pointer (> array-rank 1))
+      (error "Multidimensional arrays can't have fill pointers."))
+    (cond (initial-contents
+	   (if (or initial-element-p displaced-to)
+	       (error "Initial contents may not be specified with ~
+		       the :initial-element or :displaced-to option."))
+	   (let* ((array-size (array-linear-length dimensions))
+		  (array-data (data-vector-from-inits
+			       dimensions array-size array-rank element-type
+			       initial-contents initial-element
+			       initial-element-p)))
+	     (set-array-header array array-data array-size
+			       (get-new-fill-pointer array-size fill-pointer
+						     old-fill-pointer)
+			       0 dimensions nil)))
+	  (displaced-to
+	   (when initial-element ;no initial-contents supplied is already known
+	       (error "The :initial-element option may not be specified ~
+		       with :displaced-to."))
+	   (unless (subtypep element-type (array-element-type displaced-to))
+	     (error "One can't displace an array of type ~S into another of ~
+		     type ~S." element-type (array-element-type displaced-to)))
+	   (let ((displacement (or displaced-index-offset 0))
+		 (array-size (array-linear-length dimensions)))
+	     (declare (fixnum displacement array-size))
+	     (if (< (the fixnum (array-total-size displaced-to))
+		    (the fixnum (+ displacement array-size)))
+		 (error "The :displaced-to array is too small."))
+	     (set-array-header array displaced-to array-size
+			       (get-new-fill-pointer array-size fill-pointer
+						     old-fill-pointer)
+			       displacement dimensions t)))
+	  ((= array-rank 1)
+	   (let ((old-length (%primitive header-ref array %array-length-slot))
+		 (new-length (car dimensions))
+		 new-data)
+	     (declare (fixnum old-length new-length))
+	     (with-array-data ((old-data array) (old-start)
+			       (old-end old-length))
+	       (cond ((or (%displacedp array) (< old-length new-length))
+		      (setf new-data
+			    (data-vector-from-inits
+			     dimensions new-length array-rank element-type
+			     initial-contents initial-element
+			     initial-element-p))
+		      (replace new-data old-data
+			       :start2 old-start :end2 old-end))
+		      (t (setf new-data
+			       (%primitive shrink-vector old-data new-length))))
+	       (set-array-header array new-data new-length
+				 (get-new-fill-pointer new-length fill-pointer
+						       old-fill-pointer)
+				 0 dimensions nil))))
+	  (t
+	   (let ((old-length (%primitive header-ref array %array-length-slot))
+		 (new-length (array-linear-length dimensions)))
+	     (declare (fixnum old-length new-length))
+	     (with-array-data ((old-data array) (old-start)
+			       (old-end old-length))
+	       (declare (ignore old-end))
+	       (let ((new-data (if (or (%displacedp array)
+				       (> new-length old-length))
+				   (data-vector-from-inits
+				    dimensions new-length array-rank
+				    element-type () initial-element
+				    initial-element-p)
+				   old-data)))
+		 (zap-array-data old-data (array-dimensions array) old-start
+				 new-data dimensions new-length element-type
+				 initial-element initial-element-p)
+		 (set-array-header array new-data new-length
+				   new-length 0 dimensions nil)))))))
+  array)
+
+(defun shrink-vector (vector new-size)
+  "Destructively alters the Vector, changing its length to New-Size, which
+   must be less than or equal to its current size."
+  (cond ((array-header-p vector)
+	 ;; (%primitive shrink-vector
+	 ;;		(%primitive header-ref vector %array-data-slot)
+	 ;;		new-size)
+	 ;; (%primitive header-set vector %array-length-slot new-size)
+	 ;; Instead of shrinking the vector, just set the fill-pointer field.
+	 (%primitive header-set vector %array-fill-pointer-slot new-size)
+	 vector)
+	(t
+	 (%primitive shrink-vector vector new-size))))
+
+(defun set-array-header (array data length fill-pointer displacement dimensions
+			 &optional displacedp)
+  "Fills in array header with provided information.  Returns array."
+  (%primitive header-set array %array-data-slot data)
+  (%primitive header-set array %array-length-slot length)
+  (%primitive header-set array %array-fill-pointer-slot fill-pointer)
+  (%primitive header-set array %array-displacement-slot displacement)
+  (if (listp dimensions)
+      (do ((index %array-first-dim-slot (1+ index))
+	   (dims dimensions (cdr dims)))
+	  ((null dims))
+	(declare (fixnum index))
+	(%primitive header-set array index (car dims)))
+      (%primitive header-set array %array-first-dim-slot dimensions))
+  (%set-array-displacedp array displacedp)
+  array)
+
+
+;;; Zap-Array-Data does the grinding work for Adjust-Array.  The data is zapped
+;;; from the Old-Data in an arrangement specified by the Old-Dims to the
+;;; New-Data in an arrangement specified by the New-Dims.  Offset is a displaced
+;;; offset to be added to computed indexes of Old-Data.  New-Length, Element-Type,
+;;; Initial-Element, and Initial-Element-P are used when Old-Data and New-Data
+;;; are EQ; in this case, a temporary must be used and filled appropriately.
+;;; When Old-Data and New-Data are not EQ, New-Data has already been filled with
+;;; any specified initial-element.
+
+;;; Make a temporary to be used when old-data and new-data are EQ.
+(defvar *zap-array-data-temp* (%primitive alloc-g-vector 1000 t))
+
+(defun zap-array-data-temp (length element-type initial-element initial-element-p)
+  (declare (fixnum length))
+  (if (> length (the fixnum (length *zap-array-data-temp*)))
+      (setf *zap-array-data-temp* (%primitive alloc-g-vector length t)))
+  (when initial-element-p
+    (unless (typep initial-element element-type)
+      (error "~S cannot be used to initialize an array of type ~S."
+	     initial-element element-type))
+    (fill (the simple-vector *zap-array-data-temp*) initial-element :end length))
+  *zap-array-data-temp*)
+
+;;; Bump-Index-List helps us out:
+(eval-when (compile eval)
+(defmacro bump-index-list (index limits)
+  `(do ((subscripts ,index (cdr subscripts))
+	(limits ,limits (cdr limits)))
+       ((null subscripts) nil)
+     (cond ((< (the fixnum (car subscripts))
+	       (the fixnum (car limits)))
+	    (rplaca subscripts (1+ (the fixnum (car subscripts))))
+	    (return ,index))
+	   (t (rplaca subscripts 0)))))
+)
+
+(defun zap-array-data (old-data old-dims offset new-data new-dims new-length
+		       element-type initial-element initial-element-p)
+  (declare (list old-dims new-dims))
+  (setq old-dims (nreverse old-dims))
+  (setq new-dims (reverse new-dims))
+  (if (eq old-data new-data)
+      (let ((temp (zap-array-data-temp new-length element-type
+				       initial-element initial-element-p)))
+	(zap-array-data-aux old-data old-dims offset temp new-dims)
+	(dotimes (i new-length) (setf (aref new-data i) (aref temp i))))
+      (zap-array-data-aux old-data old-dims offset new-data new-dims)))
+      
+
+(defun zap-array-data-aux (old-data old-dims offset new-data new-dims)
+  (declare (fixnum offset))
+  (let ((limits (mapcar #'(lambda (x y)
+			    (declare (fixnum x y))
+			    (1- (the fixnum (min x y))))
+			old-dims new-dims)))
+    (do ((index (make-list (length old-dims) :initial-element 0)
+		(bump-index-list index limits)))
+	((null index))
+      (setf (aref new-data (row-major-index-from-dims index new-dims))
+	    (aref old-data
+		  (+ (the fixnum (row-major-index-from-dims index old-dims))
+		     offset))))))
+
+
+;;; ROW-MAJOR-INDEX-FROM-DIMS figures out the row-major-order index of an
+;;; array reference from a list of subscripts and a list of dimensions.
+;;; This is for internal calls only, and the subscripts and dim-list variables
+;;; are assumed to be reversed from what the user supplied.
+;;;
+(defun row-major-index-from-dims (rev-subscripts rev-dim-list)
+  (do ((rev-subscripts rev-subscripts (cdr rev-subscripts))
+       (rev-dim-list rev-dim-list (cdr rev-dim-list))
+       (chunk-size 1)
+       (result 0))
+      ((null rev-dim-list) result)
+    (declare (fixnum chunk-size result))
+    (setq result (+ result
+		    (the fixnum (* (the fixnum (car rev-subscripts))
+				   chunk-size))))
+    (setq chunk-size (* chunk-size (the fixnum (car rev-dim-list))))))
+
+
+(defun bit (bit-array &rest subscripts)
+  "Returns the bit from the Bit-Array at the specified Subscripts."
+  (apply #'aref bit-array subscripts))
+
+(defun %bitset (bit-array &rest stuff)
+  (apply #'%aset bit-array stuff))
+
+(defun sbit (simple-bit-array &rest subscripts)
+  "Returns the bit from the Simple-Bit-Array at the specified Subscripts."
+  (apply #'aref simple-bit-array subscripts))
+
+(defun %sbitset (bit-array &rest stuff)
+  (apply #'%aset bit-array stuff))
+
+(defun bit-array-same-dimensions-p (array1 array2)
+  (and (= (the fixnum (%primitive header-length array1))
+	  (the fixnum (%primitive header-length array2)))
+       (do ((index %array-first-dim-slot (1+ index))
+	    (length (- (the fixnum (%primitive header-length array1))
+		       %array-dim-base)))
+	   ((= index length) t)
+	 (declare (fixnum index length))
+	 (if (/= (the fixnum (%primitive header-ref array1 index))
+		 (the fixnum (%primitive header-ref array2 index)))
+	     (return nil)))))
+
+(defun bit-array-boole (array1 array2 op result-array)
+  (if (eq result-array t) (setq result-array array1))
+  (cond ((simple-bit-vector-p array1)
+	 (let ((length (%primitive vector-length array1)))
+	   (declare (fixnum length))
+	   (unless (and (simple-bit-vector-p array2)
+			(= (the fixnum (%primitive vector-length array2)) length))
+	     (error "~S and ~S do not have the same dimensions." array1 array2))
+	   (if result-array
+	       (unless (and (simple-bit-vector-p result-array)
+			    (= (the fixnum (%primitive vector-length result-array))
+			       length))
+		 (error "~S and ~S do not have the same dimensions."
+			array1 result-array))
+	       (setq result-array (%primitive alloc-bit-vector length)))
+	   (%primitive bit-bash array1 array2 result-array op)))
+	(t
+	 (unless (bit-array-same-dimensions-p array1 array2)
+	   (error "~S and ~S do not have the same dimensions." array1 array2))
+	 (if result-array
+	     (unless (bit-array-same-dimensions-p array1 result-array)
+	       (error "~S and ~S do not have the same dimensions."
+		      array1 result-array))
+	     (setq result-array (make-array (array-dimensions array1)
+					    :element-type '(mod 2))))
+	 (with-array-data ((data1 array1) (start1) (end1))
+	   (declare (ignore end1))
+	   (with-array-data ((data2 array2) (start2) (end2))
+	     (declare (ignore end2))
+	     (with-array-data ((data3 result-array) (start3) (end3))
+	       (declare (ignore end3))
+	       (let ((length (%primitive header-ref array1 %array-length-slot)))
+		 (declare (fixnum length))
+		 (do ((index 0 (1+ index))
+		      (index1 start1 (1+ index1))
+		      (index2 start2 (1+ index2))
+		      (index3 start3 (1+ index3)))
+		     ((= index length) result-array)
+		   (declare (fixnum index index1 index2 index3))
+		   (setf (sbit data3 index3)
+			 (boole op (sbit data1 index1)
+				(sbit data2 index2))))))))))
+  result-array)
+
+(defun bit-and (bit-array1 bit-array2 &optional result-bit-array)
+  "Performs a bit-wise logical AND on the elements of Bit-Array1 and Bit-Array2
+  putting the results in the Result-Bit-Array."
+  (bit-array-boole bit-array1 bit-array2 boole-and result-bit-array))
+
+(defun bit-ior (bit-array1 bit-array2 &optional result-bit-array)
+  "Performs a bit-wise logical IOR on the elements of Bit-Array1 and Bit-Array2
+  putting the results in the Result-Bit-Array."
+  (bit-array-boole bit-array1 bit-array2 boole-ior result-bit-array))
+
+(defun bit-xor (bit-array1 bit-array2 &optional result-bit-array)
+  "Performs a bit-wise logical XOR on the elements of Bit-Array1 and Bit-Array2
+  putting the results in the Result-Bit-Array."
+  (bit-array-boole bit-array1 bit-array2 boole-xor result-bit-array))
+
+(defun bit-eqv (bit-array1 bit-array2 &optional result-bit-array)
+  "Performs a bit-wise logical EQV  on the elements of Bit-Array1 and Bit-Array2
+  putting the results in the Result-Bit-Array."
+  (bit-array-boole bit-array1 bit-array2 boole-eqv result-bit-array))
+
+(defun bit-nand (bit-array1 bit-array2 &optional result-bit-array)
+  "Performs a bit-wise logical NAND  on the elements of Bit-Array1 and Bit-Array2
+  putting the results in the Result-Bit-Array."
+  (bit-array-boole bit-array1 bit-array2 boole-nand result-bit-array))
+
+(defun bit-nor (bit-array1 bit-array2 &optional result-bit-array)
+  "Performs a bit-wise logical NOR  on the elements of Bit-Array1 and Bit-Array2
+  putting the results in the Result-Bit-Array."
+  (bit-array-boole bit-array1 bit-array2 boole-nor result-bit-array))
+
+(defun bit-andc1 (bit-array1 bit-array2 &optional result-bit-array)
+  "Performs a bit-wise logical ANDC1 on the elements of Bit-Array1 and Bit-Array2
+  putting the results in the Result-Bit-Array."
+  (bit-array-boole bit-array1 bit-array2 boole-andc1 result-bit-array))
+
+(defun bit-andc2 (bit-array1 bit-array2 &optional result-bit-array)
+  "Performs a bit-wise logical ANDC2 on the elements of Bit-Array1 and Bit-Array2
+  putting the results in the Result-Bit-Array."
+  (bit-array-boole bit-array1 bit-array2 boole-andc2 result-bit-array))
+
+(defun bit-orc1 (bit-array1 bit-array2 &optional result-bit-array)
+  "Performs a bit-wise logical ORC1 on the elements of Bit-Array1 and Bit-Array2
+  putting the results in the Result-Bit-Array."
+  (bit-array-boole bit-array1 bit-array2 boole-orc1 result-bit-array))
+
+(defun bit-orc2 (bit-array1 bit-array2 &optional result-bit-array)
+  "Performs a bit-wise logical ORC2 on the elements of Bit-Array1 and Bit-Array2
+  putting the results in the Result-Bit-Array."
+  (bit-array-boole bit-array1 bit-array2 boole-orc2 result-bit-array))
+
+(defun bit-not (bit-array &optional result-bit-array)
+  "Performs a bit-wise logical NOT in the elements of the Bit-Array putting
+  the results into the Result-Bit-Array."
+  (bit-array-boole bit-array bit-array boole-nor result-bit-array))
diff --git a/code/c-call.lisp b/code/c-call.lisp
new file mode 100644
index 000000000..ec27554fc
--- /dev/null
+++ b/code/c-call.lisp
@@ -0,0 +1,935 @@
+;;; -*- Mode: Lisp; Package: EXTENSIONS; Log: code.log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;;    This file contains stuff used for calling out to C routines that are
+;;; linked into the Lisp process.
+;;;
+;;; Written by Rob MacLachlan.
+;;;
+(in-package "EXTENSIONS" :use '("LISP" "SYSTEM"))
+(import '(lisp::enumeration-info lisp::enumeration-info-size
+				 lisp::enumeration-info-kind
+				 lisp::enumeration-info-offset
+				 lisp::enumeration-info-to
+				 lisp::call-lisp-from-c))
+(export '(c-sizeof def-c-type def-c-record def-c-array def-c-pointer
+		   char unsigned-char short unsigned-short
+		   int unsigned-int long unsigned-long
+		   void def-c-routine def-c-variable
+		   def-c-procedure reset-foreign-pointers))
+
+#-new-compiler
+(eval-when (compile)
+  (setq lisp::*bootstrap-defmacro* t))
+
+(defvar foreign-routines-defined NIL
+  "List of symbol/routine name pairs used to reset code pointers
+  for foreign routines.")
+
+(defvar foreign-variables-defined NIL
+  "List of symbol/variable name pairs used to reset pointers to
+  foreign variables.")
+
+(eval-when (compile load eval)
+
+;;; The C-Type structure is used to represent aspects of C data representations
+;;; that aren't directly implemented by Aliens.
+;;;
+(defstruct c-type
+  ;;
+  ;; A form which is a printable representation of this type.
+  description
+  ;;
+  ;; The size in bits of objects of this type.  NIL if the size is variable.
+  (size nil :type (or unsigned-byte null))
+  ;;
+  ;; The bit alignment used for allocating objects of this type.
+  (alignment nil :type (integer 1 32)))
+
+(defun %print-c-type (s stream d)
+  (declare (ignore d))
+  (format stream "#<C-Type ~S>" (c-type-description s)))
+
+
+;;; A c-type which corresponds directly to an alien type.  The Description is
+;;; the alien type.
+;;;
+(defstruct (primitive-type
+	    (:include c-type)
+	    (:print-function %print-c-type)))
+
+
+;;; The Record-Type represnts a c structure type.
+;;;
+(defstruct (record-type
+	    (:include c-type)
+	    (:print-function %print-c-type))
+  ;;
+  ;; A list of the field descriptions for the fields in the record, in order of
+  ;; increasing bit offset.
+  (fields nil :type list))
+
+
+;;; The Field-Info structure describes a single field in a record.  The Size
+;;; recorded here may be larger than the Size in the Type, since more bits may
+;;; be allocated to the field than are actually necessary to hold a value of
+;;; that type.
+;;;
+(defstruct field-info
+  ;;
+  ;; The symbol name of this field.
+  (name nil :type symbol)
+  ;;
+  ;; The c-type of this field.
+  (type nil :type c-type)
+  ;;
+  ;; The bit offset from the start of the record that this field is located at.
+  (offset nil :type unsigned-byte)
+  ;;
+  ;; The number of bits in this field.
+  (size nil :type unsigned-byte))
+
+
+;;; The Array-Type represents a C array type.
+;;;
+(defstruct (array-type
+	    (:include c-type)
+	    (:print-function %print-c-type))
+  ;;
+  ;; The c-type of the elements in the array.
+  (element-type nil :type c-type)
+  ;;
+  ;; The number of bits used to store each element.  May be larger than the
+  ;; Size in the Element-Type due to padding.
+  (element-size nil :type unsigned-byte))
+
+
+;;; The Pointer-Type represents a C pointer type.
+;;;
+(defstruct (pointer-type
+	    (:include c-type)
+	    (:print-function %print-c-type))
+  ;;
+  ;; The type of object pointed to.
+  (to nil :type c-type))
+
+
+;;; An EQ hashtable from the names of c-types to the structures describing them.
+;;;
+(defvar *c-type-names* (make-hash-table :test #'eq))
+
+;;; Find-Alignment  --  Internal
+;;;
+;;;    Return the bit alignment for an object of the specified Size.
+;;;
+(proclaim '(function find-alignment (unsigned-byte) (integer 1 32)))
+(defun find-alignment (size)
+  (cond ((> size 16) 32)
+	((> size 8) 16)
+	((> size 1) 8)
+	(t 1)))
+
+
+;;; Align-Offset  --  Internal
+;;;
+;;;    Return Offset with enough added to bring it out to the specified
+;;; Alignment.
+;;;
+(proclaim '(function align-offset (unsigned-byte (integer 1 32))
+		     unsigned-byte))
+(defun align-offset (offset alignment)
+  (let ((extra (rem offset alignment)))
+    (if (zerop extra) offset (+ offset (- alignment extra)))))
+
+
+;;; Get-C-Type  --  Internal
+;;;
+;;;    Get the C-Type structure corresponding to the supplied Spec.  If the
+;;; spec is a named type, then just return the info.  Otherwise, the Spec must
+;;; be a primitive Alien type with an obvious size.  If we can't decide the
+;;; Spec, we signal an error.
+;;;
+(proclaim '(function get-c-type (t) c-type))
+(defun get-c-type (spec)
+  (cond ((gethash spec *c-type-names*))
+	((memq spec '(c-procedure short-float long-float))
+	 (let ((size (if (eq spec 'long-float) 64 32)))
+	   (make-primitive-type
+	    :description spec
+	    :size size
+	    :alignment (find-alignment size))))
+	((and (listp spec) (> (length spec) 1)
+	      (symbolp (first spec)))
+	 (case (first spec)
+	   ((signed-byte unsigned-byte)
+	    (let ((size (second spec)))
+	      (make-primitive-type
+	       :description spec
+	       :size size
+	       :alignment (find-alignment size))))
+	   (perq-string
+	    (make-primitive-type
+	     :description spec
+	     :size (* (1+ (second spec)) 8)
+	     :alignment 8))
+	   (null-terminated-string
+	    (make-primitive-type
+	     :description spec
+	     :size (* (second spec) 8)
+	     :alignment 8))
+	   (enumeration
+	    (let* ((name (second spec))
+		   (info (get name 'enumeration-info)))
+	      (unless info
+		(error "~S is not a defined enumeration." name))
+	      (let ((size (enumeration-info-size info)))
+		(make-primitive-type
+		 :description spec
+		 :size size
+		 :alignment (find-alignment size)))))
+	   (alien
+	    (let ((size (third spec)))
+	      (unless size
+		(error "Must specify size in Alien C-Type: ~S." spec))
+	      (make-primitive-type
+	       :description spec
+	       :size size
+	       :alignment (find-alignment size))))
+	   (t
+	    (error "~S is not a known C-Type." spec))))
+	(t (error "Losing C-Type: ~S." spec))))
+
+
+); Eval-When (Compile Load Eval)
+
+
+;;;; Exported type operations:
+
+(eval-when (compile load eval)
+
+;;; Symbolicate  --  Internal
+;;;
+;;;    Concatenate together the names of some strings and symbols, producing
+;;; a symbol in the current package.
+;;;
+(proclaim '(function symbolicate (&rest (or string symbol)) symbol))
+(defun symbolicate (&rest things)
+  (values (intern (reduce #'(lambda (x y)
+			      (concatenate 'string (string x) (string y)))
+			  things))))
+
+); Eval-When (Compile Load Eval)
+
+
+;;; C-Sizeof  --  Public
+;;;
+(proclaim '(function c-sizeof (t) unsigned-byte))
+(defun c-sizeof (spec)
+  "Return the size in bits of the C-Type described by Spec."
+  (c-type-size (get-c-type spec)))
+
+(pushnew 'clc::fold-transform (get 'c-sizeof 'clc::clc-transforms))
+
+
+;;; Def-C-Type  --  Public
+;;;
+(defmacro def-c-type (name spec)
+  "Def-C-Type Name Spec
+  Define Name to be an abbreviation for the C-Type indicated by Spec."
+  `(eval-when (compile load eval)
+     (setf (gethash ',name *c-type-names*) ',(get-c-type spec))
+     ',name))
+
+
+;;; Def-C-Record  --  Public
+;;;
+(defmacro def-c-record (name &rest fields)
+  "Name {(Name Type)}*
+  Define a record C-Type.  Name is the name of the type.  The Fields and Types
+  specify the name and type of each field.  An Alien operator Name-Field is
+  defined to select each field.  The Function Make-Name creates a dynamic alien
+  of the appropriate size and type.  Also a pointer to name type is created, so
+  that you can have pointers to a thing of type name in the definition of name.
+  The name of the pointer type is *name."
+  (let* ((info ())
+	 (pname (symbolicate "*" name))
+	 (pos 0)
+	 (align 0)
+	 (res (make-record-type
+	       :description name
+	       :size NIL
+	       :alignment 1
+	       :fields NIL))
+	 (pres (make-pointer-type
+		:description NIL
+		:size 32
+		:alignment 32
+		:to res)))
+    (setf (gethash name *c-type-names*) res)
+    (setf (gethash pname *c-type-names*) pres)
+    (dolist (field fields)
+      (unless (= (length field) 2)
+	(error "Malformed field specification: ~S." field))
+      (let* ((ftype (second field))
+	     (type (if (eq ftype pname) pname (get-c-type (second field))))
+	     (size (if (eq ftype pname) 32 (c-type-size type)))
+	     (start (align-offset pos (if (eq ftype pname) 32
+					  (c-type-alignment type)))))
+	(push (make-field-info :name (first field)
+			       :type type
+			       :offset start
+			       :size size)
+	      info)
+	(unless size
+	  (error "Variable size field ~A in record ~A not allowd."
+		 (first field) name))
+	(setq pos (+ start size))
+	(setq align (max (find-alignment size) align))))
+
+    (setf (record-type-size res) pos)
+    (setf (record-type-alignment res) align)
+    (setf (record-type-fields res) (nreverse info))
+    (setf (pointer-type-description pres) `(alien ,name ,pos))
+    `(progn
+      (eval-when (compile load eval)
+	(setf (gethash ',name *c-type-names*) ',res)
+	(setf (gethash ',pname *c-type-names*) ',pres))
+      (defun ,(symbolicate "MAKE-" name) ()
+	(make-alien ',name ,(c-type-size res)))
+      (defoperator (,(symbolicate "INDIRECT-" pname)
+		    ,(record-type-description res))
+		   ((pointer ,pname))
+	`(alien-indirect (alien-value ,pointer) ,,pos))
+      ,@(define-record-operators res))))
+
+(eval-when (compile load eval)
+
+;;; Define-Record-Operators  --  Internal
+;;;
+;;;    Compute the operator definitions for accessing the fields in Record.
+;;;
+(proclaim '(function define-record-operators (record-type) list))
+(defun define-record-operators (record)
+  (let ((name (c-type-description record)))
+    (mapcar #'(lambda (x)
+		`(defoperator (,(symbolicate name "-" (field-info-name x))
+			       ,(c-type-description (let ((type (field-info-type x)))
+						      (if (structurep type) type
+							  (get-c-type type)))))
+			      ((rec ,name))
+		  `(alien-index (alien-value ,rec)
+				,,(field-info-offset x)
+				,,(field-info-size x))))
+	    (record-type-fields record))))
+
+); Eval-When (Compile Load Eval)
+
+
+;;; Def-C-Array  --  Public
+;;;
+(defmacro def-c-array (name element-type &optional size)
+  "Def-C-Array Name Element-Type [Size]
+  Define Name to be an array C-Type with the specified Element-Type.  If size
+  is not specified, then it is a variable size array."
+  (let* ((eltype (get-c-type element-type))
+	 (elalign (c-type-alignment eltype))
+	 (elsize (align-offset (c-type-size eltype) elalign))
+	 (elts (eval size))
+	 (res (make-array-type :description name
+			       :size (if elts (* elsize elts) nil)
+			       :alignment elalign
+			       :element-type eltype
+			       :element-size elsize)))
+    `(progn
+      (eval-when (compile load eval)
+	(setf (gethash ',name *c-type-names*) ',res))
+
+      (defun ,(symbolicate "MAKE-" name)
+	     ,(if elts () '(size))
+	(make-alien ',name ,(if elts (* elsize elts) `(* ,elsize size))))
+
+      (defoperator (,(symbolicate name "-REF")
+		    ,(c-type-description eltype))
+		   ((array ,name) i)
+	`(alien-index (alien-value ,array) (* ,,elsize ,i) ,,elsize)))))
+
+
+;;; Def-C-Pointer  --  Public
+;;;
+(defmacro def-c-pointer (name to)
+  "Def-C-Pointer Name To
+  Define a pointer C-Type which points to an object of type To."
+  (let* ((type (get-c-type to))
+	 (res (make-pointer-type
+	       :description `(alien ,(c-type-description type)
+				    ,@(when (c-type-size type)
+					`(,(c-type-size type))))
+	       :size 32
+	       :alignment 32
+	       :to type)))
+    `(progn
+      (eval-when (compile load eval)
+	(setf (gethash ',name *c-type-names*) ',res))
+      (defoperator (,(symbolicate "INDIRECT-" name)
+		    ,(c-type-description type))
+		   ((pointer ,name)
+		    ,@(unless (c-type-size type)
+			'(size)))
+	`(alien-indirect (alien-value ,pointer)
+			 ,,(or (c-type-size type) 'size))))))
+
+;;; Some trivial builtin types...
+;;;  
+(setf (gethash 'port *c-type-names*)
+      (make-primitive-type :description 'port
+			   :size 32
+			   :alignment 32))
+
+(setf (gethash 'string-char *c-type-names*)
+      (make-primitive-type :description 'string-char
+			   :size 8
+			   :alignment 8))
+
+(setf (gethash 'boolean *c-type-names*)
+      (make-primitive-type :description 'boolean
+			   :size 1
+			   :alignment 1))
+
+(setf (gethash 'system-area-pointer *c-type-names*)
+      (make-primitive-type :description 'system-area-pointer
+			   :size 32
+			   :alignment 32))
+
+
+;;; Some more standard types:
+
+(def-c-type char (signed-byte 8))
+(def-c-type unsigned-char (unsigned-byte 8))
+(def-c-type short (signed-byte 16))
+(def-c-type unsigned-short (unsigned-byte 16))
+(def-c-type int (signed-byte 32))
+(def-c-type unsigned-int (unsigned-byte 32))
+(def-c-type long (signed-byte 32))
+(def-c-type unsigned-long (unsigned-byte 32))
+
+
+
+(defstruct (routine-info
+	    (:print-function
+	     (lambda (s stream d)
+	       (declare (ignore d))
+	       (format stream "#<Routine-Info ~S>" (routine-info-name s)))))
+  ;;
+  ;; String name of the routine and symbol name of the interface function.
+  (name "" :type string)
+  (function-name nil :type symbol)
+  ;;
+  ;; Symbol name of the variable holding the code pointer for the routine.
+  (code nil :type symbol)
+  ;;
+  ;; The number of words of arguments.
+  (arg-size 0 :type unsigned-byte)
+  ;;
+  ;; The global Alien var that we build the arguments in.  This is also the
+  ;; type of the Alien.
+  (arg-alien nil :type symbol)
+  ;;
+  ;; The number of words of stack allocated for reference args.
+  (result-size 0 :type unsigned-byte)
+  ;;
+  ;;  Similar to Arg-Alien, but we receive results in it.
+  (result-alien nil :type symbol)
+  ;;
+  ;; List of Arg-Info structures.
+  (args nil :type list)
+  ;;
+  ;; The specified return-type for the function value.  Null if Void was
+  ;; specified.
+  (return-type nil :type (or c-type null)))
+
+
+(defstruct arg-info
+  ;;
+  ;; Symbol name of the arg.
+  (name nil :type symbol)
+  ;;
+  ;; C-Type describing the actual argument to the routine.
+  (type nil :type c-type)
+  ;;
+  ;; Specified mode and options.
+  mode
+  options
+  ;;
+  ;; Names of the operators that access this arg in the Args and Results
+  ;; Aliens.
+  (operator nil :type symbol)
+  (result-operator nil :type symbol)
+  )
+
+
+;;;
+;;;    A list of top-level forms that are emitted before the Defun.  This is
+;;; built in reverse order.
+;;;
+(defvar *output-forms*)
+
+(defmacro def-c-routine (name (return-type &key) &rest specs)
+  "Def-C-Routine Name (Return-Type Option*)
+                    {(Arg-Name Arg-Type [Mode] Arg-Option*)}*
+
+  Define a foreign interface function for the routine with the specified string
+  Name.  Normally the interface function is named by interning the uppercased
+  name in the current package.  A different interface function name may be
+  specified by using a list (Name Function-Name) in the place of Name.
+  
+  Return-Type is the C-Type for the C function return value.  Void may be used
+  to specify a function with no result.
+
+  The remaining forms specifiy individual arguments that are passed to the
+  routine.  Arg-Name is a symbol that names the argument, primarily for
+  documentation.  Arg-Type is the C-Type of the argument.  Mode specifies the
+  say that the argument is passed.
+
+  :In
+        An :In argument is simply passed by value.  The value to be passed is
+        obtained from argument(s) to the interface function.  No values are
+        returned for :In arguments.  This is the default mode.
+
+  :Out
+        The specified argument type must be a pointer to a fixed sized object.
+        A pointer to a preallocated object is passed to the routine, and the
+        the object is accessed on return, with the value(s) being returned from
+        the interface function.
+
+  :Copy
+        Similar to :In, except that the argument values are stored in a
+        preallocated object, and a pointer to the object is passed instead of
+        the values themselves.
+
+  :In-Out
+        A combination of :Out and :Copy.  A pointer to the argument is passed,
+        with the object being initialized from supplied argument(s) and
+        return value(s) being determined by accessing the object on return."
+
+  (let ((info (make-routine-info)))
+    (cond ((stringp name)
+	   (setf (routine-info-name info) name)
+	   (setf (routine-info-function-name info)
+		 (intern (string-upcase name))))
+	  ((and (listp name) (= (length name) 2)
+		(stringp (first name)) (symbolp (second name)))
+	   (setf (routine-info-name info) (first name))
+	   (setf (routine-info-function-name info) (second name)))
+	  (t
+	   (error "Malformed routine name specification: ~S." name)))
+
+    (let ((arg-info ()))
+      (dolist (spec specs)
+	(unless (and (listp spec) (>= (length spec) 2))
+	  (error "Bad argument spec: ~S." spec))
+	(let ((arg-name (first spec))
+	      (arg-type (get-c-type (second spec)))
+	      (mode (or (third spec) :in))
+	      (options (cdddr spec)))
+	  (when (oddp (length options))
+	    (error "Odd number of options in ~S." spec))
+	  (unless (symbolp arg-name)
+	    (error "Arg name is not a symbol: ~S." arg-name))
+	  (push (make-arg-info :name arg-name :type arg-type
+			       :mode mode :options options)
+		arg-info)))
+
+      (setf (routine-info-args info) (nreverse arg-info)))
+
+    (unless (eq return-type 'void)
+      (setf (routine-info-return-type info) (get-c-type return-type)))
+
+    (let ((*output-forms* ()))
+      (link-routine-entry info)
+      (allocate-arguments info)
+      (multiple-value-bind (arg-names stores value-names values binds)
+			   (access-arguments info)
+	`(progn
+	   (compiler-let ((*alien-eval-when* '(compile eval)))
+	     ,@(nreverse *output-forms*))
+	   (defun ,(routine-info-function-name info) ,arg-names
+	     ,(make-doc-string info value-names)
+	     (alien-bind (,@(when (routine-info-arg-alien info)
+			      `((args ,(routine-info-arg-alien info))))
+			    ,@(when (routine-info-result-alien info)
+				`((results ,(routine-info-result-alien info)))))
+			 ,@stores
+		(let ((return-value
+		       (%primitive call-foreign
+				   ,(routine-info-code info)
+				   ,(if (routine-info-arg-alien info)
+					'(alien-sap (alien-value args)) 0)
+				   ,(truncate (+ (routine-info-arg-size info)
+						 31) 32))))
+		  return-value
+		  (let* ,binds
+		    (values
+		     ,@(when (routine-info-return-type info)
+			 `(,(coerce-from-integer (routine-info-return-type info)
+						 'return-value)))
+		     ,@values))))))))))
+
+
+;;; Allocate-Argument, Allocate-Result  --  Internal
+;;;
+;;;    Allocate storage for an argument of the specified Type for the routine
+;;; specified by Info.  Name is the name of the argument.  Stuff is pushed onto
+;;; *Output-Forms* as needed.  Allocate-Result is the same except that it
+;;; allocates stuff in the result Alien.
+;;;
+(proclaim '(ftype (function (routine-info c-type symbol) symbol)
+		  allocate-argument allocate-result))
+(defun allocate-argument (info type name)
+  (multiple-value-bind (operator size)
+		       (allocate-field (routine-info-arg-alien info)
+				       (routine-info-arg-size info)
+				       type name)
+    (setf (routine-info-arg-size info) size)
+    operator))
+;;;
+(defun allocate-result (info type name)
+  (multiple-value-bind (operator size)
+		       (allocate-field (routine-info-result-alien info)
+				       (routine-info-result-size info)
+				       type name)
+    (setf (routine-info-result-size info) size)
+    operator))
+
+;;; Allocate-Field  --  Internal
+;;;
+;;;    Pad Size up to the next 32 bit boundry, then create an operator that
+;;; accesses a field of the specified type.  We return the operator name and
+;;; the new amount of stuff allocated.
+;;;
+(proclaim '(function allocate-field (symbol unsigned-byte c-type symbol)
+		     (values symbol unsigned-byte)))
+(defun allocate-field (alien size type name)
+  (let ((base (align-offset size 32))
+	(opname (symbolicate alien "-" name))
+	(ctsize (c-type-size type)))
+    (unless ctsize
+      (error "Cannot pass variable size argument: ~S." type))
+    (if (< ctsize 32)
+	(incf base (- 32 ctsize)))
+    (push `(defoperator (,opname ,(c-type-description type))
+			((alien ,alien))
+	     `(alien-index (alien-value ,alien) ,,base
+			   ,,ctsize))
+	  *output-forms*)
+    (values opname (+ ctsize base))))
+
+
+;;; Allocate-Arguments  --  Internal
+;;;
+;;;    Allocate operators and Aliens for the arguments and results.
+;;;
+(proclaim '(function allocate-arguments (routine-info) void))
+(defun allocate-arguments (info)
+  (let ((name (routine-info-function-name info)))
+    (setf (routine-info-arg-alien info) (symbolicate name "-args"))
+    (setf (routine-info-result-alien info) (symbolicate name "-results")))
+
+  (dolist (arg (routine-info-args info))
+    (let ((type (arg-info-type arg))
+	  (name (arg-info-name arg)))
+      (setf (arg-info-operator arg)
+	    (allocate-argument info type name))
+      (ecase (arg-info-mode arg)
+	(:in)
+	((:copy :in-out :out)
+	 (unless (pointer-type-p type)
+	   (error "~S argument ~S, has non-pointer type."
+		  (arg-info-mode arg) name))
+	 (setf (arg-info-result-operator arg)
+	       (allocate-result info (pointer-type-to type) name))
+	 (push `(setf (alien-access (,(arg-info-operator arg)
+				     ,(routine-info-arg-alien info))
+				    'system-area-pointer)
+		      (alien-sap (,(arg-info-result-operator arg)
+				  ,(routine-info-result-alien info))))
+	       *output-forms*)))))
+
+  (macrolet ((foo (s n)
+	       `(cond ((zerop (,s info))
+		       (setf (,n info) nil))
+		      (t
+		       (setq *output-forms*
+			     (nconc *output-forms*
+				    `((defalien ,(,n info) ,(,n info) ,(,s info)))))))))
+    (foo routine-info-arg-size routine-info-arg-alien)
+    (foo routine-info-result-size routine-info-result-alien)))
+
+
+;;; Access-Arguments  --  Internal
+;;;
+;;;    Return stuff to access the argument in a call to the routine specified
+;;; by Info.  Values:
+;;;
+;;; 1] A list of the input argument names.
+;;; 2] A list of input arg storing forms.
+;;; 3] A list of the names of the result values.
+;;; 4] A list of result value forms.
+;;; 5] A list of let* bindings to make around the value forms.
+;;;
+(proclaim '(function access-arguments (routine-info)
+		     (values list list list list)))
+(defun access-arguments (info)
+  (let ((arg-names ())
+	(stores ())
+	(value-names ())
+	(values ())
+	(binds ()))
+    (dolist (arg (routine-info-args info))
+      (let ((mode (arg-info-mode arg)))
+	(when (eq mode :in)
+	  (multiple-value-bind (form names)
+			       (access-one-value
+				(arg-info-type arg)
+				:write
+				`(,(arg-info-operator arg) (alien-value args))
+				(arg-info-name arg))
+	    (setq arg-names (nconc arg-names names))
+	    (setq stores (nconc stores (list form)))))
+
+	(when (member mode '(:copy :in-out))
+	  (multiple-value-bind (form names)
+			       (access-one-value
+				(pointer-type-to (arg-info-type arg))
+				:write
+				`(,(arg-info-result-operator arg) (alien-value results))
+				(arg-info-name arg))
+	    (setq arg-names (nconc arg-names names))
+	    (setq stores (nconc stores (list form)))))
+
+	(when (member mode '(:out :in-out))
+	  (multiple-value-bind (forms names b)
+			       (access-one-value
+				(pointer-type-to (arg-info-type arg))
+				:read
+				`(,(arg-info-result-operator arg) (alien-value results))
+				(arg-info-name arg))
+	    (setq value-names (nconc value-names names))
+	    (setq values (nconc values forms))
+	    (setq binds (nconc binds b))))))
+
+    (values arg-names stores value-names values binds)))
+
+
+;;; Access-One-Value  --  Internal
+;;;
+;;;    Read or write an alien value that is described by a c-type.
+;;; Type	- The C-Type of the field to be accessed.
+;;; Kind	- :read or :write
+;;; Alien	- The Alien expression for the place to access.
+;;; Name	- The name of the field to access.  If :Write, this variable is
+;;;		  bound to the value to store.
+;;;
+;;; Returns values:
+;;;  1] If :read, a list of forms which are to be the values for the arg
+;;;     If :write, a form which does the store.
+;;;  2] A list of the names of the values produced or arguments used.  In
+;;;     the :read case, this is really just documentation.
+;;;  3] If :read, a list of let* binding forms to make around the code.
+;;;
+(proclaim '(function access-one-value (c-type (member :read :write) t symbol)
+		     (values list list list)))
+(defun access-one-value (type kind alien name)
+  (typecase type
+    (primitive-type
+     (values (if (eq kind :read)
+		 `((alien-access ,alien))
+		 `(setf (alien-access ,alien) ,name))
+	     `(,name)))
+    (pointer-type
+     (values (if (eq kind :read)
+		 `((alien-access ,alien 'alien))
+		 `(setf (alien-access ,alien 'system-area-pointer) ,name))
+	     `(,name)))
+    (t
+     (values (if (eq kind :read)
+		 `((copy-alien ,alien))
+		 `(alien-assign ,alien ,name))
+	     `(,name)))))
+
+
+;;; Coerce-From-Integer  --  Internal
+;;;
+;;;    Return a form that converts a 32bit signed integer into the kind of
+;;; object specified by Type.
+;;;
+(proclaim '(function coerce-from-integer (c-type t) t))
+(defun coerce-from-integer (type value)
+  (typecase type
+    (primitive-type
+     (let ((desc (c-type-description type)))
+       (if (atom desc)
+	   (case desc
+	     (port value)
+	     (boolean `(not (zerop ,value)))
+	     (string-char `(code-char ,value))
+	     (system-area-pointer `(int-sap ,value))
+	     (short-float `(int-sap
+			    (logior (ash ,value (- clc::short-float-shift-16))
+				    (ash clc::short-float-4bit-type
+					 (- 32 clc::short-float-shift-16)))))
+	     (t
+	      (error "Don't know how to hack ~S return type." desc)))
+	   (case (first desc)
+	     (signed-byte value)
+	     (unsigned-byte
+	      (if (> (second desc) 31)
+		  `(ldb (byte 32 0) ,value)
+		  value))
+	     (enumeration
+	      (let ((info (get (cadr desc) 'enumeration-info)))
+		(when (null info)
+		  (error "~S is not a defined enumeration." desc))
+		(ecase (enumeration-info-kind info)
+		  (:vector
+		   `(svref ,(enumeration-info-to info)
+			   (+ ,(enumeration-info-offset info) ,value)))
+		  (`(cdr (assoc ,value) ,(enumeration-info-to info))))))
+	     (t
+	      (error "Don't know how to hack ~S return type." desc))))))
+    (pointer-type
+     (let ((to (pointer-type-to type)))
+       (unless (c-type-size to)
+	 (error "Cannot return pointer to unknown size object."))
+       (let ((tds (c-type-description to)))
+	 (if (or (eq tds 'null-terminated-string)
+		 (and (listp tds) (eq (car (the list tds))
+				      'null-terminated-string)))
+	     `(if (eq ,value 0) NIL
+		  (let ((av (lisp::make-alien-value (int-sap ,value) 0
+						    ,(c-type-size to)
+						    ',tds)))
+		    (alien-bind ((s av ,tds))
+		      (alien-access (alien-value s)))))
+	     `(if (eq ,value 0) NIL
+		  (lisp::make-alien-value (int-sap ,value) 0 ,(c-type-size to)
+					  ',tds))))))
+    (t
+     (error "Don't know how to hack ~S return type." type))))
+
+
+;;; Make-Doc-String  --  Internal
+;;;
+;;;    Make a doc string for the interface routine described by Info.  Values
+;;; is a list of the names of the by-reference return values.
+;;;
+(proclaim '(function make-doc-string (routine-info list) string))
+(defun make-doc-string (info values)
+  (let ((*print-pretty* t)
+	(*print-case* :downcase))
+    (format nil "Interface to foreign routine ~S~:[; returns no values.~;~
+	    ~:*, return values:~%  ~A~]"
+	    (routine-info-name info)
+	    (if (routine-info-return-type info)
+		(cons 'return-value values)
+		values))))
+
+;;; Link-Routine-Entry  --  Internal
+;;;
+;;;    Emit stuff needed to look up a foreign routine and stash the code
+;;; pointer in a variable.
+;;;
+(proclaim '(function link-routine-entry (routine-info) void))
+(defun link-routine-entry (info)
+  (let ((name (symbolicate (routine-info-function-name info) "-code"))
+	(item (gensym)))
+    (push `(defparameter ,name (get-code-pointer ,(routine-info-name info)))
+	  *output-forms*)
+    (push `(let ((,item (cons ',name ',(routine-info-name info))))
+	     (when (not (member ,item foreign-routines-defined :test #'equal))
+	       (push ,item foreign-routines-defined)))
+	  *output-forms*)
+    (setf (routine-info-code info) name)))
+
+
+;;; Def-C-Variable defines a global C-Variable, so that it is available to
+;;; Lisp.  It accepts the name of the variable (as a string) and the type
+;;; of the variable.
+
+(defmacro def-c-variable (name type)
+  "Defines a foreign variable so that it is available from Lisp.
+  Name should be a string with the name of the foreign variable and
+  type is the foreign type of the variable."
+  (let* ((symbol (intern (string-upcase name)))
+	 (c-info (get-c-type type))
+	 (c-type (if (primitive-type-p c-info)
+		     (c-type-description c-info)
+		     type))
+	 (c-size (c-type-size c-info))
+	 (item (gensym)))
+    `(let ((,item (cons ',symbol ',name)))
+       (when (not (member ,item foreign-variables-defined :test #'equal))
+	 (push ,item foreign-variables-defined))
+       (defalien ,symbol ,c-type ,c-size
+	 (lisp::sap-int (get-data-pointer ,name))))))
+
+#|
+;;; Def-C-Procedure defines data structures etc. so that C can be passed
+;;; a pointer to a C procedure object which when called will invoke a Lisp
+;;; function.  Def-C-Procedure accepts three arguments: a symbol whose
+;;; value is set to an object which can be written to alien-structures
+;;; that will look like a c procedure object; a number which is a constant
+;;; number of arguments that the C routine will be called with; and a Lisp
+;;; function (an object callable as a function) which should accept the
+;;; same number of arguments and will be called when the C procedure object
+;;; is invoked.
+
+(defmacro def-c-procedure (name nargs lfunc)
+  "Assigns to the value of the symbol name  an object which can be
+  passed to a foreign function as a procedure object.  Nargs is the
+  number of arguments the procedure should accept.  Lfunc is the Lisp
+  function will be called when the procedure is called.  Lfunc should
+  be callable by apply."
+  (let ((var (gensym)))
+  `(defparameter ,name
+     (let ((,var (%primitive alloc-static-g-vector 3)))
+       (setf (svref ,var 0)
+	     (int-sap (logior (ash clc::type-assembler-code
+				   (+ clc::type-shift-16 16))
+			      (get 'clc::call-lisp
+				   'lisp::%loaded-address))))
+       (setf (svref ,var 1) ,nargs)
+       (setf (svref ,var 2) ,lfunc)
+       ,var))))
+
+;;; Call-Lisp-from-C is a Lisp function that gains control when a C
+;;; function calls a procedure object that is defined as above.  It
+;;; wraps an unwind-protect around the call to the function, so that
+;;; if we throw passed it, the c-stack-information will be reset.
+
+(defun call-lisp-from-c (old-c-stack procedure &rest args)
+  (unwind-protect
+    (let ((rv (apply (svref procedure 2) args)))
+	(%primitive return-to-c old-c-stack rv))
+    (%primitive reset-c-stack old-c-stack)))
+
+;;; Reset-foreign-pointers goes through the list of all defined foreign
+;;; functions and variables and sets the pointers to their new location.
+
+(defun reset-foreign-pointers ()
+  "Reset all the code and variable pointers that may have moved."
+  (dolist (x foreign-routines-defined)
+    (setf (symbol-value (car x)) (get-code-pointer (cdr x))))
+  (dolist (x foreign-variables-defined)
+    (setf (lisp::alien-value-sap (symbol-value (car x)))
+	  (get-data-pointer (cdr x)))))
+|#
+
+#-new-compiler
+(eval-when (compile)
+  (setq lisp::*bootstrap-defmacro* nil))
diff --git a/code/char.lisp b/code/char.lisp
new file mode 100644
index 000000000..b1bfccabd
--- /dev/null
+++ b/code/char.lisp
@@ -0,0 +1,466 @@
+;;; -*- Log: code.log; Package: Lisp -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; Character functions for Spice Lisp.  Part of the standard Spice Lisp
+;;; environment.
+;;;
+;;; This file assumes the use of ASCII codes and the specific character formats
+;;; used in Spice Lisp and Vax Common Lisp.  It is optimized for performance
+;;; rather than for portability and elegance, and may have to be rewritten if
+;;; the character representation is changed.
+;;;
+;;; Written by Guy Steele.
+;;; Rewritten by David Dill.
+;;; Hacked up for speed by Scott Fahlman.
+;;; Font support flushed and type hackery rewritten by Rob MacLachlan.
+;;;
+(in-package 'lisp)
+
+(export '(char-code-limit char-font-limit char-bits-limit standard-char-p
+	  graphic-char-p string-char-p alpha-char-p upper-case-p lower-case-p
+	  both-case-p digit-char-p alphanumericp char= char/= char< char>
+	  char<= char>= char-equal char-not-equal char-lessp char-greaterp
+	  char-not-greaterp char-not-lessp character char-code char-bits
+	  char-font code-char make-char char-upcase char-downcase
+	  digit-char char-int int-char char-name name-char char-control-bit
+	  char-meta-bit char-hyper-bit char-super-bit char-bit set-char-bit))
+
+
+;;; Compile some trivial character operations via inline expansion:
+;;;
+(proclaim '(inline standard-char-p
+		   graphic-char-p string-char-p alpha-char-p upper-case-p
+		   lower-case-p both-case-p alphanumericp char-bits
+		   char-int))
+
+
+(defconstant char-code-limit 256
+  "The upper exclusive bound on values produced by CHAR-CODE.")
+(defconstant char-font-limit 1
+  "The upper exclusive bound on values produced by CHAR-FONT.")
+(defconstant char-bits-limit 256
+  "The upper exclusive bound on values produced by CHAR-BITS.")
+
+(defconstant char-control-bit 1
+  "This bit indicates a control character.")
+(defconstant char-meta-bit 2
+  "This bit indicates a meta character.")
+(defconstant char-super-bit 4
+  "This bit indicates a super character.")
+(defconstant char-hyper-bit 8
+  "This bit indicates a hyper character.")
+
+
+(defparameter char-name-alist
+	`(("NULL" . ,(code-char 0))
+	  ("BELL" . ,(code-char 7))
+	  ("BACKSPACE" . ,(code-char 8)) ("BS" . ,(code-char 8))
+	  ("TAB" . ,(code-char 9))
+	  ("LINEFEED" . ,(code-char 10)) ("LF" . ,(code-char 10))
+	  ("VT" . ,(code-char 11))
+	  ("PAGE" . ,(code-char 12)) ("FORM" . ,(code-char 12))
+	  ("FORMFEED" . ,(code-char 12)) ("FF" . ,(code-char 12))
+	  ("RETURN" . ,(code-char 13)) ("NL" . ,(code-char 10))
+	  ("NEWLINE" . ,(code-char 10))  ("CR" . ,(code-char 13))
+	  ("ALTMODE" . ,(code-char 27)) ("ALT" . ,(code-char 27))
+	  ("ESCAPE" . ,(code-char 27)) ("ESC" . ,(code-char 27))
+	  ("SPACE" . ,(code-char 32)) ("SP" . ,(code-char 32))
+	  ("RUBOUT" . ,(code-char 127)) ("DELETE" . ,(code-char 127)))
+  "This is the alist of (character-name . character) for characters
+  with long names.  The first name in this list for a given character
+  is used on typeout and is the preferred form for input.")
+
+
+;;;; Accessor functions:
+
+(defun char-code (char)
+  "Given a character object argument, char-code returns the code attribute
+   of that object as a non-negative integer."
+  (ldb %character-code-byte (char-int char)))
+
+(defun char-bits (char)
+  "Given a character object argument, char-code returns the bits attribute
+   of that object as a non-negative integer."
+  (ldb %character-control-byte (char-int char)))
+
+(defun char-font (char)
+  "Given a character object argument, char-code returns the font attribute
+   of that object as 0."
+  (declare (ignore char))
+  0)
+
+(defun char-int (char)
+  "The argument must be a character-object.  Returns the font, bits, and
+  code fields as a single non-negative integer.  Implementation dependent.
+  Used mostly for hashing."
+  (declare (character char))
+  (%primitive make-fixnum char))
+
+
+(defun int-char (n)
+  "Performs the inverse of char-int.  The argument must be a non-negative
+  integer of the appropriate size.  It is turned into a character object."
+  (declare (type unsigned-byte n))
+  (cond ((or (not (fixnump n))
+	     (not (<= 0 (the fixnum n) %character-int-mask)))
+	 nil)
+	((zerop (ldb %character-control-byte (the fixnum n)))
+	 (%primitive make-immediate-type n %string-char-type))
+	(t
+	 (%primitive make-immediate-type n %bitsy-char-type))))
+
+
+(defun code-char (code &optional (bits 0) (font 0))
+  "All three arguments, must be non-negative integers; the last two are 
+   optional with default values of 0 (for the bits and font attributes).
+   Returns a character object with the specified code, bits, and font,
+   or returns NIL if this is not possible."
+  (cond ((not (and (< -1 code char-code-limit) (zerop font))) nil)
+	((zerop bits) (code-char code))
+	((< -1 bits char-bits-limit)
+	 (%primitive make-immediate-type 
+		     (dpb bits %character-control-byte code)
+		     %bitsy-char-type))
+	(t nil)))
+
+
+(defun character (object)
+  "Coerces its argument into a character object if possible.  Accepts
+  characters, strings and symbols of length 1, and integers."
+  (typecase object
+    (character object)
+    (integer (int-char object))
+    (string (if (= 1 (the fixnum (length (the string object))))
+		(char object 0)
+		(error "String is not of length one: ~S" object)))
+    (symbol (if (= 1 (the fixnum (length (symbol-name object))))
+		(schar (symbol-name object) 0)
+		(error "Symbol name is not of length one: ~S" object)))
+    (t
+     (error "~S cannot be coerced to a character."))))
+
+
+(defun make-char (char &optional (bits 0) (font 0))
+  "Replaces the bits and font attributes of the specified character with
+  those supplied by the user as fixnums.  Bits and font both default to 0."
+  (declare (character char))
+  (and (< -1 bits char-bits-limit)
+       (zerop font)
+       (int-char (dpb bits %character-control-byte (char-code char)))))
+
+
+(defun char-name (char)
+  "Given a character object, char-name returns the name for that
+  object (a symbol)."
+  (car (rassoc char char-name-alist)))
+
+
+(defun name-char (name)
+  "Given an argument acceptable to string, name-char returns a character
+  object whose name is that symbol, if one exists.  Otherwise, () is returned."
+  (cdr (assoc (string name) char-name-alist :test #'string-equal)))
+
+
+(defun char-bit (char name)
+  "Returns T if the named bit is set in character object CHAR.  Else,
+  returns NIL.  Legal names are :CONTROL, :META, :HYPER, and :SUPER."
+  (logtest (case name
+	     (:control char-control-bit)
+	     (:meta char-meta-bit)
+	     (:hyper char-hyper-bit)
+	     (:super char-super-bit))
+	   (char-bits char)))
+
+
+(defun set-char-bit (char name newvalue)
+  "Returns a character just like CHAR except that the named bit is
+  set or cleared, according to whether NEWVALUE is non-null or NIL.
+  Legal bit names are :CONTROL, :META, :HYPER, and :SUPER."
+  (let ((bit (case name
+	      (:control char-control-bit)
+	      (:meta char-meta-bit)
+	      (:hyper char-hyper-bit)
+	      (:super char-super-bit)
+	      (t 0))))
+    (code-char (char-code char)
+	       (if newvalue
+		   (logior bit (char-bits char))
+		   (logand (lognot bit) (char-bits char)))
+	       (char-font char))))
+
+
+;;;; Predicates:
+
+(defun standard-char-p (char)
+  "The argument must be a character object.  Standard-char-p returns T if the
+   argument is a standard character -- one of the 95 ASCII printing characters
+   or <return>."
+  (declare (character char))
+  (and (typep char 'string-char)
+       (let ((n (char-code (the string-char char))))
+	 (or (< 31 n 127)
+	     (= n 13)
+	     (= n 10)))))
+
+
+(defun graphic-char-p (char)
+  "The argument must be a character object.  Graphic-char-p returns T if the
+  argument is a printing character (space through ~ in ASCII), otherwise
+  returns ()."
+  (declare (character char))
+  (and (typep char 'string-char)
+       (< 31
+	  (char-code (the string-char char))
+	  127)))
+
+
+(defun string-char-p (char)
+  "The argument must be a character object.  String-char-p returns T if the
+   argument can be stored in a string."
+  (declare (character char))
+  (typep char 'string-char))
+
+
+(defun alpha-char-p (char)
+  "The argument must be a character object.  Alpha-char-p returns T if the
+   argument is an alphabetic character, A-Z or a-z; otherwise ()."
+  (declare (character char))
+  (let ((m (char-code char)))
+    (or (< 64 m 91) (< 96 m 123))))
+
+
+(defun upper-case-p (char)
+  "The argument must be a character object; upper-case-p returns T if the
+   argument is an upper-case character, () otherwise."
+  (declare (character char))
+  (< 64
+     (char-code char)
+     91))
+
+
+(defun lower-case-p (char)
+  "The argument must be a character object; lower-case-p returns T if the 
+   argument is a lower-case character, () otherwise."
+  (declare (character char))
+  (< 96
+     (char-code char)
+     123))
+
+
+(defun both-case-p (char)
+  "The argument must be a character object.  Both-case-p returns T if the
+  argument is an alphabetic character and if the character exists in
+  both upper and lower case.  For ASCII, this is the same as Alpha-char-p."
+  (declare (character char))
+  (let ((m (char-code char)))
+    (or (< 64 m 91) (< 96 m 123))))
+
+
+(defun digit-char-p (char &optional (radix 10.))
+  "If char is a digit in the specified radix, returns the fixnum for
+  which that digit stands, else returns NIL.  Radix defaults to 10
+  (decimal)."
+  (declare (character char))
+  (let ((m (- (char-code char) 48)))
+    (cond ((<= radix 10.)
+	   ;; Special-case decimal and smaller radices.
+	   (if (and (>= m 0) (< m radix))  m  nil))
+	  ;; Cannot handle radix past Z.
+	  ((> radix 36)
+	   (error "~S too large to be an input radix."  radix))
+	  ;; Digits 0 - 9 are used as is, since radix is larger.
+	  ((and (>= m 0) (< m 10)) m)
+	  ;; Check for upper case A - Z.
+	  ((and (>= (setq m (- m 7)) 10) (< m radix)) m)
+	  ;; Also check lower case a - z.
+	  ((and (>= (setq m (- m 32)) 10) (< m radix)) m)
+	  ;; Else, fail.
+	  (t nil))))
+
+
+(defun alphanumericp (char)
+  "Given a character-object argument, alphanumericp returns T if the
+   argument is either numeric or alphabetic."
+  (declare (character char))
+  (let ((m (char-code char)))
+    (or (< 47 m 58) (< 64 m 91) (< 96 m 123))))
+
+
+(defun char= (character &rest more-characters)
+  "Returns T if all of its arguments are the same character."
+  (do ((clist more-characters (cdr clist)))
+      ((atom clist) T)
+    (unless (eq (car clist) character) (return nil))))
+
+
+(defun char/= (character &rest more-characters)
+  "Returns T if no two of its arguments are the same character."
+  (do* ((head character (car list))
+	(list more-characters (cdr list)))
+       ((atom list) T)
+    (unless (do* ((l list (cdr l)))                  ;inner loop returns T 
+		 ((atom l) T)			     ; iff head /= rest.
+	      (if (eq head (car l)) (return nil)))
+      (return nil))))
+
+
+(defun char< (character &rest more-characters)
+  "Returns T if its arguments are in strictly increasing alphabetic order."
+  (do* ((c character (car list))
+	(list more-characters (cdr list)))
+       ((atom list) T)
+    (unless (< (char-int c)
+	       (char-int (car list)))
+      (return nil))))
+
+
+(defun char> (character &rest more-characters)
+  "Returns T if its arguments are in strictly decreasing alphabetic order."
+  (do* ((c character (car list))
+	(list more-characters (cdr list)))
+       ((atom list) T)
+    (unless (> (char-int c)
+	       (char-int (car list)))
+      (return nil))))
+
+
+(defun char<= (character &rest more-characters)
+  "Returns T if its arguments are in strictly non-decreasing alphabetic order."
+  (do* ((c character (car list))
+	(list more-characters (cdr list)))
+       ((atom list) T)
+    (unless (<= (char-int c)
+		(char-int (car list)))
+      (return nil))))
+
+
+(defun char>= (character &rest more-characters)
+  "Returns T if its arguments are in strictly non-increasing alphabetic order."
+  (do* ((c character (car list))
+	(list more-characters (cdr list)))
+       ((atom list) T)
+    (unless (>= (char-int c)
+		(char-int (car list)))
+      (return nil))))
+
+
+
+;;; Equal-Char-Code is used by the following functions as a version of char-int
+;;;  which loses font, bits, and case info.
+
+(defmacro equal-char-code (character)
+  `(let ((ch (char-code ,character)))
+     (if (< 96 ch 123) (- ch 32) ch)))
+
+
+
+(defun char-equal (character &rest more-characters)
+  "Returns T if all of its arguments are the same character.
+  Font, bits, and case are ignored."
+  (do ((clist more-characters (cdr clist)))
+      ((atom clist) T)
+    (unless (= (equal-char-code (car clist))
+	       (equal-char-code character))
+      (return nil))))
+
+
+(defun char-not-equal (character &rest more-characters)
+  "Returns T if no two of its arguments are the same character.
+   Font, bits, and case are ignored."
+  (do* ((head character (car list))
+	(list more-characters (cdr list)))
+       ((atom list) T)
+    (unless (do* ((l list (cdr l)))
+		 ((atom l) T)
+	      (if (= (equal-char-code head)
+		     (equal-char-code (car l)))
+		  (return nil)))
+      (return nil))))
+
+
+(defun char-lessp (character &rest more-characters)
+  "Returns T if its arguments are in strictly increasing alphabetic order.
+   Font, bits, and case are ignored."
+  (do* ((c character (car list))
+	(list more-characters (cdr list)))
+       ((atom list) T)
+    (unless (< (equal-char-code c)
+	       (equal-char-code (car list)))
+      (return nil))))
+
+
+(defun char-greaterp (character &rest more-characters)
+  "Returns T if its arguments are in strictly decreasing alphabetic order.
+   Font, bits, and case are ignored."
+  (do* ((c character (car list))
+	(list more-characters (cdr list)))
+       ((atom list) T)
+    (unless (> (equal-char-code c)
+	       (equal-char-code (car list)))
+      (return nil))))
+
+
+(defun char-not-greaterp (character &rest more-characters)
+  "Returns T if its arguments are in strictly non-decreasing alphabetic order.
+   Font, bits, and case are ignored."
+  (do* ((c character (car list))
+	(list more-characters (cdr list)))
+       ((atom list) T)
+    (unless (<= (equal-char-code c)
+		(equal-char-code (car list)))
+      (return nil))))
+
+
+(defun char-not-lessp (character &rest more-characters)
+  "Returns T if its arguments are in strictly non-increasing alphabetic order.
+   Font, bits, and case are ignored."
+  (do* ((c character (car list))
+	(list more-characters (cdr list)))
+       ((atom list) T)
+    (unless (>= (equal-char-code c)
+		(equal-char-code (car list)))
+      (return nil))))
+
+
+
+
+;;;; Miscellaneous functions:
+
+(defun char-upcase (char)
+  "Returns a character with the same bits and font as the input character,
+  converted to upper-case if that is possible."
+  (declare (character char))
+  (cond ((typep char 'string-char)
+	 (char-upcase (the string-char char)))
+	((lower-case-p char)
+	 (int-char (- (char-int char) 32)))
+	(t
+	 char)))
+
+
+(defun char-downcase (char)
+  "Returns a character with the same bits and font as the input character,
+  converted to lower-case if that is possible."
+  (declare (character char))
+  (cond ((typep char 'string-char)
+	 (char-downcase (the string-char char)))
+	((upper-case-p char)
+	 (int-char (+ (char-int char) 32)))
+	(t
+	 char)))
+
+
+(defun digit-char (weight &optional (radix 10) (font 0))
+  "All arguments must be integers.  Returns a character object that
+  represents a digit of the given weight in the specified radix.  Returns
+  NIL if no such character exists.  The character will have the specified
+  font attributes."
+  (and (>= weight 0) (< weight radix) (< weight 36)
+       (code-char (if (< weight 10) (+ 48 weight) (+ 55 weight))
+		  0 font)))
diff --git a/code/clx-ext.lisp b/code/clx-ext.lisp
new file mode 100644
index 000000000..a1a4faa26
--- /dev/null
+++ b/code/clx-ext.lisp
@@ -0,0 +1,591 @@
+;;; -*- Package: Extensions; Log: code.log; Mode: Lisp -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; Spice Lisp is currently incomplete and under active development.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; This file contains code to extend CLX in the CMU Common Lisp environment.
+;;;
+;;; Written by Bill Chiles and Chris Hoover.
+;;;
+
+(in-package "EXTENSIONS")
+
+(export '(open-clx-display with-clx-event-handling enable-clx-event-handling
+	  disable-clx-event-handling object-set-event-handler
+	  default-clx-event-handler 
+	  flush-display-events carefully-add-font-paths
+
+	  serve-key-press serve-key-release serve-button-press
+	  serve-button-release serve-motion-notify serve-enter-notify
+	  serve-leave-notify serve-focus-in serve-focus-out 
+	  serve-exposure serve-graphics-exposure serve-no-exposure
+	  serve-visibility-notify serve-create-notify serve-destroy-notify
+	  serve-unmap-notify serve-map-notify serve-map-request
+	  serve-reparent-notify serve-configure-notify serve-gravity-notify
+	  serve-resize-request serve-configure-request serve-circulate-notify
+	  serve-circulate-request serve-property-notify serve-selection-clear
+	  serve-selection-request serve-selection-notify serve-colormap-notify
+	  serve-client-message))
+
+
+
+;;;; OPEN-CLX-DISPLAY.
+
+(defun open-clx-display (&optional (string (cdr (assoc :display
+						       *environment-list*
+						       :test #'eq))))
+  "Parses a display specification including display and screen numbers.
+   This returns nil when there is no DISPLAY environment variable.  If string
+   is non-nil, and any fields are missing in the specification, this signals an
+   error.  This returns the display and screen objects."
+  (when string
+    (let* ((string (coerce string 'simple-string))
+	   (length (length string))
+	   (host-name "unix")
+	   (display-num nil)
+	   (screen-num nil))
+      (declare (simple-string string))
+      (let ((colon (position #\: string :test #'char=)))
+	(cond ((null colon)
+	       (error "Missing display number in DISPLAY environment variable."))
+	      (t
+	       (unless (zerop colon) (setf host-name (subseq string 0 colon)))
+	       (let* ((start (1+ colon))
+		      (first-dot (position #\. string
+					   :test #'char= :start start)))
+		 (cond ((= start (or first-dot length))
+			(error "Badly formed display number in DISPLAY ~
+				environment variable."))
+		       ((null first-dot)
+			(setf display-num (parse-integer string :start start)))
+		       (t
+			(setf display-num (parse-integer string :start start
+							 :end first-dot))
+			(let* ((start (1+ first-dot))
+			       (second-dot (position #\. string :test #'char=
+						     :start start)))
+			  (cond ((= start (or second-dot length))
+				 (error "Badly formed screen number in ~
+					 DISPLAY environment variable."))
+				(t
+				 (setf screen-num
+				       (parse-integer string :start start
+						      :end second-dot)))))))))))
+      (let ((display (xlib:open-display host-name :display display-num)))
+	(cond (screen-num
+	       (let* ((screens (xlib:display-roots display))
+		      (num-screens (length screens)))
+		 (when (>= screen-num num-screens)
+		   (xlib:close-display display)
+		   (error "No such screen number (~D)." screen-num))
+		 (values display (elt screens screen-num))))
+	      (t
+	       (values display (xlib:display-default-screen display))))))))
+
+
+;;;; Font Path Manipulation
+
+(defun carefully-add-font-paths (display font-pathnames
+					 &optional (operation :append))
+  "Adds the list of font pathnames, Font-Pathnames, to the font path of
+  the server Display but does so carefully by checking to make sure that
+  the font pathnames are not already on the server's font path.  If any
+  of the font pathnames are on the server's font path, they will remain
+  in their current positions.  Operation may be specified as either
+  :prepend or :append and specifies whether to add the additional font
+  pathnames to the beginning or the end of the server's original font
+  path."
+  (let ((font-path (xlib:font-path display))
+	(result ()))
+    (dolist (elt font-pathnames)
+      (let ((font-dir (namestring elt)))
+	(unless (member font-dir font-path :test #'string=)
+	  (push font-dir result))))
+    (when result
+      (ecase operation
+	(:prepend
+	 (setf (xlib:font-path display) (revappend result font-path)))
+	(:append
+	 (setf (xlib:font-path display) (append font-path (nreverse result))))))))
+
+
+
+;;;; Enabling and disabling event handling through SYSTEM:SERVER.
+
+(defvar *clx-fds-to-displays* (make-hash-table :test #'eql)
+  "This is a hash table that maps CLX file descriptors to CLX display structures.
+   For every CLX file descriptor in system:*file-input-handlers*, there must
+   be a mapping from that file descriptor to its CLX display structure when
+   events are handled via SYSTEM:SERVER.")
+
+
+(defmacro with-clx-event-handling ((display handler) &rest body)
+  "Evaluates body in a context where events are handled for the display
+   by calling handler on the display.  This destroys any previously established
+   handler for display."
+  `(unwind-protect
+       (progn
+	 (enable-clx-event-handling ,display ,handler)
+	 ,@body)
+     (disable-clx-event-handling ,display)))
+
+;;; ENABLE-CLX-EVENT-HANDLING associates the display with the handler in
+;;; *display-event-handlers*.  It also associates the display's file descriptor
+;;; (connection to X11 server) with CALL-DISPLAY-EVENT-HANDLER in
+;;; system:*file-input-handlers*.  These are both necessary for SYSTEM:SERVER
+;;; to serve CLX events.  Since CALL-DISPLAY-EVENT-HANDLER is called on a
+;;; file descriptor, the file descriptor is also mapped to the display in
+;;; *clx-fds-to-displays*, so the user's handler can be called on the display.
+;;;
+(defun enable-clx-event-handling (display handler)
+  "After calling this, when SYSTEM:SERVER notices input on display's connection
+   to the X11 server, handler is called on the display.  Handler is invoked in
+   a dynamic context with an error handler bound that will flush all events
+   from the display and return.  By returning, it declines to handle the error,
+   but it will have cleared all events; thus, entering the debugger will not
+   result in infinite errors due to streams that wait via SYSTEM:SERVER for
+   input.  Calling this repeatedly on the same display establishes handler as
+   a new handler, replacing any previous one for display."
+  (check-type display xlib:display)
+  (let ((change-handler (assoc display *display-event-handlers*)))
+    (if change-handler
+	(setf (cdr change-handler) handler)
+	(let ((fd (xlib::display-input-stream display)))
+	  (push (cons fd #'call-display-event-handler)
+		system::*file-input-handlers*)
+	  (setf (gethash fd *clx-fds-to-displays*) display)
+	  (push (cons display handler) *display-event-handlers*)))))
+
+;;; CALL-DISPLAY-EVENT-HANDLER maps the file descriptor to its display and maps
+;;; the display to its handler.  If we can't find the display, we remove the
+;;; file descriptor from system:*file-input-handlers* and try to remove the
+;;; display from *display-event-handlers*.  This is necessary to try to keep
+;;; SYSTEM:SERVER from repeatedly trying to handle the same event over and
+;;; over.  This is possible since many CMU Common Lisp streams loop over
+;;; SYSTEM:SERVER, so when the debugger is entered, infinite errors are
+;;; possible.
+;;;
+(defun call-display-event-handler (file-descriptor)
+  (let ((display (gethash file-descriptor *clx-fds-to-displays*)))
+    (unless display
+      (setf system:*file-input-handlers*
+	    (delete file-descriptor system:*file-input-handlers*
+		    :key #'car))
+      (setf *display-event-handlers*
+	    (remove display *display-event-handlers*
+		    :key #'car
+		    :test #'(lambda (ignore d)
+			      (declare (ignore ignore))
+			      (= (xlib::display-input-stream d)
+				 file-descriptor))))
+      (error "File descriptor ~S not associated with any CLX display.~%~
+              It has been removed from system:*file-input-handlers*."
+	     file-descriptor))
+    (let ((handler (cdr (assoc display *display-event-handlers*))))
+      (unless handler
+	(flush-display-events display)
+	(error "Display ~S not associated with any event handler." display))
+      (handler-bind ((error #'(lambda (condx)
+				(declare (ignore condx))
+				(flush-display-events display))))
+	(funcall handler display)))))
+
+(defun disable-clx-event-handling (display)
+  "Undoes the effect of EXT:ENABLE-CLX-EVENT-HANDLING."
+  (setf *display-event-handlers*
+	(remove display *display-event-handlers* :key #'car))
+  (let ((fd (xlib::display-input-stream display)))
+    (remhash fd *clx-fds-to-displays*)
+    (setf system:*file-input-handlers*
+	  (remove fd system:*file-input-handlers* :key #'car))))
+
+
+
+;;;; Object set event handling.
+
+;;; This is bound by OBJECT-SET-EVENT-HANDLER, so DISPATCH-EVENT can clear
+;;; events on the display before signalling any errors.  This is necessary
+;;; since reading on certain CMU Common Lisp streams involves SERVER, and
+;;; getting an error while trying to handle an event causes repeated attempts
+;;; to handle the same event.
+;;;
+(defvar *process-clx-event-display* nil)
+
+(defvar *object-set-event-handler-print* nil)
+
+(proclaim '(declaration values))
+
+(defun object-set-event-handler (display)
+  "This display event handler uses object sets to map event windows cross
+   event types to handlers.  It uses XLIB:EVENT-CASE to bind all the slots of
+   each event, calling the handlers on all these values in addition to the
+   event key and send-event-p.  Describe EXT:SERVE-MUMBLE, where mumble is an
+   event keyword name for the exact order of arguments.  :mapping-notify and
+   :keymap-notify events are ignored since they do not occur on any particular
+   window.  After calling a handler, each branch returns t to discard the
+   event.  While the handler is executing, all errors go through a handler that
+   flushes all the display's events and returns.  This prevents infinite errors
+   since the debug and terminal streams loop over SYSTEM:SERVER.  This function
+   returns t if there were some event to handle, nil otherwise.  It returns
+   immediately if there is no event to handle."
+  (macrolet ((dispatch (event-key &rest args)
+	       `(multiple-value-bind (object object-set)
+				     (lisp::map-xwindow event-window)
+		  (unless object
+		    (cond ((not (typep event-window 'xlib:window))
+			   (xlib:discard-current-event display)
+			   (warn "Discarding ~S event on non-window ~S."
+				 ,event-key event-window)
+			   (return-from object-set-event-handler nil))
+			  (t
+			   (flush-display-events display)
+			   (error "~S not a known X window.~%~
+			           Received event ~S."
+				  event-window ,event-key))))
+		  (handler-bind ((error #'(lambda (condx)
+					    (declare (ignore condx))
+					    (flush-display-events display))))
+		    (when *object-set-event-handler-print*
+		      (print ,event-key) (force-output))
+		    (funcall (gethash ,event-key
+				      (lisp::object-set-table object-set)
+				      (lisp::object-set-default-handler
+				       object-set))
+			     object ,event-key
+			     ,@args))
+		  (setf result t))))
+    (let ((*process-clx-event-display* display)
+	  (result nil))
+      (xlib:event-case (display :timeout 0)
+	((:KEY-PRESS :KEY-RELEASE :BUTTON-PRESS :BUTTON-RELEASE)
+	     (event-key event-window root child same-screen-p
+	      x y root-x root-y state time code send-event-p)
+	 (dispatch event-key event-window root child same-screen-p
+		   x y root-x root-y state time code send-event-p))
+	(:MOTION-NOTIFY (event-window root child same-screen-p
+			 x y root-x root-y state time hint-p send-event-p)
+	 (dispatch :motion-notify event-window root child same-screen-p
+		   x y root-x root-y state time hint-p send-event-p))
+	(:ENTER-NOTIFY (event-window root child same-screen-p
+			x y root-x root-y state time mode kind send-event-p)
+	 (dispatch :enter-notify event-window root child same-screen-p
+		   x y root-x root-y state time mode kind send-event-p))
+	(:LEAVE-NOTIFY (event-window root child same-screen-p
+			x y root-x root-y state time mode kind send-event-p)
+	 (dispatch :leave-notify event-window root child same-screen-p
+		   x y root-x root-y state time mode kind send-event-p))
+	(:EXPOSURE (event-window x y width height count send-event-p)
+	 (dispatch :exposure event-window x y width height count send-event-p))
+	(:GRAPHICS-EXPOSURE (event-window x y width height count major minor
+			     send-event-p)
+	 (dispatch :graphics-exposure event-window x y width height
+		   count major minor send-event-p))
+	(:NO-EXPOSURE (event-window major minor send-event-p)
+	 (dispatch :no-exposure event-window major minor send-event-p))
+	(:FOCUS-IN (event-window mode kind send-event-p)
+	 (dispatch :focus-in event-window mode kind send-event-p))
+	(:FOCUS-OUT (event-window mode kind send-event-p)
+	 (dispatch :focus-out event-window mode kind send-event-p))
+	(:KEYMAP-NOTIFY ()
+	 (warn "Ignoring keymap notify event.")
+	 (when *object-set-event-handler-print*
+	   (print :keymap-notify) (force-output))
+	 (setf result t))
+	(:VISIBILITY-NOTIFY (event-window state send-event-p)
+	 (dispatch :visibility-notify event-window state send-event-p))
+	(:CREATE-NOTIFY (event-window window x y width height border-width
+			 override-redirect-p send-event-p)
+	 (dispatch :create-notify event-window window x y width height
+		   border-width override-redirect-p send-event-p))
+	(:DESTROY-NOTIFY (event-window window send-event-p)
+	 (dispatch :destroy-notify event-window window send-event-p))
+	(:UNMAP-NOTIFY (event-window window configure-p send-event-p)
+	 (dispatch :unmap-notify event-window window configure-p send-event-p))
+	(:MAP-NOTIFY (event-window window override-redirect-p send-event-p)
+	 (dispatch :map-notify event-window window override-redirect-p
+		   send-event-p))
+	(:MAP-REQUEST (event-window window send-event-p)
+	 (dispatch :map-request event-window window send-event-p))
+	(:REPARENT-NOTIFY (event-window window parent x y override-redirect-p
+			   send-event-p)
+	 (dispatch :reparent-notify event-window window parent x y
+		   override-redirect-p send-event-p))
+	(:CONFIGURE-NOTIFY (event-window window x y width height border-width
+			    above-sibling override-redirect-p send-event-p)
+	 (dispatch :configure-notify event-window window x y width height
+		   border-width above-sibling override-redirect-p
+		   send-event-p))
+	(:GRAVITY-NOTIFY (event-window window x y send-event-p)
+	 (dispatch :gravity-notify event-window window x y send-event-p))
+	(:RESIZE-REQUEST (event-window width height send-event-p)
+	 (dispatch :resize-request event-window width height send-event-p))
+	(:CONFIGURE-REQUEST (event-window window x y width height border-width
+			     stack-mode above-sibling value-mask send-event-p)
+	 (dispatch :configure-request event-window window x y width height
+		   border-width stack-mode above-sibling value-mask
+		   send-event-p))
+	(:CIRCULATE-NOTIFY (event-window window place send-event-p)
+	 (dispatch :circulate-notify event-window window place send-event-p))
+	(:CIRCULATE-REQUEST (event-window window place send-event-p)
+	 (dispatch :circulate-request event-window window place send-event-p))
+	(:PROPERTY-NOTIFY (event-window atom state time send-event-p)
+	 (dispatch :property-notify event-window atom state time send-event-p))
+	(:SELECTION-CLEAR (event-window selection time send-event-p)
+	 (dispatch :selection-notify event-window selection time send-event-p))
+	(:SELECTION-REQUEST (event-window requestor selection target property
+			     time send-event-p)
+	 (dispatch :selection-request event-window requestor selection target
+		   property time send-event-p))
+	(:SELECTION-NOTIFY (event-window selection target property time
+			    send-event-p)
+	 (dispatch :selection-notify event-window selection target property time
+		   send-event-p))
+	(:COLORMAP-NOTIFY (event-window colormap new-p installed-p send-event-p)
+	 (dispatch :colormap-notify event-window colormap new-p installed-p
+		   send-event-p))
+	(:MAPPING-NOTIFY (request)
+	 (warn "Ignoring mapping notify event -- ~S." request)
+	 (when *object-set-event-handler-print*
+	   (print :mapping-notify) (force-output))
+	 (setf result t))
+	(:CLIENT-MESSAGE (event-window format data send-event-p)
+	 (dispatch :client-message event-window format data send-event-p)))
+      result)))
+
+(defun default-clx-event-handler (object event-key event-window &rest ignore)
+  (declare (ignore ignore))
+  (flush-display-events *process-clx-event-display*)
+  (error "No handler for event type ~S on ~S in ~S."
+	 event-key object (lisp::map-xwindow event-window)))
+
+(defun flush-display-events (display)
+  "Dumps all the events in display's event queue including the current one
+   in case this is called from within XLIB:EVENT-CASE, etc."
+  (xlib:discard-current-event display)
+  (xlib:event-case (display :discard-p t :timeout 0)
+    (t () nil)))
+
+
+
+;;;; Key and button service.
+
+(defun serve-key-press (object-set fun)
+  "Associate a method in the object-set with :key-press events.  The method
+   is called on the object the event occurred, event key, event window, root,
+   child, same-screen-p, x, y, root-x, root-y, state, time, code, and
+   send-event-p."
+  (setf (gethash :key-press (lisp::object-set-table object-set)) fun))
+
+(defun serve-key-release (object-set fun)
+  "Associate a method in the object-set with :key-release events.  The method
+   is called on the object the event occurred, event key, event window, root,
+   child, same-screen-p, x, y, root-x, root-y, state, time, code, and
+   send-event-p."
+  (setf (gethash :key-release (lisp::object-set-table object-set)) fun))
+
+(defun serve-button-press (object-set fun)
+  "Associate a method in the object-set with :button-press events.  The method
+   is called on the object the event occurred, event key, event window, root,
+   child, same-screen-p, x, y, root-x, root-y, state, time, code, and
+   send-event-p."
+  (setf (gethash :button-press (lisp::object-set-table object-set)) fun))
+
+(defun serve-button-release (object-set fun)
+  "Associate a method in the object-set with :button-release events.  The
+   method is called on the object the event occurred, event key, event window,
+   root, child, same-screen-p, x, y, root-x, root-y, state, time, code, and
+   send-event-p."
+  (setf (gethash :button-release (lisp::object-set-table object-set)) fun))
+
+
+
+;;;; Mouse service.
+
+(defun serve-motion-notify (object-set fun)
+  "Associate a method in the object-set with :motion-notify events.  The method
+   is called on the object the event occurred, event key, event window, root,
+   child, same-screen-p, x, y, root-x, root-y, state, time, hint-p, and
+   send-event-p."
+  (setf (gethash :motion-notify (lisp::object-set-table object-set)) fun))
+
+(defun serve-enter-notify (object-set fun)
+  "Associate a method in the object-set with :enter-notify events.  The method
+   is called on the object the event occurred, event key, event window, root,
+   child, same-screen-p, x, y, root-x, root-y, state, time, mode, kind,
+   and send-event-p."
+  (setf (gethash :enter-notify (lisp::object-set-table object-set)) fun))
+
+(defun serve-leave-notify (object-set fun)
+  "Associate a method in the object-set with :leave-notify events.  The method
+   is called on the object the event occurred, event key, event window, root,
+   child, same-screen-p, x, y, root-x, root-y, state, time, mode, kind,
+   and send-event-p."
+  (setf (gethash :leave-notify (lisp::object-set-table object-set)) fun))
+
+
+
+;;;; Keyboard service.
+
+(defun serve-focus-in (object-set fun)
+  "Associate a method in the object-set with :focus-in events.  The method
+   is called on the object the event occurred, event key, event window, mode,
+   kind, and send-event-p."
+  (setf (gethash :focus-in (lisp::object-set-table object-set)) fun))
+
+(defun serve-focus-out (object-set fun) 
+  "Associate a method in the object-set with :focus-out events.  The method
+   is called on the object the event occurred, event key, event window, mode,
+   kind, and send-event-p."
+  (setf (gethash :focus-out (lisp::object-set-table object-set)) fun))
+
+
+
+;;;; Exposure service.
+
+(defun serve-exposure (object-set fun)
+  "Associate a method in the object-set with :exposure events.  The method
+   is called on the object the event occurred, event key, event window, x, y,
+   width, height, count, and send-event-p."
+  (setf (gethash :exposure (lisp::object-set-table object-set)) fun))
+
+(defun serve-graphics-exposure (object-set fun)
+  "Associate a method in the object-set with :graphics-exposure events.  The
+   method is called on the object the event occurred, event key, event window,
+   x, y, width, height, count, major, minor, and send-event-p."
+  (setf (gethash :graphics-exposure (lisp::object-set-table object-set)) fun))
+
+(defun serve-no-exposure (object-set fun)
+  "Associate a method in the object-set with :no-exposure events.  The method
+   is called on the object the event occurred, event key, event window, major,
+   minor, and send-event-p."
+  (setf (gethash :no-exposure (lisp::object-set-table object-set)) fun))
+  
+
+
+;;;; Structure service.
+
+(defun serve-visibility-notify (object-set fun)
+  "Associate a method in the object-set with :visibility-notify events.  The
+   method is called on the object the event occurred, event key, event window,
+   state, and send-event-p."
+  (setf (gethash :visibility-notify (lisp::object-set-table object-set)) fun))
+
+(defun serve-create-notify (object-set fun)
+  "Associate a method in the object-set with :create-notify events.  The
+   method is called on the object the event occurred, event key, event window,
+   window, x, y, width, height, border-width, override-redirect-p, and
+   send-event-p."
+  (setf (gethash :create-notify (lisp::object-set-table object-set)) fun))
+
+(defun serve-destroy-notify (object-set fun)
+  "Associate a method in the object-set with :destroy-notify events.  The
+   method is called on the object the event occurred, event key, event window,
+   window, and send-event-p."
+  (setf (gethash :destroy-notify (lisp::object-set-table object-set)) fun))
+
+(defun serve-unmap-notify (object-set fun)
+  "Associate a method in the object-set with :unmap-notify events.  The
+   method is called on the object the event occurred, event key, event window,
+   window, configure-p, and send-event-p."
+  (setf (gethash :unmap-notify (lisp::object-set-table object-set)) fun))
+
+(defun serve-map-notify (object-set fun)
+  "Associate a method in the object-set with :map-notify events.  The
+   method is called on the object the event occurred, event key, event window,
+   window, override-redirect-p, and send-event-p."
+  (setf (gethash :map-notify (lisp::object-set-table object-set)) fun))
+
+(defun serve-map-request (object-set fun)
+  "Associate a method in the object-set with :map-request events.  The
+   method is called on the object the event occurred, event key, event window,
+   window, and send-event-p."
+  (setf (gethash :map-request (lisp::object-set-table object-set)) fun))
+
+(defun serve-reparent-notify (object-set fun)
+  "Associate a method in the object-set with :reparent-notify events.  The
+   method is called on the object the event occurred, event key, event window,
+   window, parent, x, y, override-redirect-p, and send-event-p."
+  (setf (gethash :reparent-notify (lisp::object-set-table object-set)) fun))
+
+(defun serve-configure-notify (object-set fun)
+  "Associate a method in the object-set with :configure-notify events.  The
+   method is called on the object the event occurred, event key, event window,
+   window, x, y, width, height, border-width, above-sibling,
+   override-redirect-p, and send-event-p."
+  (setf (gethash :configure-notify (lisp::object-set-table object-set)) fun))
+
+(defun serve-gravity-notify (object-set fun)
+  "Associate a method in the object-set with :gravity-notify events.  The
+   method is called on the object the event occurred, event key, event window,
+   window, x, y, and send-event-p."
+  (setf (gethash :gravity-notify (lisp::object-set-table object-set)) fun))
+
+(defun serve-resize-request (object-set fun)
+  "Associate a method in the object-set with :resize-request events.  The
+   method is called on the object the event occurred, event key, event window,
+   width, height, and send-event-p."
+  (setf (gethash :resize-request (lisp::object-set-table object-set)) fun))
+
+(defun serve-configure-request (object-set fun)
+  "Associate a method in the object-set with :configure-request events.  The
+   method is called on the object the event occurred, event key, event window,
+   window, x, y, width, height, border-width, stack-mode, above-sibling,
+   value-mask, and send-event-p."
+  (setf (gethash :configure-request (lisp::object-set-table object-set)) fun))
+
+(defun serve-circulate-notify (object-set fun)
+  "Associate a method in the object-set with :circulate-notify events.  The
+   method is called on the object the event occurred, event key, event window,
+   window, place, and send-event-p."
+  (setf (gethash :circulate-notify (lisp::object-set-table object-set)) fun))
+
+(defun serve-circulate-request (object-set fun)
+  "Associate a method in the object-set with :circulate-request events.  The
+   method is called on the object the event occurred, event key, event window,
+   window, place, and send-event-p."
+  (setf (gethash :circulate-request (lisp::object-set-table object-set)) fun))
+
+
+
+;;;; Misc. service.
+
+(defun serve-property-notify (object-set fun)
+  "Associate a method in the object-set with :property-notify events.  The
+   method is called on the object the event occurred, event key, event window,
+   atom, state, time, and send-event-p."
+  (setf (gethash :property-notify (lisp::object-set-table object-set)) fun))
+
+(defun serve-selection-clear (object-set fun)
+  "Associate a method in the object-set with :selection-clear events.  The
+   method is called on the object the event occurred, event key, event window,
+   selection, time, and send-event-p."
+  (setf (gethash :selection-clear (lisp::object-set-table object-set)) fun))
+
+(defun serve-selection-request (object-set fun)
+  "Associate a method in the object-set with :selection-request events.  The
+   method is called on the object the event occurred, event key, event window,
+   requestor, selection, target, property, time, and send-event-p."
+  (setf (gethash :selection-request (lisp::object-set-table object-set)) fun))
+
+(defun serve-selection-notify (object-set fun)
+  "Associate a method in the object-set with :selection-notify events.  The
+   method is called on the object the event occurred, event key, event window,
+   selection, target, property, time, and send-event-p."
+  (setf (gethash :selection-notify (lisp::object-set-table object-set)) fun))
+
+(defun serve-colormap-notify (object-set fun)
+  "Associate a method in the object-set with :colormap-notify events.  The
+   method is called on the object the event occurred, event key, event window,
+   colormap, new-p, installed-p, and send-event-p."
+  (setf (gethash :colormap-notify (lisp::object-set-table object-set)) fun))
+
+(defun serve-client-message (object-set fun)
+  "Associate a method in the object-set with :client-message events.  The
+   method is called on the object the event occurred, event key, event window,
+   format, data, and send-event-p."
+  (setf (gethash :client-message (lisp::object-set-table object-set)) fun))
diff --git a/code/debug-info.lisp b/code/debug-info.lisp
new file mode 100644
index 000000000..3b8d7f099
--- /dev/null
+++ b/code/debug-info.lisp
@@ -0,0 +1,191 @@
+;;; -*- Log: code.log; Package: C -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;;    This file contains structures used for recording debugger information.
+;;;
+(in-package "C")
+
+(defstruct location)
+
+(defstruct (compiled-location (:include location))
+  ;;
+  ;; This variable's name and package, represented as strings.  This allows the
+  ;; debugger to recover the symbol without requiring the symbol to be created
+  ;; at load time.  Package-Name is NIL for gensyms.
+  (name nil :type simple-string)
+  (package-name nil :type (or simple-string null))
+  ;;
+  ;; The SC and offset, save SC and save offset encoded as bit-fields.  Also
+  ;; some sort of ID that makes the name/package unique.  All locations for the
+  ;; same var have the same ID.  A single variable will have multiple locations
+  ;; (in different functions) when it is closed over.
+  (bits0 0 :type fixnum)
+  (bits1 0 :type fixnum)
+  ;;
+  ;; The variable's type, represented as list-style type descriptor.
+  type)
+
+
+(defmacro compiled-location-offset (str)
+  `(ldb (byte 17 0) (compiled-location-bits0 ,str)))
+
+(defmacro compiled-location-sc (str)
+  `(ldb (byte 5 17) (compiled-location-bits0 ,str)))
+
+(defmacro compiled-location-save-sc (str)
+  `(ldb (byte 5 22) (compiled-location-bits0 ,str)))
+
+(defmacro compiled-location-save-offset (str)
+  `(ldb (byte 17 0) (compiled-location-bits1 ,str)))
+
+(defmacro compiled-location-id (str)
+  `(ldb (byte 10 17) (compiled-location-bits1 ,str)))
+
+
+(defstruct debug-block)
+
+;;; If a block has elsewhere (error) code, then there will be two debug-block
+;;; structures to represent it: one for the normal code and one for the
+;;; elsewhere code.
+;;;
+;;; ### Actually, this should probably all be represented in some packed binary
+;;; form in an i-vector in the debug-function.
+;;;
+(defstruct (compiled-debug-block (:include debug-block))
+  ;;
+  ;; The PC that this block starts at.
+  (pc nil :type index)
+  ;;
+  ;; Alternating offsets into the DEBUG-FUNCTION's source map and PC
+  ;; increments, represented in some variable-length encoding.
+  (forms nil :type (simple-array ??? (*)))
+  ;;
+  ;; A bit-vector indicating which vars are live somewhere in this block.  This
+  ;; vector parallels the DEBUG-FUNCTION-VARIABLES, with a 1 for stored in each
+  ;; location that corresponds to a live variable.
+  (live-variables nil :type simple-bit-vector)
+  ;;
+  ;; If NIL, this block has no successor.  If an INDEX, the PC of this
+  ;; block's successor.  If a CONS, then the block's two successors are the CAR
+  ;; and CDR.
+  (successor nil :type (or null index cons)))
+
+
+(defstruct debug-function)
+
+(defstruct (compiled-debug-function (:include debug-function))
+  ;;
+  ;; The name of this function.  If from a DEFUN, etc., then this is the
+  ;; function name, otherwise it is a descriptive string.
+  (name nil :type (or simple-string cons symbol))
+  ;;
+  ;; The kind of function (same as FUNCTIONAL-KIND):
+  (kind nil :type (member nil :optional :external :top-level :cleanup))
+  ;;
+  ;; A vector of the Location structures for the variables that the argument
+  ;; values are stored in within this function.  The Locations are in the order
+  ;; that the arguments are actually passed in, but special marker symbols can
+  ;; be interspersed to indicate the orignal call syntax:
+  ;;
+  ;; DELETED
+  ;;    There was an argument to the function in this position, but it was
+  ;;    deleted due to lack of references.  The value cannot be recovered.
+  ;;
+  ;; SUPPLIED-P
+  ;;    The following location is the supplied-p value for the preceding
+  ;;    keyword or optional.
+  ;;
+  ;; REST-ARG
+  ;;    The following location holds the list of rest args.
+  ;;
+  ;; MORE-ARG
+  ;;    The following two locations are the more arg context and count.
+  ;;
+  ;; <any other symbol>
+  ;;    The following location is the value of the keyword argument with the
+  ;;    specified name.
+  ;;
+  ;; This may be NIL to save space.
+  (arguments nil :type (or simple-vector null))
+  ;;
+  ;; A vector of the locations of all the variables in this function,
+  ;; alphabetically sorted by the NAME.  This may be NIL to save space.
+  (variables nil :type (or simple-vector null))
+  ;;
+  ;; A vector of Locations describing the return locations, or :Standard if the
+  ;; function returns using the standard unknown-values convention.  This may
+  ;; be NIL to save space.  These locations only meaningful slots are OFFSET
+  ;; and SC.
+  (returns nil :type (or simple-vector (member :standard nil)))
+  ;;
+  ;; A vector of all the DEBUG-BLOCKs in this function, in the order they were
+  ;; emitted.  The first block is the start of the function.  This may be NIL
+  ;; to save space.
+  (blocks nil :type (or simple-vector null))
+  ;;
+  ;; Register where the return PC and return CONT are kept, or NIL if they are
+  ;; kept on the stack in the standard location.
+  (return-pc nil :type (or (unsigned-byte 8) null))
+  (old-cont nil :type (or (unsigned-byte 8) null)))
+
+
+;;; ### We may ultimately want a vector of the start positions of each source
+;;; form, since that would make it easier for the debugger to locate the
+;;; source.
+;;;
+(defstruct debug-source
+  ;;
+  ;; This slot indicates where the definition came from:
+  ;;    :File - from a file (Compile-File)
+  ;;    :Lisp - from Lisp (Compile)
+  ;;  :Stream - from a non-file stream (Compile-From-Stream)
+  (from nil :type (member :file :stream :lisp))
+  ;;
+  ;; If :File, the file name, if :Lisp, the lambda compiled, otherwise some
+  ;; descriptive string.
+  (name nil :type (or pathname list simple-string))
+  ;;
+  ;; The universal time that the source was written, or NIL if unavailable.
+  (created nil :type (or unsigned-byte null))
+  ;;
+  ;; The universal time that the source was compiled.
+  (compiled nil :type unsigned-byte)
+  ;;
+  ;; The source path root number of the first form read from this source (i.e.
+  ;; the total number of forms converted previously in this compilation.)
+  (source-root 0 :type index)
+  ;;
+  ;; The file-position of the first form read from this source (if applicable).
+  (start-position nil :type (or index null)))
+
+(defstruct debug-info)
+
+(defstruct (compiled-debug-info (:include debug-info))
+  ;;
+  ;; Some string describing something about the code in this component.
+  (name nil :type simple-string)
+  ;;
+  ;; A list of DEBUG-SOURCE structures describing where the code for this
+  ;; component came from, in the order that they were read.
+  ;;
+  ;; *** NOTE: the offset of this slot is wired into the fasl dumper so that it
+  ;; *** can backpatch the source info when compilation is complete.
+  (source nil :type list)
+  ;;
+  ;; A simple-vector of alternating Debug-Function structures and fixnum
+  ;; PCs.  This is used to map PCs to functions, so that we can figure out
+  ;; what function we were running in.  The function is valid between the PC
+  ;; before it (inclusive) and the PC after it (exclusive).  The PCs are in
+  ;; sorted order, so we can binary-search.  We omit the first and last PC,
+  ;; since their values are 0 and the length of the code vector.  Null only
+  ;; temporarily.
+  (function-map nil :type (or simple-vector null))
+  ;;
+  ;; Representation of the tree of source paths for code in this component.
+  (source-paths nil :type (or (simple-array (unsigned-byte 4) (*)) null)))
diff --git a/code/debug.lisp b/code/debug.lisp
new file mode 100644
index 000000000..1b9f1457f
--- /dev/null
+++ b/code/debug.lisp
@@ -0,0 +1,441 @@
+;;; -*- Mode: Lisp; Package: Debug; Log: code.log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; Spice Lisp Debugger.
+;;;
+;;; Written by Steve Handerson
+;;; Pages 6 through 9 rewritten by Bill Chiles.
+;;;
+;;; **********************************************************************
+;;;
+(in-package "DEBUG" :use '("LISP" "SYSTEM"))
+
+
+(export '(internal-debug *flush-debug-errors* backtrace debug-function
+	  show-all debug-return local show hide argument pc
+	  function-name hide-defaults *debug-print-level*
+	  *debug-print-length* *debug-hidden-functions*))
+
+
+
+(in-package "LISP")
+(export '(invoke-debugger *debugger-hook*))
+
+
+(in-package "DEBUG")
+
+;;;
+;;; Used to communicate to debug-loop that we are at a step breakpoint.
+;;;
+
+(define-condition step-condition (simple-condition))
+  "*Print-level* is bound to this value when debug prints a function call.")
+;;;; Variables, parameters, and constants.
+
+  "*Print-length* is bound to this value when debug prints a function call.")
+  null, use *PRINT-LEVEL*")
+(defvar *inside-debugger-p* nil
+  "This is T while evaluating expressions in the debugger.")
+
+
+(defparameter *debug-print-length* 5
+  "*PRINT-LENGTH* is bound to this value when debug prints a function call.  If
+  null, use *PRINT-LENGTH*.")
+
+(defvar *in-the-debugger* nil
+  "When true, the LIST-LOCATIONS command only displays block start locations.
+  "The default contents of *debug-prompt*."
+   Otherwise, all locations are displayed.")
+
+  "If true, list the code location type in the LIST-LOCATIONS command.")
+    (princ " ")))
+;;; should not be listed when listing breakpoints.
+;;;
+  "A lambda of no args that prints the debugger prompt on *debug-io*.")
+
+;;; Code locations of the possible breakpoints
+;;;
+Prompt is <stack-level>':'<frame-number>(<command-level>*']').
+Frames look like calls, C signifying a catch frame.
+Expressions get evaluated in the frame's lexical environment,
+  setting * and friends like the top level read-eval-print loop.
+Debug commands do not affect * and friends.
+;;;
+(defvar *breakpoints* nil)
+(declaim (type list *breakpoints*))
+
+;;; A list of breakpoint-info structures of the made and active step
+;;; breakpoints.
+  PUSH     rebinds things in another command level.  Good for hide/show.
+  ABORT    returns to the previous abort restart case.
+;;;
+(defvar *step-breakpoints* nil)  
+;;;
+(defvar *number-of-steps* 1)
+  F  go to numbered frame (prompts if not given).
+  S  search for a specified function (prompts), 
+     an optional number of times (does not prompt).
+  R  searches up the stack, optional times.
+(declaim (type integer *number-of-steps*))
+;;;
+(defvar *default-breakpoint-debug-function* nil)
+  ?              prints all kinds of groovy things.
+  L              lists locals in current function.
+  P, PP          displays current function call.  
+
+Functions/macros for your enjoyment:
+ (DEBUG:DEBUG-RETURN expression [frame])  returns with values from an active frame.
+ (DEBUG:ARGUMENT n [frame])              shows the nth  supplied argument.
+ (DEBUG:PC [frame])                 shows the next pc to be executed.
+;;; Returns a list of the next code-locations following the one passed.  One of
+;;; the *bad-code-location-types* will not be returned.
+;;;
+(defun next-code-locations (code-location)
+    (di:do-debug-block-locations (block-code-location debug-block)
+    (setf kind (di:breakpoint-kind (breakpoint-info-breakpoint place)))
+    (format t "Cannot step, in elsewhere code~%"))
+   (t
+(proclaim '(inline pointer+ stack-ref valid-env-p cstack-pointer-valid-p))
+	  (di:activate-breakpoint bp)
+(defun pointer+ (x y)
+  (%primitive sap+ x (ash y 2)))
+	     (t ,other)))))
+(defun stack-ref (s n)
+  (%primitive read-control-stack (pointer+ s n)))
+
+(defun escape-reg (f n)
+  (stack-ref f (+ n %escape-frame-general-register-start-slot)))
+
+(defun valid-env-p (env)
+  (and (functionp env)
+       (eql (%primitive get-vector-subtype env)
+	    %function-constants-subtype)))
+
+(defun cstack-pointer-valid-p (x)
+  (and (%primitive pointer< x (%primitive current-sp))
+       (not (%primitive pointer< x
+			(%primitive make-immediate-type 0
+				    %control-stack-type)))))
+
+(defun check-valid (x)
+  (unless (cstack-pointer-valid-p x)
+    (error "Invalid control stack pointer."))
+  x)
+
+(defun print-code-and-stuff (env pc)
+  (let* ((code (%primitive header-ref env %function-code-slot))
+	 (code-int (%primitive make-fixnum code)))
+    (format t "~A, Code = #x~X, PC = ~D"
+	    (%primitive header-ref env %function-name-slot)
+	    (logior code-int (ash %code-type 27))
+	    (- (%primitive make-fixnum pc) code-int))))
+
+;;; Backtrace prints a history of calls on the stack.
+
+(defun backtrace (&optional (frames most-positive-fixnum)
+			    (*standard-output* *debug-io*))
+  "Show a listing of the call stack going down from the current frame.  Frames
+  is how many frames to show."
+  (do ((callee (%primitive current-cont)
+	       (stack-ref callee c::old-cont-save-offset))
+       (n 0 (1+ n)))
+      ((or (not (cstack-pointer-valid-p callee))
+	   (>= n frames))
+       (values))
+    (let* ((caller (stack-ref callee c::old-cont-save-offset))
+	   (pc (stack-ref callee c::return-pc-save-offset)))
+      (unless (cstack-pointer-valid-p caller)
+	(return (values)))
+      (let ((env (stack-ref caller c::env-save-offset)))
+	(cond 
+	 ((eql env 0)
+	  (let ((env (escape-reg caller c::env-offset)))
+	    (cond ((eql (%primitive get-type env) %trap-type)
+		   (format t "~%<undefined> ~S"
+			   (escape-reg caller c::call-name-offset))
+		   (setq callee
+			 (check-valid
+			  (escape-reg caller c::old-cont-offset))))
+		  ((valid-env-p env)
+		   (format t "~%<escape frame> ")
+		   (print-code-and-stuff
+		    env
+		    (escape-reg caller c::return-pc-offset))
+		   (setq callee
+			 (check-valid
+			  (stack-ref callee c::old-cont-save-offset))))
+		  (t
+		   (error "Escaping frame ENV invalid?")))))
+	 ((valid-env-p env)
+	  (terpri)
+	  (print-code-and-stuff env pc))
+	 (t
+	  (format t "~%<invalid frame>")))))))
+
+    (make-unprintable-object "unavailable-arg")))
+;;;; DEBUG
+;;; PRINT-FRAME-CALL -- Interface
+;;;
+;;; This prints a representation of the function call causing frame to exist.
+;;; Verbosity indicates the level of information to output; zero indicates just
+   which causes the standard debugger to execute.")
+(defun print-frame-call (frame &key (print-length *print-length*)
+			       (number nil))
+  (let ((*print-length* (or *debug-print-length* print-length))
+(defvar *debug-abort*)
+	(*print-level* (or *debug-print-level* print-level)))
+      (when number
+	(format t "~&~S: " (di:frame-number frame)))
+      (format t "~S" frame))
+     (t
+      (when number
+	(format t "~&~S: " (di:frame-number frame)))
+    (when (>= verbosity 2)
+      (let ((loc (di:frame-code-location frame)))
+	 (*debug-abort* (find-restart 'abort))
+	(handler-case
+	    (progn
+	 (*error-output* *debug-io*))
+
+;;;; Invoke-debugger.
+
+(defvar *debugger-hook* nil
+   which causes the standard debugger to execute.  The system passes the value
+   of this variable to the function because it binds *debugger-hook* to nil
+   around the invocation.")
+    (do ((p restarts (cdr p))
+	 (i 0 (1+ i)))
+	((endp p))
+      (format s "~&  ~D: ~A~%" i (car p)))))
+	 ;; Rebind some printer control variables.
+;;; INTERNAL-DEBUG calls the debug loop.  This is used in DEBUG and
+;;; CONDITIONS::ERROR-ERROR.
+	 (*print-readably* nil)
+;;; SHOW-RESTARTS -- Internal.
+  (let ((*in-the-debugger* T)
+	(*read-suppress* NIL))
+  (when restarts
+    (format s "~&Restarts:~%")
+    (let ((count 0)
+	  (names-used '(nil))
+	  (max-name-len 0))
+      (dolist (restart restarts)
+
+;;; NTH-ARG -- Internal.
+;;;
+;;; This returns the n'th arg as the user sees it from args, the result of
+;;; Interface to *debug-commands*.
+;;; 
+(defmacro def-debug-command (name &rest body)
+    (dolist (ele args (error "Argument specification out of range -- ~S." n))
+      (lambda-list-element-dispatch ele
+      (defun ,fun-name () ,@body)
+      (push (cons ,name #',fun-name) *debug-commands*)
+				      (di:frame-code-location *current-frame*)
+		   (error "Unused rest-arg before n'th argument.")
+(defun debug-command-p (form)
+  (if (symbolp form)
+      (cdr (assoc (symbol-name form) *debug-commands* :test #'string=))))
+(defun debug-command-p (form &optional other-commands)
+	;; Return the right value.
+(defun make-restart-commands (&optional (restarts *debug-restarts*))
+(def-debug-command "FRAME" (&optional
+;;; 
+(def-debug-command "Q"
+	   (princ "You are here."))
+	  ((> n current)
+(def-debug-command "GO"
+	    (setf *current-frame*
+		  (do ((prev *current-frame* lead)
+
+(def-debug-command "PUSH"
+  (invoke-debugger *debug-condition*))
+
+(def-debug-command "ABORT"
+  (invoke-restart *debug-abort*))
+		       (lead (di:frame-down *current-frame*)
+(def-debug-command "RESTART"
+		      ((null lead)
+		       (princ "Bottom of stack encountered.")
+		       prev)
+      (write-string "Restart number: ")
+	  (t
+    (invoke-restart-interactively (nth num *debug-restarts*))))
+;;;
+
+;;;
+;;; 
+(def-debug-command "H"
+  (princ debug-help-string))
+	  (princ "No such restart.")))))
+(def-debug-command "ERROR"
+;;; Information commands.
+;;;
+ 
+;;; BACKTRACE-DEBUG-COMMAND binds *inside-debugger-p*, so BACKTRACE will
+;;; not reparse the stack.  *inside-debugger-p* is only bound to non-nil
+;;; when doing evaluations in the debug loop.
+;;; 
+(def-debug-command "BACKTRACE"
+  (let ((*inside-debugger-p* t))
+    (backtrace (read-if-available most-positive-fixnum))))
+   printing a prompting line to continue with output.")
+  (let* ((end -1)
+(defvar *flush-debug-errors* t
+  "Don't recursively call DEBUG on errors while within the debugger if non-nil.")
+	     (let ((code-loc (di:debug-function-start-location place)))
+(def-debug-command "FLUSH"
+  (setf *flush-debug-errors* (not *flush-debug-errors*)))
+
+	(when old-bp-info
+	  (di:deactivate-breakpoint (breakpoint-info-breakpoint old-bp-info))
+	  (setf *breakpoints* (remove old-bp-info *breakpoints*))
+	  (format t "Note: previous breakpoint removed.~%"))
+	(push new-bp-info *breakpoints*))
+      (print-breakpoint-info (first *breakpoints*))
+  (if (not (listen-skip-whitespace in))
+      (princ prompt out))
+
+;;; list all breakpoints set
+(def-debug-command "LIST-BREAKPOINTS" ()
+  (if (listen-skip-whitespace stream)
+	(sort *breakpoints* #'< :key #'breakpoint-info-breakpoint-number))
+  (dolist (info *breakpoints*)
+
+
+
+;;;; Debug-Loop.
+
+(defun debug-loop ()
+  (let ((*debug-command-level* (1+ *debug-command-level*)))
+    (loop
+     (catch 'debug-loop-catcher
+       (handler-bind ((error #'(lambda (condition)
+				 (when *flush-debug-errors*
+				   (clear-input *debug-io*)
+				   (princ condition)
+				   (format t "~&Error flushed ...")
+				   (throw 'debug-loop-catcher nil))
+				 (invoke-debugger condition))))
+	 (funcall *debug-prompt*)
+	 (let* ((exp (read))
+		(cmd-fun (debug-command-p exp))
+		;; Must bind level for restart function created for this abort.
+		(level *debug-command-level*))
+	   (with-simple-restart (abort "Return to debug level ~D." level)
+	     (if cmd-fun
+		 (funcall cmd-fun)
+		 (debug-eval-print exp)))))))))
+
+(defun debug-eval-print (exp)
+  (setq +++ ++ ++ + + - - exp)
+  (let* ((values (multiple-value-list (eval -)))
+	 (*standard-output* *debug-io*))
+    (fresh-line)
+    (if values (prin1 (car values)))
+    (dolist (x (cdr values))
+      (fresh-line)
+      (prin1 x))
+    (setq /// // // / / values)
+    (setq *** ** ** * * (car values))
+    ;; Make sure nobody passes back an unbound marker.
+    (unless (boundp '*)
+      (setq * nil)
+      (fresh-line)
+      (princ "Setting * to NIL -- was unbound marker."))))
+    (print-breakpoint-info info)))
+
+(def-debug-command-alias "LB" "LIST-BREAKPOINTS")
+(def-debug-command-alias "LBP" "LIST-BREAKPOINTS")
+
+;;; remove breakpoint n or all if none given
+(def-debug-command "DELETE-BREAKPOINT" ()
+  (let* ((index (read-if-available nil))
+	 (bp-info
+	  (find index *breakpoints* :key #'breakpoint-info-breakpoint-number)))
+    (cond (bp-info
+	   (di:delete-breakpoint (breakpoint-info-breakpoint bp-info))
+	   (setf *breakpoints* (remove bp-info *breakpoints*))
+	   (format t "Breakpoint ~S removed.~%" index))
+	  (index (format t "Breakpoint doesn't exist."))
+	  (t
+	   (dolist (ele *breakpoints*)
+	     (di:delete-breakpoint (breakpoint-info-breakpoint ele)))
+	   (setf *breakpoints* nil)
+	   (format t "All breakpoints deleted.~%")))))
+
+(def-debug-command-alias "DBP" "DELETE-BREAKPOINT")
+
+
+;;;
+;;; Miscellaneous commands.
+;;;
+
+(def-debug-command "FLUSH-ERRORS" ()
+  (if (setf *flush-debug-errors* (not *flush-debug-errors*))
+      (write-line "Errors now flushed.")
+      (write-line "Errors now create nested debug levels.")))
+
+
+(def-debug-command "DESCRIBE" ()
+  (let* ((curloc (di:frame-code-location *current-frame*))
+	 (debug-fun (di:code-location-debug-function curloc))
+	 (function (di:debug-function-function debug-fun)))
+    (if function
+	(describe function)
+	(format t "Can't figure out the function for this frame."))))
+
+
+;;;
+;;; Editor commands.
+;;;
+
+(def-debug-command "EDIT-SOURCE" ()
+  (unless (typep *terminal-io* 'ed::ts-stream)
+    (error "The debugger's EDIT-SOURCE command only works in slave Lisps ~
+	    connected to a Hemlock editor."))
+  (let* ((wire (ed::ts-stream-wire *terminal-io*))
+	 (location (maybe-block-start-location
+		    (di:frame-code-location *current-frame*)))
+	 (d-source (di:code-location-debug-source location))
+	 (name (di:debug-source-name d-source)))
+    (ecase (di:debug-source-from d-source)
+      (:file
+       (let* ((tlf-offset (di:code-location-top-level-form-offset location))
+	      (local-tlf-offset (- tlf-offset
+				   (di:debug-source-root-number d-source)))
+	      (char-offset (aref (or (di:debug-source-start-positions d-source)
+				     (error "No start positions map."))
+				 local-tlf-offset)))
+	 (wire:remote wire
+	   (ed::edit-source-location (namestring name)
+				     (di:debug-source-created d-source)
+				     tlf-offset local-tlf-offset char-offset
+				     (di:code-location-form-number location)))
+	 (wire:wire-force-output wire)))
+      ((:lisp :stream)
+       (wire:remote wire
+	 (ed::cannot-edit-source-location))
+       (wire:wire-force-output wire)))))
+
+
+
+;;;; Debug loop command utilities.
+
+(defun read-prompting-maybe (prompt &optional (in *standard-input*)
+				    (out *standard-output*))
+  (unless (ext:listen-skip-whitespace in)
+    (princ prompt out)
+    (force-output out))
+  (read in))
+
+(defun read-if-available (default &optional (stream *standard-input*))
+  (if (ext:listen-skip-whitespace stream)
+      (read stream)
+      default))
diff --git a/code/defmacro.lisp b/code/defmacro.lisp
new file mode 100644
index 000000000..aae4551ce
--- /dev/null
+++ b/code/defmacro.lisp
@@ -0,0 +1,413 @@
+;;; -*- Log: code.log; Mode: Lisp; Package: Lisp -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; This file contains the DEFMACRO function that is part of the
+;;; standard Spice Lisp environment.  For the version that runs in
+;;; Maclisp, see file DEFMACRO.LSP.
+;;;
+;;; Written by Scott Fahlman.
+;;;
+;;; Ugly code, since I can't create macros here and need to stay close to
+;;; Maclisp, so that it will be easy to create a derivitive version to use
+;;; in the cross compiler.  Even without this, there's so much going on
+;;; in the arglist that the code has to be hairy.
+;;;
+(in-package 'lisp)
+(export '(defmacro deftype))
+
+;;; The following specials are used for communication during argument-list
+;;; parsing for a macro or macro-like form.
+
+(proclaim '(special %arg-count %min-args %restp %let-list
+		    %keyword-tests *keyword-package*
+		    %env-arg-name %env-arg-used))
+
+;;; The following is an ugly way of getting an optional arg passed in to
+;;; Analyze1.  Bootstrapping problems in Maclisp force me to do this.
+
+(defvar *default-default* nil)
+(defvar *key-finder* 'find-keyword)
+
+;;; Parse-Defmacro  --  Semi-Public
+;;;
+;;;    Provides a clean interface to ANALYZE1
+;;;
+(defun parse-defmacro (arglist whole code errloc &key (path `(cdr ,whole))
+				((:environment %env-arg-name)) error-string
+				(doc-string-allowed t)
+				((:default-default *default-default*) nil)
+				((:key-finder *key-finder*) 'find-keyword))
+  "For use by macros and macro-like forms that must parse some form
+  according to a defmacro-like argument list, ARGLIST.  The first value
+  returned is a LET* form which binds things and then evalutes the
+  specified CODE.  WHOLE is the variable which is bound to the entire
+  arglist, or NIL if &whole is illegal.  ERRLOC is the name of the function
+  being worked on, for use in error messages.  The second value is a list
+  of ignore declarations for the WHOLE and ENVIRONMENT vars, if appropriate.
+
+  PATH is an access expression for getting to the object to be parsed,
+  which defaults to the CDR of WHOLE.
+  
+  ENVIRONMENT is the place where the macroexpansion environment
+  may be found.  If not supplied, then no &environment arg is allowed.
+
+  ERROR-STRING is used as the argument to error if an incorrect number of
+  arguments are supplied.  The additional error arguments are ERRLOC and
+  the number of arguments supplied.  If not supplied, then no argument count
+  error checking is done.
+
+  DOC-STRING-ALLOWED indicates whether a doc-string should be parsed out of
+  the body.  If one is found, it is returned as the third value.
+  
+  DEFAULT-DEFAULT is the default value for unsupplied arguments, which defaults
+  to NIL.
+
+  KEY-FINDER the function used to do keyword lookup.  It defaults to a function
+  that does the right thing.
+
+  The fourth and fifth values are the minimum and maximum number of arguments
+  allowed, in case you care about that kind of thing.  The fifth value is NIL
+  if there is no upper limit."
+  (multiple-value-bind (body local-decs doc)
+		       (parse-body code nil doc-string-allowed)
+
+    (let ((%arg-count 0) (%min-args 0)
+	  (%restp nil) (%let-list nil)
+	  (%keyword-tests nil)
+	  (%env-arg-used nil))
+      (analyze1 arglist path errloc whole)
+    
+      (let ((arg-test (if error-string (defmacro-arg-test whole)))
+	    (body
+	     `(let* ,(nreverse %let-list)
+		,@ local-decs
+		(progn
+		 ,@ %keyword-tests
+		 ,@ body))))
+	(values
+	 (if arg-test
+	     `(if ,arg-test
+		  (error ,error-string ',errloc (length ,path))
+		  ,body)
+	     body)
+	 ;; Wrong if no error check and arglist composed entirely of &environment
+	 ;; args, but anyone who does that deserves to lose...
+	 `(,@(unless (or arg-test arglist) `((declare (ignore ,whole))))
+	   ,@(when (and %env-arg-name (not %env-arg-used))
+	       `((declare (ignore ,%env-arg-name)))))
+	 doc
+	 %min-args
+	 (if %restp nil %arg-count))))))
+
+;;; ANALYZE1 is implemented as a finite-state machine that steps
+;;; through the legal parts of an arglist in order: required, optional,
+;;; rest, key, and aux.  The results are accumulated in a set of special
+;;; variables: %let-list, %arg-count, %min-args, %restp, and %keyword-tests.
+;;;
+;;; ANALYZE1 is called by ANALYZE-ARGLIST to do the work for required and
+;;; optional args.  It calls other functions if &rest, &key, or &aux are
+;;; encountered.
+
+(defun analyze1 (arglist path errloc whole)
+  (do ((args arglist (cdr args))
+       (optionalp nil)
+       a temp)
+      ((atom args)
+       (cond ((null args) nil)
+	     ;; Varlist is dotted, treat as &rest arg and exit.
+	     (t (push (list args path) %let-list)
+		(setq %restp t))))
+    (setq a (car args))
+    (cond ((eq a '&whole)
+	   (cond ((and whole (cdr args) (symbolp (cadr args)))
+		  (push (list (cadr args) whole) %let-list)
+		  (setq %restp t)
+		  (setq args (cdr args)))
+		 (t (error "Illegal or ill-formed &whole arg in ~S." errloc))))
+	  ((eq a '&environment)
+	   (cond ((and %env-arg-name (cdr args) (symbolp (cadr args)))
+		  (push `(,(cadr args) ,%env-arg-name) %let-list)
+		  (setq %env-arg-used t)
+		  (setq args (cdr args)))
+		 (t (error "Illegal or ill-formed &environment arg in ~S."
+			   errloc))))
+	  ((eq a '&optional)
+	   (and optionalp
+		(cerror "Ignore it."
+			"Redundant &optional flag in varlist of ~S." errloc))
+	   (setq optionalp t))
+	  ((or (eq a '&rest) (eq a '&body))
+	   (return (analyze-rest (cdr args) path errloc whole)))
+	  ((eq a '&key)
+	   ;; Create a rest-arg, then do keyword analysis.
+	   (setq temp (gensym))
+	   (setq %restp t)
+	   (push (list temp path) %let-list)
+	   (return (analyze-key (cdr args) temp errloc)))
+	  ((eq a '&allow-other-keys)
+	   (cerror "Ignore it."
+		   "Stray &ALLOW-OTHER-KEYS in arglist of ~S." errloc))
+	  ((eq a '&aux)
+	   (return (analyze-aux (cdr args) errloc)))
+	  ((not optionalp)
+	   (setq %min-args (1+ %min-args))
+	   (setq %arg-count (1+ %arg-count))
+	   (cond ((symbolp a)
+		  (push `(,a (car ,path)) %let-list))
+		 ((atom a)
+		  (cerror "Ignore this item."
+			  "Non-symbol variable name in ~S." errloc))
+		 (t (let ((%min-args 0) (%arg-count 0) (%restp nil)
+			  (new-whole (gensym)))
+		      (push (list new-whole `(car ,path)) %let-list)
+		      (analyze1 a new-whole errloc new-whole))))
+	   (setq path `(cdr ,path)))
+	  ;; It's an optional arg.
+	  (t (setq %arg-count (1+ %arg-count))
+	     (cond ((symbolp a)
+		    ;; Just a symbol.  Bind to car of path or default.
+		    (push `(,a (cond (,path (car ,path))
+				     (t ,*default-default*)))
+			  %let-list))
+		   ((atom a)
+		    (cerror "Ignore this item."
+			    "Non-symbol variable name in ~S." errloc))
+		   ((symbolp (car a))
+		    ;; Car of list is a symbol.  Bind to car of path or
+		    ;; to default value.
+		    (push `(,(car a)
+			    (cond (,path (car ,path))
+				  (t ,(cond ((> (length a) 1) (cadr a))
+					    (t *default-default*)))))
+			  %let-list)
+		    ;; Handle supplied-p variable, if any.
+		    (and (> (length a) 2)
+			 (push `(,(caddr a) (not (null ,path))) %let-list)))
+		   ;; Then destructure arg against contents of this gensym.
+		   (t (setq temp (gensym))
+		      (push `(,temp
+			      (cond (,path (car ,path))
+				    (t ,(cond ((cddr a) (cadr a))
+					      (t *default-default*)))))
+			    %let-list)
+		      (let ((%min-args 0) (%arg-count 0) (%restp nil))
+			(analyze1 (car a) temp errloc nil))
+		      ;; Handle supplied-p variable if any.
+		      (and (> (length a) 2)
+			   (push `(,(caddr a) (not (null ,path))) %let-list))))
+	     (setq path `(cdr ,path))))))
+
+
+;;; This deals with the portion of the arglist following any &rest flag.
+
+(defun analyze-rest (arglist path errloc whole)
+  (when (atom arglist)
+    (error "Bad &rest or &body arg in ~S." errloc))
+  (prog ((rest-arg (car arglist))
+	 (more (cdr arglist)))
+    (cond ((symbolp rest-arg)
+	   (push (list rest-arg path) %let-list))
+	  ((and (consp rest-arg) (> (length (the list rest-arg)) 1))
+	   (unless %env-arg-name
+	     (error "Hairy &body not allowed when no environment available."))
+	   (let ((decls-var (second rest-arg))
+		 (doc-var (third rest-arg))
+		 (n-body (gensym)) (n-decls (gensym)) (n-doc (gensym)))
+	     (setq rest-arg (first rest-arg))
+	     (when doc-var (push doc-var %let-list))
+	     (push decls-var %let-list)
+	     (push `(,rest-arg
+		     (multiple-value-bind (,n-body ,n-decls ,n-doc)
+					  (parse-body ,path ,%env-arg-name
+						      ,(not (null doc-var)))
+		       (setq ,decls-var ,n-decls)
+		       ,(if doc-var `(setq ,doc-var ,n-doc) n-doc)
+		       ,n-body))
+		   %let-list)))
+	  (t
+	   (error "Bad &rest or &body arg in ~S." errloc)))
+		 
+    (setq %restp t)
+    TRY-AGAIN
+    (cond ((null more) nil)
+	  ((atom more)
+	   (cerror "Ignore the illegal terminator."
+		   "Dotted arglist terminator after &rest arg in ~S." errloc))
+	  ((eq (car more) '&key)
+	   (analyze-key (cdr more) rest-arg errloc))
+	  ((eq (car more) '&aux)
+	   (analyze-aux (cdr more) errloc))
+	  ((eq (car more) '&allow-other-keys)
+	   (cerror "Ignore it."
+		   "Stray &ALLOW-OTHER-KEYS in arglist of ~S." errloc))
+	  ((eq (cadr arglist) '&whole)
+	   (cond ((and whole (cdr more) (symbolp (cadr more)))
+		  (push (list (cadr more) whole) %let-list)
+		  (setq more (cddr more))
+		  (go try-again))
+		 (t (error "Ill-formed or illegal &whole arg in ~S."
+			   errloc))))
+	  ((eq (cadr arglist) '&environment)
+	   (cond ((and %env-arg-name (cdr more) (symbolp (cadr more)))
+		  (push `(,(cadr more) ,%env-arg-name) %let-list)
+		  (setq %env-arg-used t)
+		  (setq more (cddr more))
+		  (go try-again))
+		 (t (error "Ill-formed or illegal &environment arg in ~S."
+			   errloc)))))))
+
+;;; Analyze stuff following &aux.
+
+(defun analyze-aux (arglist errloc)
+  (do ((args arglist (cdr args)))
+      ((null args))
+    (cond ((atom args)
+	   (cerror "Ignore the illegal terminator."
+		   "Dotted arglist after &AUX in ~S." errloc)
+	   (return nil))
+	  ((atom (car args))
+	   (push (list (car args) nil) %let-list))
+	  (t (push (list (caar args) (cadar args)) %let-list)))))
+
+
+;;; Handle analysis of keywords, perhaps with destructuring over the keyword
+;;; variable.  Assumes the remainder of the calling form has already been
+;;; bound to the variable passed in as RESTVAR.
+
+(defun analyze-key (arglist restvar errloc)
+  (let ((temp (gensym))
+	(check-keywords t)
+	(keywords-seen nil))
+    (push temp %let-list)
+    (do ((args arglist (cdr args))
+	 a k sp-var temp1)
+	((atom args)
+	 (cond ((null args) nil)
+	       (t (cerror "Ignore the illegal terminator."
+			  "Dotted arglist after &key in ~S." errloc))))
+      (setq a (car args))
+      (cond ((eq a '&allow-other-keys)
+	     (setq check-keywords nil))
+	    ((eq a '&aux)
+	     (return (analyze-aux (cdr args) errloc)))
+	    ;; Just a top-level variable.  Make matching keyword.
+	    ((symbolp a)
+	     (setq k (make-keyword a))
+	     (push `(,a (cond ((setq ,temp (,*key-finder* ',k ,restvar))
+			       (car ,temp))
+			      (t nil)))
+		   %let-list)
+	     (push k keywords-seen))
+	    ;; Filter out error that might choke defmacro.
+	    ((atom a)
+	     (cerror "Ignore this item."
+		     "~S -- non-symbol variable name in arglist of ~S."
+		     a errloc))
+	    ;; Deal with the common case: (var [init [svar]]) 
+	    ((symbolp (car a))
+	     (setq k (make-keyword (car a)))
+	     ;; Deal with supplied-p variable, if any.
+	     (cond ((and (cddr a) (symbolp (caddr a)))
+		    (setq sp-var (caddr a))
+		    (push (list sp-var nil) %let-list))
+		   (t (setq sp-var nil)))
+	     (push `(,(car a)
+		     (cond ((setq ,temp (,*key-finder* ',k ,restvar))
+			    ,@(and sp-var `((setq ,sp-var t)))
+			    (car ,temp))
+			   (t ,(cadr a))))
+		   %let-list)
+	     (push k keywords-seen))
+	    ;; Filter out more error cases that might kill defmacro.
+	    ((or (atom (car a)) (not (keywordp (caar a))) (atom (cdar a)))
+	     (cerror "Ignore this item."
+		     "~S -- ill-formed keyword arg in ~S." (car a) errloc))
+	    ;; Next case is ((:key var) [init [supplied-p]]).
+	    ((symbolp (cadar a))
+	     (setq k (caar a))
+	     ;; Deal with supplied-p variable, if any.
+	     (cond ((and (cddr a) (symbolp (caddr a)))
+		    (setq sp-var (caddr a))
+		    (push (list sp-var nil) %let-list))
+		   (t (setq sp-var nil)))
+	     (push `(,(cadar a)
+		     (cond ((setq ,temp (,*key-finder* ',k ,restvar))
+			    ,@(and sp-var `((setq ,sp-var t)))
+			    (car ,temp))
+			   (t ,(cadr a))))
+		   %let-list)
+	     (push k keywords-seen))
+	    ;; Same case, but must destructure the "variable".
+	    (t (setq k (caar a))
+	       (setq temp1 (gensym))
+	       (cond ((and (cddr a) (symbolp (caddr a)))
+		      (setq sp-var (caddr a))
+		      (push (list sp-var nil) %let-list))
+		     (t (setq sp-var nil)))
+	       (push `(,temp1
+		       (cond ((setq ,temp (,*key-finder* ',k ,restvar))
+			      ,@(and sp-var `((setq ,sp-var t)))
+			      (car ,temp))
+			     (t ,(cadr a))))
+		     %let-list)
+	       (push k keywords-seen)
+	       (let ((%min-args 0) (%arg-count 0) (%restp nil))
+		      (analyze1 (cadar a) temp1 errloc nil)))))
+    (and check-keywords
+	 (push `(keyword-test ,restvar ',keywords-seen) %keyword-tests))))
+	    
+
+;;; Functions that must be around when the macros produced by DEFMACRO are
+;;; expanded.
+
+(defun make-keyword (s)
+  "Takes a non-keyword symbol S and returns the corresponding keyword."
+  (intern (symbol-name s) *keyword-package*))
+
+
+(defun find-keyword (keyword keylist)
+  "If keyword is present in the keylist, return a list of its argument.
+  Else, return NIL."
+  (do ((l keylist (cddr l)))
+      ((atom l) nil)
+    (cond ((atom (cdr l))
+	   (cerror "Stick a NIL on the end and go on."
+		   "Unpaired item in keyword portion of macro call.")
+	   (rplacd l (list nil))
+	   (return nil))
+	  ((eq (car l) keyword) (return (list (cadr l)))))))
+
+
+(defun keyword-test (keylist legal)
+  "Check whether all keywords in a form are legal.  KEYLIST is the portion
+  of the calling form containing keywords.  LEGAL is the list of legal
+  keywords.  If the keyword :allow-other-keyws is present in KEYLIST,
+  just return without complaining about anything."
+  (cond ((memq ':allow-other-keys keylist) nil)
+	(t (do ((kl keylist (cddr kl)))
+	       ((atom kl) nil)
+	     (cond ((memq (car kl) legal))
+		   (t (cerror "Ignore it."
+			      "~S illegal or unknown keyword." (car kl))))))))
+
+;;; Return a form which tests whether an illegal number of arguments 
+;;; have been supplied.  Args is the name of the variable to which
+;;; the arglist is bound.
+;;;
+(defun defmacro-arg-test (args)
+  (cond ((and (zerop %min-args) %restp) nil)
+	((zerop %min-args)
+	 `(> (length ,args) ,(1+ %arg-count)))
+	(%restp
+	 `(< (length ,args) ,(1+ %min-args)))
+	((= %min-args %arg-count)
+	 `(not (= (length ,args) ,(1+ %min-args))))
+	(t
+	 `(or (> (length ,args) ,(1+ %arg-count))
+	      (< (length ,args) ,(1+ %min-args))))))
diff --git a/code/defstruct.lisp b/code/defstruct.lisp
new file mode 100644
index 000000000..4591b9414
--- /dev/null
+++ b/code/defstruct.lisp
@@ -0,0 +1,561 @@
+;;; -*- Log: code.log; Package: C -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; Defstruct structure definition package (Mark II).
+;;; Written by Skef Wholey and Rob MacLachlan.
+;;;
+(in-package 'c)
+(export '(lisp::defstruct) "LISP")
+
+;;; In Spice Lisp, the default structure representation is a simple-vector with
+;;; the subtype field set to 1.  The first element is used to hold the name of
+;;; the structure.  This piece of implementation-dependency resides in the
+;;; macros defined here.
+
+(compiler-let ((lisp::*bootstrap-defmacro* t))
+  (defmacro structurify (structure)
+    "Frobs a vector to turn it into a named structure.  Returns the vector."
+    `(%primitive set-vector-subtype ,structure %g-vector-structure-subtype)))
+
+
+;;; This version of Defstruct is implemented using Defstruct, and is free of
+;;; Maclisp compatability nonsense.  For bootstrapping, you're on your own.
+
+(defun print-defstruct-description (structure stream depth)
+  (declare (ignore depth))
+  (format stream "#<Defstruct-Description for ~S>" (dd-name structure)))
+
+
+;;; DSD-Name  --  Internal
+;;;
+;;;    Return the the name of a defstruct slot as a symbol.  We store it
+;;; as a string to avoid creating lots of worthless symbols at load time.
+;;;
+(defun dsd-name (dsd)
+  (intern (string (dsd-%name dsd)) (symbol-package (dsd-accessor dsd))))
+
+(defun print-defstruct-slot-description (structure stream depth)
+  (declare (ignore depth))
+  (format stream "#<Defstruct-Slot-Description for ~S>" (dsd-name structure)))
+
+;;; The legendary macro itself.
+
+;;; ### Bootstrap hack...
+;;; Install this definition only into the new compiler's environment so that we
+;;; don't break the bootstrap environment.
+;;;
+(compiler-let ((lisp::*bootstrap-defmacro* t))
+
+(defmacro defstruct (name-and-options &rest slot-descriptions)
+  "Defstruct {Name | (Name Option*)} {Slot | (Slot [Default] {Key Value}*)}
+  Define the structure type Name.  See the manual for details."
+  (let* ((defstruct (parse-name-and-options name-and-options))
+	 (name (dd-name defstruct)))
+    (parse-slot-descriptions defstruct slot-descriptions)
+    (if (eq (dd-type defstruct) 'structure)
+	`(progn
+	   (%compiler-defstruct ',defstruct)
+	   ,@(define-constructor defstruct)
+	   ,@(define-boa-constructors defstruct)
+	   
+	   ;;
+	   ;; So the print function is in the right lexical environment, and
+	   ;; can be compiled...
+	   (let ((new ',defstruct))
+	     ,@(when (consp (dd-print-function defstruct))
+		 `((setf (dd-print-function new)
+			 #',(dd-print-function defstruct))))
+	     (%defstruct new))
+	   ',name)
+	`(progn
+	   (eval-when (compile load eval)
+	     (setf (info type kind ',name) nil)
+	     (setf (info type structure-info ',name) ',defstruct))
+	   ,@(define-constructor defstruct)
+	   ,@(define-boa-constructors defstruct)
+	   ,@(define-predicate defstruct)
+	   ,@(define-accessors defstruct)
+	   ,@(define-copier defstruct)
+	   ',name))))
+
+); Compiler-Let
+	   
+
+;;;; Parsing:
+
+(defun parse-name-and-options (name-and-options)
+  (if (atom name-and-options)
+      (setq name-and-options (list name-and-options)))
+  (do* ((options (cdr name-and-options) (cdr options))
+	(name (car name-and-options))
+	(print-function 'default-structure-print)
+	(conc-name (concat-pnames name '-))
+	(constructor (concat-pnames 'make- name))
+	(saw-constructor)
+	(boa-constructors '())
+	(copier (concat-pnames 'copy- name))
+	(predicate (concat-pnames name '-p))
+	(include)
+	(saw-type)
+	(type 'structure)
+	(saw-named)
+	(offset 0))
+       ((null options)
+	(make-defstruct-description
+	 :name name
+	 :conc-name conc-name
+	 :constructor constructor
+	 :boa-constructors boa-constructors
+	 :copier copier
+	 :predicate predicate
+	 :include include
+	 :print-function print-function
+	 :type type
+	 :lisp-type (cond ((eq type 'structure) 'simple-vector)
+			  ((eq type 'vector) 'simple-vector)
+			  ((eq type 'list) 'list)
+			  ((and (listp type) (eq (car type) 'vector))
+			   (cons 'simple-array (cdr type)))
+			  (t (error "~S is a bad :TYPE for Defstruct." type)))
+	 :named (if saw-type saw-named t)
+	 :offset offset))
+    (if (atom (car options))
+	(case (car options)
+	  (:constructor (setq saw-constructor t
+			      constructor (concat-pnames 'make- name)))
+	  (:copier)
+	  (:predicate)
+	  (:named (setq saw-named t))
+	  (t (error "The Defstruct option ~S cannot be used with 0 arguments."
+		    (car options))))
+	(let ((option (caar options))
+	      (args (cdar options)))
+	  (case option
+	    (:conc-name (setq conc-name (car args)))
+	    (:constructor (cond ((cdr args)
+				 (unless saw-constructor
+				   (setq constructor nil))
+				 (push args boa-constructors))
+				(t
+				 (setq saw-constructor t)
+				 (setq constructor (car args)))))
+	    (:copier (setq copier (car args)))
+	    (:predicate (setq predicate (car args)))
+	    (:include (setq include args))
+	    (:print-function (setq print-function (car args)))
+	    (:type (setq saw-type t type (car args)))
+	    (:named (error "The Defstruct option :NAMED takes no arguments."))
+	    (:initial-offset (setq offset (car args)))
+	    (t (error "~S is an unknown Defstruct option." option)))))))
+
+;;; Parse-Slot-Descriptions parses the slot descriptions (surprise) and does
+;;; any structure inclusion that needs to be done.
+
+(defun parse-slot-descriptions (defstruct slots)
+  ;; First strip off any doc string and stash it in the Defstruct.
+  (when (stringp (car slots))
+    (setf (dd-doc defstruct) (car slots))
+    (setq slots (cdr slots)))
+  ;; Then include stuff.  We add unparsed items to the start of the Slots.
+  (when (dd-include defstruct)
+    (let* ((included-name (car (dd-include defstruct)))
+	   (included-thing (info type structure-info included-name))
+	   (modified-slots (cdr (dd-include defstruct))))
+      (unless included-thing
+	(error "Cannot find description of structure ~S to use for inclusion."
+	       included-name))
+      (setf (dd-includes defstruct)
+	    (cons (dd-name included-thing) (dd-includes included-thing)))
+      (setf (dd-offset defstruct) (dd-offset included-thing))
+      (do* ((islots (mapcar #'(lambda (slot)
+				`(,(dsd-name slot) ,(dsd-default slot)
+				  :type ,(dsd-type slot)
+				  :read-only ,(dsd-read-only slot)))
+			    (dd-slots included-thing)))
+	    (islots* islots (cdr islots*)))
+	   ((null islots*)
+	    (setq slots (nconc islots slots)))
+	(let* ((islot (car islots*))
+	       (modifiee (find (car islot) modified-slots
+			       :key #'(lambda (x) (if (atom x) x (car x)))
+			       :test #'string=)))
+	  (when modifiee
+	    (cond ((symbolp modifiee)
+		   ;; If it's just a symbol, nilify the default.
+		   (setf (cadr islot) nil))
+		  ((listp modifiee)
+		   ;; If it's a list, parse new defaults and options.
+		   (setf (cadr islot) (cadr modifiee))
+		   (when (cddr modifiee)
+		     (do ((options (cddr modifiee) (cddr options)))
+			 ((null options))
+		       (case (car options)
+			 (:type
+			  (setf (cadddr islot) (cadr options)))
+			 (:read-only
+			  (setf (cadr (cddddr islot)) (cadr options)))
+			 (t
+			  (error "Bad option in included slot spec: ~S."
+				 (car options)))))))))))))
+  ;; Finally parse the slots into Slot-Description objects.
+  (do ((slots slots (cdr slots))
+       (index (+ (dd-offset defstruct) (if (dd-named defstruct) 1 0)) (1+ index))
+       (descriptions '()))
+      ((null slots)
+       (setf (dd-length defstruct) index)
+       (setf (dd-slots defstruct) (nreverse descriptions)))
+    (let ((slot (car slots)))
+      (push
+       (if (atom slot)
+	   (let ((name slot))
+	     (make-defstruct-slot-description
+	      :%name (string name)
+	      :index index
+	      :accessor (concat-pnames (dd-conc-name defstruct) name)
+	      :type t))
+	   (do ((options (cddr slot) (cddr options))
+		(name (car slot))
+		(default (cadr slot))
+		(type t)
+		(read-only nil))
+	       ((null options)
+		(make-defstruct-slot-description
+		 :%name (string name)
+		 :index index
+		 :accessor (concat-pnames (dd-conc-name defstruct) name)
+		 :default default
+		 :type type
+		 :read-only read-only))
+	     (case (car options)
+	       (:type (setq type (cadr options)))
+	       (:read-only (setq read-only (cadr options))))))
+       descriptions))))
+
+
+
+;;;; Default structure access and copiers:
+;;;
+;;;    In the normal case of structures that have a real type (i.e. no :Type
+;;; option was specified), we want to optimize things for space as well as
+;;; speed, since there can be thousands of defined slot accesors.
+;;;
+;;;    What we do is defined the accessors and copier as closures over
+;;; general-case code.  Since the compiler will normally open-code accesors,
+;;; the (minor) efficiency penalty is not a concern.
+
+;;; Typep-To-Structure  --  Internal
+;;;
+;;;    Return true if Obj is an object of the structure type specified by Info.
+;;; This is called by the accessor closures, which have a handle on the type's
+;;; Defstruct-Description.
+;;;
+(proclaim '(inline typep-to-structure))
+(defun typep-to-structure (obj info)
+  (declare (type defstruct-description info) (inline member))
+  (and (structurep obj)
+       (let ((name (%primitive header-ref obj 0)))
+	 (or (eq name (dd-name info))
+	     (member name (dd-included-by info) :test #'eq)))))
+
+#+new-compiler
+;;; %Defstruct  --  Internal
+;;;
+;;;    Do miscellaneous load-time actions for the structure described by Info.
+;;; Define setters, accessors, copier, predicate, documentation, instantiate
+;;; definition in load-time env.  This is only called for default structures.
+;;;
+(defun %defstruct (info)
+  (declare (type defstruct-description info))
+  (dolist (slot (dd-slots info))
+    (let ((dsd slot))
+      (setf (symbol-function (dsd-accessor slot))
+	    #'(lambda (structure)
+		(declare (optimize (speed 3) (safety 0)))
+		(unless (typep-to-structure structure info)
+		  (error "Structure for accessor ~S is not a ~S:~% ~S"
+			 (dsd-accessor dsd) (dd-name info) structure))
+		(%primitive header-ref structure (dsd-index dsd))))
+      
+      (unless (dsd-read-only slot)
+	(setf (fdefinition `(setf ,(dsd-accessor slot)))
+	      #'(lambda (structure new-value)
+		  (declare (optimize (speed 3) (safety 0)))
+		  (unless (typep-to-structure structure info)
+		    (error "Structure for setter ~S is not a ~S:~% ~S"
+			   `(setf ,(dsd-accessor dsd)) (dd-name info)
+			   structure))
+		  (unless (typep new-value (dsd-type dsd))
+		    (error "New-Value for setter ~S is not a ~S:~% ~S."
+			   `(setf ,(dsd-accessor dsd)) (dsd-type dsd)
+			   new-value))
+		  (%primitive header-set structure (dsd-index dsd)
+			      new-value))))))
+
+  (when (dd-predicate info)
+    (setf (symbol-function (dd-predicate info))
+	  #'(lambda (object)
+	      (declare (optimize (speed 3) (safety 0)))
+	      (if (typep-to-structure object info) t nil))))
+
+  (when (dd-copier info)
+    (setf (symbol-function (dd-copier info))
+	  #'(lambda (structure)
+	      (declare (optimize (speed 3) (safety 0)))
+	      (unless (typep-to-structure structure info)
+		(error "Structure for copier ~S is not a ~S:~% ~S"
+		       (dd-copier info) (dd-name info) structure))
+
+	      (let ((len (dd-length info)))
+		(declare (fixnum len))
+		(do ((i 1 (1+ i))
+		     (res (%primitive alloc-g-vector len nil)))
+		    ((= i len)
+		     (%primitive header-set res 0 (dd-name info))
+		     (structurify res))
+		  (declare (fixnum i))
+		  (%primitive header-set res i
+			      (%primitive header-ref structure i)))))))
+
+  (when (dd-doc info)
+    (setf (documentation (dd-name info) 'type) (dd-doc info))))
+
+
+;;; Define-Accessors returns a list of function definitions for accessing and
+;;; setting the slots of the a typed Defstruct.  The functions are proclaimed
+;;; to be inline, and the types of their arguments and results are declared as
+;;; well.  We count on the compiler to do clever things with Elt.
+
+(defun define-accessors (defstruct)
+  (do ((slots (dd-slots defstruct) (cdr slots))
+       (stuff '())
+       (type (dd-lisp-type defstruct)))
+      ((null slots) stuff)
+    (let* ((slot (car slots))
+	   (name (dsd-accessor slot))
+	   (index (dsd-index slot))
+	   (slot-type (dsd-type slot)))
+      (push
+       `(progn
+	  (proclaim '(inline ,name (setf ,name)))
+	  (defun ,name (structure)
+	    (declare (type ,type structure))
+	    (the ,slot-type (elt structure ,index)))
+	  ,@(unless (dsd-read-only slot)
+	      `((defun (setf ,name) (structure new-value)
+		  (declare (type ,type structure) (type ,slot-type new-value))
+		  (setf (elt structure ,index) new-value)))))
+       stuff))))
+
+
+;;; Define-Constructor returns a definition for the constructor function of the
+;;; given Defstruct.  If the structure is implemented as a vector and is named,
+;;; we structurify it.  If the structure is a vector of some specialized type,
+;;; we can't use the Vector function.
+;;;
+;;; If we are defining safe accessors, we also check the types of the values to
+;;; make sure that they are legal.
+;;;
+(defun define-constructor (defstruct)
+  (let ((name (dd-constructor defstruct)))
+    (when name
+      (let* ((initial-cruft
+	      (if (dd-named defstruct)
+		  (make-list (1+ (dd-offset defstruct))
+			     :initial-element `',(dd-name defstruct))
+		  (make-list (dd-offset defstruct))))
+	     (slots (dd-slots defstruct))
+	     (names (mapcar #'dsd-name slots))
+	     (args (mapcar #'(lambda (slot)
+			       `(,(dsd-name slot) ,(dsd-default slot)))
+			   slots)))
+	`((defun ,name ,(if args `(&key ,@args))
+	    (declare
+	     ,@(mapcar #'(lambda (slot)
+			   `(type ,(dsd-type slot) ,(dsd-name slot)))
+		       slots))
+	    ,(case (dd-type defstruct)
+	       (list
+		`(list ,@initial-cruft ,@names))
+	       (structure
+		`(truly-the ,(dd-name defstruct)
+			    (structurify
+			     (vector ,@initial-cruft ,@names))))
+	       (vector
+		`(vector ,@initial-cruft ,@names))
+	       (t
+		(do ((sluts slots (cdr sluts))
+		     (sets '())
+		     (temp (gensym)))
+		    ((null sluts)
+		     `(let ((,temp (make-array
+				    ,(dd-length defstruct)
+				    :element-type
+				    ',(cadr (dd-lisp-type defstruct)))))
+			,@(when (dd-named defstruct)
+			    `(setf (aref ,temp ,(dd-offset defstruct))
+				   ',(dd-name defstruct)))
+			,@sets
+			,temp))
+		  (let ((slot (car sluts)))
+		    (push `(setf (aref ,temp ,(dsd-index slot))
+				 ,(dsd-name slot))
+			  sets)))))))))))
+
+;;; Find-Legal-Slot   --  Internal
+;;;
+;;;    Given a defstruct description and a slot name, return the corresponding
+;;; slot if it exists, or signal an error if not.
+;;;
+(defun find-legal-slot (defstruct name)
+  (or (find name (dd-slots defstruct) :key #'dsd-name :test #'string=)
+      (error "~S is not a defined slot name in the ~S structure."
+	     name (dd-name defstruct))))
+
+;;; Define-Boa-Constructors defines positional constructor functions.  We generate
+;;; code to set each variable not specified in the arglist to the default given
+;;; in the Defstruct.  We just slap required args in, as with rest args and aux
+;;; args.  Optionals are treated a little differently.  Those that aren't
+;;; supplied with a default in the arg list are mashed so that their default in
+;;; the arglist is the corresponding default from the Defstruct.
+;;;
+;;; If we are defining safe accessors, we check the types of the arguments
+;;; supplied.  We don't bother checking the defaulted arguments since we would
+;;; have to figure out how to eval the defaults only once, and it probably
+;;; isn't worth the effort anyway.
+
+(defun define-boa-constructors (defstruct)
+  (do* ((boas (dd-boa-constructors defstruct) (cdr boas))
+	(name (car (car boas)) (car (car boas)))
+	(args (copy-list (cadr (car boas))) (copy-list (cadr (car boas))))
+	(slots (dd-slots defstruct) (dd-slots defstruct))
+	(slots-in-arglist '() '())
+	(defuns '()))
+       ((null boas) defuns)
+    ;; Find the slots in the arglist and hack the defaultless optionals.
+    (do ((args args (cdr args))
+	 (arg-kind 'required))
+	((null args))
+      (let ((arg (car args)))
+	(if (atom arg)
+	    (if (memq arg '(&optional &rest &aux))
+		(setq arg-kind arg)
+		(case arg-kind
+		  ((required &rest &aux)
+		   (push (find-legal-slot defstruct arg) slots-in-arglist))
+		  (&optional
+		   (let ((dsd (find-legal-slot defstruct arg)))
+		     (push dsd slots-in-arglist)
+		     (rplaca args (list arg (dsd-default dsd)))))))
+	    (push (find-legal-slot defstruct (car arg)) slots-in-arglist))))
+    
+    ;; Then make a list that can be used with a (list ...) or (vector ...).
+    (let ((initial-cruft
+	   (if (dd-named defstruct)
+	       (make-list (1+ (dd-offset defstruct))
+			  :initial-element `',(dd-name defstruct))
+	       (make-list (dd-offset defstruct))))
+	  (thing (mapcar #'(lambda (slot)
+			     (if (memq slot slots-in-arglist)
+				 (dsd-name slot)
+				 (dsd-default slot)))
+			 slots)))
+      (push
+       `(defun ,name ,args
+	  (declare
+	   ,@(mapcar #'(lambda (slot)
+			 `(type ,(dsd-type slot) ,(dsd-name slot)))
+		     slots-in-arglist))
+	  ,(case (dd-type defstruct)
+	     (list
+	      `(list ,@initial-cruft ,@thing))
+	     (structure
+	      `(truly-the ,(dd-name defstruct)
+			  (structurify (vector ,@initial-cruft ,@thing))))
+	     (vector
+	      `(vector ,@initial-cruft ,@thing))
+	     (t
+	      (do ((things thing (cdr things))
+		   (index 0 (1+ index))
+		   (sets '())
+		   (temp (gensym)))
+		  ((null things)
+		   `(let ((,temp (make-array
+				  ,(dd-length defstruct)
+				  :element-type
+				  ',(cadr (dd-lisp-type defstruct)))))
+		      ,@(when (dd-named defstruct)
+			  `(setf (aref ,temp ,(dd-offset defstruct))
+				 ',(dd-name defstruct)))
+		      ,@sets
+		      ,temp))
+		(push `(setf (aref ,temp index) ,(car things))
+		      sets)))))
+       defuns))))
+
+;;; Define-Copier returns the definition for a copier function of a typed
+;;; Defstruct if one is desired.
+
+(defun define-copier (defstruct)
+  (when (dd-copier defstruct)
+    `((defun ,(dd-copier defstruct) (structure)
+	(declare (type ,(dd-lisp-type defstruct) structure))
+	(subseq structure 0 ,(dd-length defstruct))))))
+
+
+;;; Define-Predicate returns a definition for a predicate function if one is
+;;; desired.  This is only called for typed structures, since the default
+;;; structure predicate is implemented as a closure. 
+
+(defun define-predicate (defstruct)
+  (let ((name (dd-name defstruct))
+	(pred (dd-predicate defstruct)))
+    (when (and pred (dd-named defstruct))
+      (let ((ltype (dd-lisp-type defstruct)))
+	`((defun ,pred (object)
+	    (and (typep object ',ltype)
+		 (eq (elt (the ,ltype object) ,(dd-offset defstruct))
+		     ',name))))))))
+
+
+;;; Structure-Predicate  --  Internal
+;;;
+;;;    The typep transform in typetran calls this function when it encounters
+;;; an unknown symbol type specifier.  If the referred-to type is in fact a
+;;; structure type that has a predicate, then we open-code the normal case of
+;;; an exact match, and otherwise call the predicate.
+;;;
+(defun structure-predicate (object type)
+  (let ((def (info type structure-info type)))
+    (if (and def (eq (dd-type def) 'structure) (dd-predicate def))
+	`(and (structurep ,object)
+	      (or (eq (%primitive header-ref ,object 0) ',type)
+		  (,(dd-predicate def) ,object)))
+	`(lisp::structure-typep ,object ',type))))
+
+
+;;; Random sorts of stuff.
+
+(defun default-structure-print (structure stream depth)
+  (declare (ignore depth))
+  (write-string "#S(" stream)
+  (prin1 (svref structure 0) stream)
+  (do ((index 1 (1+ index))
+       (length (length structure))
+       (slots (dd-slots (info type structure-info (svref structure 0)))
+	      (cdr slots)))
+      ((or (= index length)
+	   (and *print-length*
+		(= index *print-length*)))
+       (if (= index length)
+	   (write-string ")" stream)
+	   (write-string "...)" stream)))
+    (write-char #\space stream)
+    (prin1 (dsd-name (car slots)) stream)
+    (write-char #\space stream)
+    (prin1 (svref structure index) stream)))
diff --git a/code/describe.lisp b/code/describe.lisp
new file mode 100644
index 000000000..5d985ce4f
--- /dev/null
+++ b/code/describe.lisp
@@ -0,0 +1,318 @@
+;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (Scott.Fahlman@cs.cmu.edu). 
+;;; **********************************************************************
+;;;
+;;; This is the describe mechanism for Common Lisp.
+;;;
+;;; Written by Skef Wholey or Rob MacLachlan originally.
+;;; Cleaned up, reorganized, and enhanced by Blaine Burks.
+;;;
+;;; This should be done better using CLOS more effectively once CMU Common
+;;; Lisp is brought up to the new standard.  The TYPECASE in DESCRIBE-AUX
+;;; should be unnecessary.	-- Bill Chiles
+;;;
+
+(in-package "LISP")
+
+(export '(describe *describe-level* *describe-verbose*
+		   *describe-implementation-details* *describe-print-level*
+		   *describe-print-length* *describe-indentation*))
+
+
+;;;; DESCRIBE public switches.
+
+(defvar *describe-level* 2
+  "Depth of recursive descriptions allowed.")
+
+(defvar *describe-verbose* nil
+  "If non-nil, descriptions may provide interpretations of information and
+  pointers to additional information.  Normally nil.")
+
+(defvar *describe-implementation-details* nil
+  "If non-null, normally concealed implementation information won't be.")
+
+(defvar *describe-print-level* 2
+  "*print-level* gets bound to this inside describe.")
+
+(defvar *describe-print-length* 5
+  "*print-length gets bound to this inside describe.")
+
+(defvar *describe-indentation* 3
+  "Number of spaces that sets off each line of a recursive description.")
+
+(defvar *in-describe* nil
+  "Used to tell whether we are doing a recursive describe.")
+(defvar *current-describe-level* 0
+  "Used to implement recursive description cutoff.  Don't touch.")
+(defvar *describe-output* nil
+  "An output stream used by Describe for indenting and stuff.")
+(defvar *used-documentation* nil "Documentation already described.")
+(defvar *described-objects* nil
+  "List of all objects describe within the current top-level call to describe.")
+(defvar *current-describe-object* nil
+  "The last object passed to describe.")
+
+;;; DESCRIBE sets up the output stream and calls DESCRIBE-AUX, which does the
+;;; hard stuff.
+;;;
+(defun describe (x &optional (stream *standard-output*))
+  "Prints a description of the object X.
+  See also *describe-level*, defdescribe, *describe-verbose*,
+  *describe-implementation-details*, *describe-print-level*,
+  *describe-print-length*, and *describe-indentation*."
+  (unless *describe-output*
+    (setq *describe-output* (make-indenting-stream *standard-output*)))
+  (cond (*in-describe*
+	 (unless (or (eq x nil) (eq x t))
+	   (let ((*current-describe-level* (1+ *current-describe-level*))
+		 (*current-describe-object* x))
+	     (indenting-further *describe-output* *describe-indentation*
+	       (describe-aux x)))))
+	(t
+	 (setf (indenting-stream-stream *describe-output*) stream)
+	 (let ((*standard-output* *describe-output*)
+	       (*print-level* *describe-print-level*)
+	       (*print-length* *describe-print-length*)
+	       (*used-documentation* ())
+	       (*described-objects* ())
+	       (*in-describe* t)
+	       (*current-describe-object* x))
+	   (describe-aux x))
+	 (values))))
+
+;;; DESCRIBE-AUX does different things for each type.  The order of the
+;;; TYPECASE branches matters with respect to:
+;;;    - symbols and functions until the new standard makes them disjoint.
+;;;    - packages and structure since packages are structures.
+;;; We punt a given call if the current level is greater than *describe-level*,
+;;; or if we detect an object into which we have already descended.
+;;;
+(defun describe-aux (x)
+  (when (or (not (integerp *describe-level*))
+	    (minusp *describe-level*))
+    (error "*describe-level* should be a nonnegative integer - ~A."
+	   *describe-level*))
+  (when (or (>= *current-describe-level* *describe-level*)
+	    (member x *described-objects*))
+    (return-from describe-aux x))
+  (push x *described-objects*)
+  (typecase x
+    (symbol (describe-symbol x))
+    (function (describe-function x))
+    (package (describe-package x))
+    (hash-table (describe-hash-table x))
+    (structure (describe-structure x))
+    (array (describe-array x))
+    (fixnum (describe-fixnum x))
+    (t (default-describe x)))
+  x)
+
+
+
+;;;; Implementation properties.
+
+;;; This supresses random garbage that users probably don't want to see.
+;;;
+(defparameter *implementation-properties*
+  '(%loaded-address
+    ;;
+    ;; Documentation properties:
+    %var-documentation %fun-documentation %struct-documentation
+    %type-documentation %setf-documentation %documentation))
+
+
+;;;; DESCRIBE methods.
+
+;;; DESC-DOC prints the specified kind of documentation about the given Symbol.
+;;;
+(defun desc-doc (symbol name string)
+  (let ((doc (documentation symbol name)))
+    (when (and doc (not (member doc *used-documentation*)))
+      (push doc *used-documentation*)
+      (format t "~&~A~&  ~A" string doc))))
+
+	  
+(defun default-describe (x)
+  (format t "~&~S is a ~S." x (type-of x)))
+
+(defun describe-symbol (x)
+  (let ((package (symbol-package x)))
+    (if package
+	(multiple-value-bind (symbol status)
+			     (find-symbol (symbol-name x) package)
+	  (declare (ignore symbol))
+	  (format t "~&~A is an ~A symbol in the ~A package." x
+		  (string-downcase (symbol-name status))
+		  (package-name (symbol-package x))))
+	(format t "~&~A is an uninterned symbol." x)))
+  ;;
+  ;; Describe the value cell.
+  (when (boundp x)
+    (let ((value (symbol-value x))
+	  (constantp (constantp x)))
+      (cond ((get x 'globally-special)
+	     (if constantp
+		 (format t "~&It is a constant; its value is ~S." value)
+		 (format t "~&It is a special variable; ~
+			    its current binding is ~S."
+			 value)))
+	    (t
+	     (fresh-line)
+	     (write-string "Its value is ")
+	     (print-for-describe value nil)))
+      (desc-doc x 'variable
+		(format nil "~:[Variable~;Constant~] Documentation:"
+			constantp))
+      (describe value)))
+  ;;
+  ;; Describe the function cell.
+  (cond ((macro-function x)
+	 (let ((fun (macro-function x)))
+	   (format t "~&Its macroexpansion function is ~A." fun)
+	   (describe-function fun)
+	   (desc-doc x 'function "Macro Documentation:")))
+	((fboundp x)
+	 (describe-function (symbol-function x))))
+  ;;
+  ;; Print other documentation.
+  (desc-doc x 'structure "Documentation on the structure:")
+  (desc-doc x 'type "Documentation on the type:")
+  (desc-doc x 'setf "Documentation on the SETF form:")
+  (dolist (assoc (get x '%documentation))
+    (unless (member (cdr assoc) *used-documentation*)
+      (format t "~&Documentation on the ~(~A~):~%~A" (car assoc) (cdr assoc))))
+  ;;
+  ;; Print out properties, possibly ignoring implementation details.
+  (do ((plist (symbol-plist X) (cddr plist))
+       (properties-to-ignore (if *describe-implementation-details*
+				 nil
+				 *implementation-properties*)))
+      ((null plist) ())
+    (unless (member (car plist) properties-to-ignore)
+      (format t "~&Its ~S property is ~S." (car plist) (cadr plist))
+      (describe (cadr plist)))))
+
+(defun describe-structure (x)
+  (format t "~&~S is a structure of type ~A." x (svref x 0))
+  (dolist (slot (cddr (inspect::describe-parts x)))
+    (format t "~%~A: ~S." (car slot) (cdr slot))))
+
+(defun describe-array (x)
+  (let ((rank (array-rank x)))
+    (cond ((> rank 1)
+	   (format t "~&~S is " x)
+	   (write-string (if (%displacedp x) "a displaced" "an"))
+	   (format t " array of rank ~A." rank)
+	   (format t "~%Its dimensions are ~S." (array-dimensions x)))
+	  (t
+	   (format t "~&~S is a ~:[~;displaced ~]vector of length ~D." x
+		   (%displacedp x) (length x))
+	   (if (array-has-fill-pointer-p x)
+	       (format t "~&It has a fill pointer, currently ~d"
+		       (fill-pointer x))
+	       (format t "~&It has no fill pointer."))))
+  (format t "~&Its element type is ~S." (array-element-type x))))
+
+(defmacro describe-function-arg-list (object test output)
+  `(progn
+     (print-for-describe ,object)
+     (if ,test
+	 (write-string " is called with zero arguments.")
+	 (indenting-further *standard-output* 2
+	   (format t " can be called with these arguments:~%")
+	   ,output))))
+
+(defun describe-function (x)
+  (case (%primitive get-vector-subtype x)
+    (#.%function-entry-subtype
+     (describe-function-compiled x))
+    (#.%function-closure-subtype
+     (describe-function-lex-closure x))
+    (t
+     (format t "~&It is an unknown type of function."))))
+
+(defun describe-function-compiled (x)
+  (let ((args (%primitive header-ref x %function-entry-arglist-slot)))
+    (describe-function-arg-list
+     *current-describe-object* (string= args "()") (write-string args)))
+  (let ((*print-level* nil)
+	(*print-length* nil)
+	(type (%primitive header-ref x %function-entry-type-slot)))
+    (format t "~&Its argument types are:~%  ~S" (second type))
+    (format t "~&Its result type is:~%  ~S" (third type)))
+  
+  (let ((name (%primitive header-ref x %function-name-slot)))
+    (when (symbolp name)
+      (desc-doc 'function name "Function Documention:")))
+  
+  (let ((info (%primitive header-ref
+			  (%primitive header-ref x
+				      %function-entry-constants-slot)
+			  %function-constants-debug-info-slot)))
+    (when info
+      (let ((sources (c::compiled-debug-info-source info)))
+	(format t "~&On ~A it was compiled from:"
+		(format-universal-time nil
+				       (c::debug-source-compiled
+					(first sources))))
+	(dolist (source sources)
+	  (let ((name (c::debug-source-name source)))
+	    (ecase (c::debug-source-from source)
+	      (:file
+	       (format t "~&~A " (namestring name))
+	       (ext:format-universal-time t (c::debug-source-created source)))
+	      (:stream (format t "~&~S" name))
+	      (:lisp (format t "~&~S" name)))))))))
+
+(defun describe-function-lex-closure (x)
+  (print-for-describe x)
+  (format t " is a lexical closure.~%")
+  (format t "~&Its lexical environment is:")
+  (indenting-further *standard-output* 8
+    (do ((i %function-closure-variables-offset (1+ i)))
+	((= i (%primitive header-length x)))
+      (format t "~&~D: ~S"
+	      (- i %function-closure-variables-offset)
+	      (%primitive header-ref x i))))
+  (describe-function-compiled (%primitive header-ref x %function-name-slot)))
+
+
+(defun print-for-describe (x &optional (freshp t))
+  (when freshp (fresh-line))
+  (cond ((symbolp x)
+	 (write-string (symbol-name x)))
+	(t
+	 (princ x))))
+
+(defun describe-fixnum (x)
+  (cond ((not (or *describe-verbose* (zerop *current-describe-level*))))
+	((primep x)
+	 (format t "~&It is a prime number."))
+	(t
+	 (format t "~&It is a composite number."))))
+
+(defun describe-hash-table (x)
+  (format t "~&~S is an ~a hash table." x (hash-table-kind x))
+  (format t "~&Its size is ~d buckets." (hash-table-size x))
+  (format t "~&Its rehash-size is ~d." (hash-table-rehash-size x))
+  (format t "~&Its rehash-threshold is ~d."
+	  (hash-table-rehash-threshold x))
+  (format t "~&It currently holds ~d entries."
+	  (hash-table-number-entries x)))
+
+(defun describe-package (x)
+  (describe-structure x)
+  (let* ((internal (package-internal-symbols x))
+	 (internal-count (- (package-hashtable-size internal)
+			    (package-hashtable-free internal)))
+	 (external (package-external-symbols x))
+	 (external-count (- (package-hashtable-size external)
+			    (package-hashtable-free external))))
+    (format t "~&~d symbols total: ~d internal and ~d external."
+	     (+ internal-count external-count) internal-count external-count)))
+
diff --git a/code/error.lisp b/code/error.lisp
new file mode 100644
index 000000000..34cd1ffc9
--- /dev/null
+++ b/code/error.lisp
@@ -0,0 +1,1237 @@
+;;; -*- Package: conditions; Log: code.log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; This is a condition system for CMU Common Lisp.
+;;; It was originally taken from some prototyping code written by KMP@Symbolics
+;;; and massaged for our uses.
+;;;
+
+(in-package "CONDITIONS")
+
+#-new-compiler
+(eval-when (compile)
+  (setq lisp::*bootstrap-defmacro* t))
+
+(in-package "LISP")
+(export '(break error warn cerror
+	  ;;
+	  ;; The following are found in Macros.Lisp:
+	  check-type assert etypecase ctypecase ecase ccase
+	  ;;
+	  ;; These are all the new things to export from "LISP" now that this
+	  ;; proposal has been accepted.
+	  *break-on-signals* *debugger-hook* signal handler-case handler-bind
+	  ignore-errors define-condition make-condition with-simple-restart
+	  restart-case restart-bind restart-name restart-name find-restart
+	  compute-restarts invoke-restart invoke-restart-interactively abort
+	  continue muffle-warning store-value use-value invoke-debugger restart
+	  condition warning serious-condition simple-condition simple-warning
+	  simple-error simple-condition-format-string
+	  simple-condition-format-arguments storage-condition stack-overflow
+	  storage-exhausted type-error type-error-datum
+	  type-error-expected-type simple-type-error program-error
+	  control-error stream-error stream-error-stream end-of-file file-error
+	  file-error-pathname cell-error unbound-variable undefined-function
+	  arithmetic-error arithmetic-error-operation arithmetic-error-operands
+	  package-error package-error-package division-by-zero
+	  floating-point-overflow floating-point-underflow))
+
+
+(in-package "CONDITIONS")
+
+;;;; Keyword utilities.
+
+(eval-when (eval compile load)
+
+(defun parse-keyword-pairs (list keys)
+  (do ((l list (cddr l))
+       (k '() (list* (cadr l) (car l) k)))
+      ((or (null l) (not (member (car l) keys)))
+       (values (nreverse k) l))))
+
+(defmacro with-keyword-pairs ((names expression &optional keywords-var)
+			      &body forms)
+  (let ((temp (member '&rest names)))
+    (unless (= (length temp) 2)
+      (error "&rest keyword is ~:[missing~;misplaced~]." temp))
+    (let ((key-vars (ldiff names temp))
+          (key-var (or keywords-var (gensym)))
+          (rest-var (cadr temp)))
+      (let ((keywords (mapcar #'(lambda (x)
+				  (intern (string x) ext:*keyword-package*))
+			      key-vars)))
+        `(multiple-value-bind (,key-var ,rest-var)
+             (parse-keyword-pairs ,expression ',keywords)
+           (let ,(mapcar #'(lambda (var keyword)
+			     `(,var (getf ,key-var ,keyword)))
+			 key-vars keywords)
+	     ,@forms))))))
+
+) ;eval-when
+
+
+
+;;;; Restarts.
+
+(defvar *restart-clusters* '())
+
+(defun compute-restarts ()
+  "Return a list of all the currently active restarts ordered from most
+   recently established to less recently established."
+  (copy-list (apply #'append *restart-clusters*)))
+
+(defun restart-print (restart stream depth)
+  (declare (ignore depth))
+  (if *print-escape*
+      (format stream "#<~S.~X>"
+	      (type-of restart) (system:%primitive lisp::make-fixnum restart))
+      (restart-report restart stream)))
+
+(defstruct (restart (:print-function restart-print))
+  name
+  function
+  report-function
+  interactive-function)
+
+(setf (documentation 'restart-name 'function)
+      "Returns the name of the given restart object.")
+
+(defun restart-report (restart stream)
+  (funcall (or (restart-report-function restart)
+               (let ((name (restart-name restart)))
+		 #'(lambda (stream)
+		     (if name (format stream "~S" name)
+			      (format stream "~S" restart)))))
+           stream))
+
+(defmacro restart-bind (bindings &body forms)
+  "Executes forms in a dynamic context where the given restart bindings are
+   in effect.  Users probably want to use RESTART-CASE.  When clauses contain
+   the same restart name, FIND-RESTART will find the first such clause."
+  `(let ((*restart-clusters*
+	  (cons (list
+		 ,@(mapcar #'(lambda (binding)
+			       (unless (or (car binding)
+					   (member :report-function
+						   binding :test #'eq))
+				 (warn "Unnamed restart does not have a ~
+					report function -- ~S"
+				       binding))
+			       `(make-restart
+				 :name ',(car binding)
+				 :function ,(cadr binding)
+				 ,@(cddr binding)))
+			       bindings))
+		*restart-clusters*)))
+     ,@forms))
+
+(defun find-restart (name)
+  "Returns the first restart named name.  If name is a restart, it is returned
+   if it is currently active.  If no such restart is found, nil is returned.
+   It is an error to supply nil as a name."
+  (dolist (restart-cluster *restart-clusters*)
+    (dolist (restart restart-cluster)
+      (when (or (eq restart name) (eq (restart-name restart) name))
+	(return-from find-restart restart)))))
+  
+
+(defun invoke-restart (restart &rest values)
+  "Calls the function associated with the given restart, passing any given
+   arguments.  If the argument restart is not a restart or a currently active
+   non-nil restart name, then a control-error is signalled."
+  (let ((real-restart (find-restart restart)))
+    (unless real-restart
+      (error 'control-error
+	     :format-string "Restart ~S is not active."
+	     :format-arguments (list restart)))
+    (apply (restart-function real-restart) values)))
+
+(defun invoke-restart-interactively (restart)
+  "Calls the function associated with the given restart, prompting for any
+   necessary arguments.  If the argument restart is not a restart or a
+   currently active non-nil restart name, then a control-error is signalled."
+  (let ((real-restart (find-restart restart)))
+    (unless real-restart
+      (error 'control-error
+	     :format-string "Restart ~S is not active."
+	     :format-arguments (list restart)))
+    (apply (restart-function real-restart)
+	   (let ((interactive-function
+		  (restart-interactive-function real-restart)))
+	     (if interactive-function
+		 (funcall interactive-function)
+		 '())))))
+
+
+(defmacro restart-case (expression &body clauses)
+  "(RESTART-CASE form
+   {(case-name arg-list {keyword value}* body)}*)
+   The form is evaluated in a dynamic context where the clauses have special
+   meanings as points to which control may be transferred (see INVOKE-RESTART).
+   When clauses contain the same case-name, FIND-RESTART will find the first
+   such clause."
+  (flet ((transform-keywords (&key report interactive)
+	   (let ((result '()))
+	     (when report
+	       (setq result (list* (if (stringp report)
+				       `#'(lambda (stream)
+					    (write-string ,report stream))
+				       `#',report)
+				   :report-function
+				   result)))
+	     (when interactive
+	       (setq result (list* `#',interactive
+				   :interactive-function
+				   result)))
+	     (nreverse result))))
+    (let ((temp-var (gensym))
+	  (outer-tag (gensym))
+	  (inner-tag (gensym))
+	  (tag-var (gensym))
+	  (data
+	    (mapcar #'(lambda (clause)
+			(with-keyword-pairs ((report interactive &rest forms)
+					     (cddr clause))
+			  (list (car clause)			   ;name=0
+				(gensym)			   ;tag=1
+				(transform-keywords :report report ;keywords=2
+						    :interactive interactive)
+				(cadr clause)			   ;bvl=3
+				forms)))			   ;body=4
+		    clauses)))
+      `(let ((,outer-tag (cons nil nil))
+	     (,inner-tag (cons nil nil))
+	     ,temp-var ,tag-var)
+	 (catch ,outer-tag
+	   (catch ,inner-tag
+	     (throw ,outer-tag
+		    (restart-bind
+			,(mapcar #'(lambda (datum)
+				     (let ((name (nth 0 datum))
+					   (tag  (nth 1 datum))
+					   (keys (nth 2 datum)))
+				       `(,name #'(lambda (&rest temp)
+						   (setf ,temp-var temp)
+						   (setf ,tag-var ',tag)
+						   (throw ,inner-tag nil))
+					       ,@keys)))
+				 data)
+		      ,expression)))
+	   (case ,tag-var
+	     ,@(mapcar #'(lambda (datum)
+			   (let ((tag  (nth 1 datum))
+				 (bvl  (nth 3 datum))
+				 (body (nth 4 datum)))
+			     `(,tag
+			       (apply #'(lambda ,bvl ,@body) ,temp-var))))
+		       data)))))))
+#|
+This macro doesn't work in our system due to lossage in closing over tags.
+The previous version is uglier, but it sets up unique run-time tags.
+
+(defmacro restart-case (expression &body clauses)
+  "(RESTART-CASE form
+   {(case-name arg-list {keyword value}* body)}*)
+   The form is evaluated in a dynamic context where the clauses have special
+   meanings as points to which control may be transferred (see INVOKE-RESTART).
+   When clauses contain the same case-name, FIND-RESTART will find the first
+   such clause."
+  (flet ((transform-keywords (&key report interactive)
+	   (let ((result '()))
+	     (when report
+	       (setq result (list* (if (stringp report)
+				       `#'(lambda (stream)
+					    (write-string ,report stream))
+				       `#',report)
+				   :report-function
+				   result)))
+	     (when interactive
+	       (setq result (list* `#',interactive
+				   :interactive-function
+				   result)))
+	     (nreverse result))))
+    (let ((block-tag (gensym))
+	  (temp-var  (gensym))
+	  (data
+	    (mapcar #'(lambda (clause)
+			(with-keyword-pairs ((report interactive &rest forms)
+					     (cddr clause))
+			  (list (car clause)			   ;name=0
+				(gensym)			   ;tag=1
+				(transform-keywords :report report ;keywords=2
+						    :interactive interactive)
+				(cadr clause)			   ;bvl=3
+				forms)))			   ;body=4
+		    clauses)))
+      `(block ,block-tag
+	 (let ((,temp-var nil))
+	   (tagbody
+	     (restart-bind
+	       ,(mapcar #'(lambda (datum)
+			    (let ((name (nth 0 datum))
+				  (tag  (nth 1 datum))
+				  (keys (nth 2 datum)))
+			      `(,name #'(lambda (&rest temp)
+					  (setq ,temp-var temp)
+					  (go ,tag))
+				,@keys)))
+			data)
+	       (return-from ,block-tag ,expression))
+	     ,@(mapcan #'(lambda (datum)
+			   (let ((tag  (nth 1 datum))
+				 (bvl  (nth 3 datum))
+				 (body (nth 4 datum)))
+			     (list tag
+				   `(return-from ,block-tag
+				      (apply #'(lambda ,bvl ,@body)
+					     ,temp-var)))))
+		       data)))))))
+|#
+
+(defmacro with-simple-restart ((restart-name format-string
+					     &rest format-arguments)
+			       &body forms)
+  "(WITH-SIMPLE-RESTART (restart-name format-string format-arguments)
+   body)
+   If restart-name is not invoked, then all values returned by forms are
+   returned.  If control is transferred to this restart, it immediately
+   returns the values nil and t."
+  `(restart-case (progn ,@forms)
+     (,restart-name ()
+        :report (lambda (stream)
+		  (format stream ,format-string ,@format-arguments))
+      (values nil t))))
+
+
+
+;;;; Conditions.
+
+(defstruct (condition (:constructor |constructor for condition|)
+                      (:predicate nil)
+                      (:print-function condition-print))
+  )
+
+(defun condition-print (condition stream depth)
+  (declare (ignore depth))
+  (if *print-escape*
+      (format stream "#<~S.~X>"
+	      (type-of condition)
+	      (system:%primitive lisp::make-fixnum condition))
+      (condition-report condition stream)))
+
+
+(eval-when (eval compile load)
+
+(defmacro parent-type     (condition-type) `(get ,condition-type 'parent-type))
+(defmacro slots           (condition-type) `(get ,condition-type 'slots))
+(defmacro conc-name       (condition-type) `(get ,condition-type 'conc-name))
+(defmacro report-function (condition-type)
+  `(get ,condition-type 'report-function))
+(defmacro make-function   (condition-type) `(get ,condition-type 'make-function))
+
+) ;eval-when
+
+(defun condition-report (condition stream)
+  (do ((type (type-of condition) (parent-type type)))
+      ((not type)
+       (format stream "The condition ~A occurred." (type-of condition)))
+    (let ((reporter (report-function type)))
+      (when reporter
+        (funcall reporter condition stream)
+        (return nil)))))
+
+(setf (make-function   'condition) '|constructor for condition|)
+
+(defun make-condition (type &rest slot-initializations)
+  "Makes a condition of type type using slot-initializations as initial values
+   for the slots."
+  (let ((fn (make-function type)))
+    (cond ((not fn) (error 'simple-type-error
+			   :datum type
+			   :expected-type '(satisfies make-function)
+			   :format-string "Not a condition type: ~S"
+			   :format-arguments (list type)))
+          (t (apply fn slot-initializations)))))
+
+
+;;; Some utilities used at macro expansion time.
+;;;
+(eval-when (eval compile load)
+
+(defmacro resolve-function (function expression resolver)
+  `(cond ((and ,function ,expression)
+          (cerror "Use only the :~A information."
+                  "Only one of :~A and :~A is allowed."
+                  ',function ',expression))
+         (,expression (setq ,function ,resolver))))
+         
+(defun parse-new-and-used-slots (slots parent-type)
+  (let ((new '()) (used '()))
+    (dolist (slot slots)
+      (if (slot-used-p (car slot) parent-type)
+          (push slot used)
+          (push slot new)))
+    (values new used)))
+
+(defun slot-used-p (slot-name type)
+  (cond ((eq type 'condition) nil)
+        ((not type) (error "The type ~S does not inherit from condition." type))
+        ((assoc slot-name (slots type)))
+        (t (slot-used-p slot-name (parent-type type)))))
+
+) ;eval-when
+
+(defmacro define-condition (name (parent-type) slot-specs &rest options)
+  "(DEFINE-CONDITION name (parent-type)
+   ( {slot-name | (slot-name) | (slot-name default-value)}*)
+   options)"
+  (let ((constructor (let ((*package* (find-package "CONDITIONS")))
+		       ;; Bind for the INTERN and the FORMAT.
+		       (intern (format nil "Constructor for ~S" name)))))
+    (let ((slots (mapcar #'(lambda (slot-spec)
+			     (if (atom slot-spec) (list slot-spec) slot-spec))
+			 slot-specs)))
+      (multiple-value-bind (new-slots used-slots)
+          (parse-new-and-used-slots slots parent-type)
+	(let ((conc-name-p     nil)
+	      (conc-name       nil)
+	      (report-function nil)
+	      (documentation   nil))
+	  (do ((o options (cdr o)))
+	      ((null o))
+	    (let ((option (car o)))
+	      (case (car option) ;should be ecase
+		(:conc-name
+		 (setq conc-name-p t)
+		 (setq conc-name (cadr option)))
+		(:report
+		 (setq report-function
+		       (if (stringp (cadr option))
+			   `(lambda (stream)
+			      (write-string ,(cadr option) stream))
+			   (cadr option))))
+		(:documentation (setq documentation (cadr option)))
+		(otherwise
+		 (cerror "Ignore this DEFINE-CONDITION option."
+			 "Invalid DEFINE-CONDITION option: ~S" option)))))
+	  (unless conc-name-p
+	    (setq conc-name
+		  (intern (concatenate 'simple-string (symbol-name name)
+				       "-")
+			  *package*)))
+	  ;; The following three forms are compile-time side-effects.  For now,
+	  ;; they affect the global environment, but with modified abstractions
+	  ;; for parent-type, slots, and conc-name, the compiler could easily
+	  ;; make them local.
+	  (setf (parent-type name) parent-type)
+          (setf (slots name)       slots)
+          (setf (conc-name name)   conc-name)
+          ;; finally, the expansion ...
+	  `(progn
+	     (defstruct (,name
+			 (:constructor ,constructor)
+			 (:predicate nil)
+			 (:copier nil)
+			 (:print-function condition-print)
+			 (:include ,parent-type ,@used-slots)
+			 (:conc-name ,conc-name))
+	       ,@new-slots)
+	     (setf (documentation ',name 'type) ',documentation)
+	     (setf (parent-type ',name) ',parent-type)
+	     (setf (slots ',name) ',slots)
+	     (setf (conc-name ',name) ',conc-name)
+	     (setf (report-function ',name)
+		   ,(if report-function `#',report-function))
+	     (setf (make-function ',name) ',constructor)
+	     ',name))))))
+
+
+
+;;;; HANDLER-BIND and SIGNAL.
+
+(defvar *handler-clusters* nil)
+
+(defmacro handler-bind (bindings &body forms)
+  "(HANDLER-BIND ( {(type handler)}* )  body)
+   Executes body in a dynamic context where the given handler bindings are
+   in effect.  Each handler must take the condition being signalled as an
+   argument.  The bindings are searched first to last in the event of a
+   signalled condition."
+  (unless (every #'(lambda (x) (and (listp x) (= (length x) 2))) bindings)
+    (error "Ill-formed handler bindings."))
+  `(let ((*handler-clusters*
+	  (cons (list ,@(mapcar #'(lambda (x) `(cons ',(car x) ,(cadr x)))
+				bindings))
+		*handler-clusters*)))
+     ,@forms))
+
+(defvar *break-on-signals* nil
+  "When (typep condition *break-on-signals*) is true, then calls to SIGNAL will
+   enter the debugger prior to signalling that condition.")
+
+(defun signal (datum &rest arguments)
+  "Invokes the signal facility on a condition formed from datum and arguments.
+   If the condition is not handled, nil is returned.  If
+   (TYPEP condition *BREAK-ON-SIGNALS*) is true, the debugger is invoked before
+   any signalling is done."
+  (let ((condition (coerce-to-condition datum arguments
+					'simple-condition 'signal))
+        (*handler-clusters* *handler-clusters*))
+    (when (typep condition *break-on-signals*)
+      (break "~A~%Break entered because of *break-on-signals*."
+	     condition))
+    (loop
+      (unless *handler-clusters* (return))
+      (let ((cluster (pop *handler-clusters*)))
+	(dolist (handler cluster)
+	  (when (typep condition (car handler))
+	    (funcall (cdr handler) condition)))))
+    nil))
+
+;;; COERCE-TO-CONDITION is used in SIGNAL, ERROR, CERROR, WARN, and
+;;; INVOKE-DEBUGGER for parsing the hairy argument conventions into a single
+;;; argument that's directly usable by all the other routines.
+;;;
+(defun coerce-to-condition (datum arguments default-type function-name)
+  (cond ((typep datum 'condition)
+	 (if arguments
+	     (cerror "Ignore the additional arguments."
+		     'simple-type-error
+		     :datum arguments
+		     :expected-type 'null
+		     :format-string "You may not supply additional arguments ~
+				     when giving ~S to ~S."
+		     :format-arguments (list datum function-name)))
+	 datum)
+        ((symbolp datum) ;Roughly, (subtypep datum 'condition).
+         (apply #'make-condition datum arguments))
+        ((stringp datum)
+	 (make-condition default-type
+                         :format-string datum
+                         :format-arguments arguments))
+        (t
+         (error 'simple-type-error
+		:datum datum
+		:expected-type '(or symbol string)
+		:format-string "Bad argument to ~S: ~S"
+		:format-arguments (list function-name datum)))))
+
+
+
+;;;; INFINITE-ERROR-PROTECT.
+
+(defvar *error-system-initialized*)
+(defvar *max-error-depth* 10 "The maximum number of nested errors allowed.")
+(defvar *current-error-depth* 0 "The current number of nested errors.")
+
+;;; INFINITE-ERROR-PROTECT is used by ERROR and friends to keep us out of
+;;; hyperspace.
+;;;
+(defmacro infinite-error-protect (form)
+  `(if (and (boundp '*error-system-initialized*) (numberp *current-error-depth*))
+       (let ((*current-error-depth* (1+ *current-error-depth*)))
+	 (if (> *current-error-depth* *max-error-depth*)
+	     (error-error "Help! " *current-error-depth* " nested errors.")
+	     ,form))
+       (system:%primitive lisp::halt)))
+
+;;; These are used in ERROR-ERROR.
+;;;
+(defvar %error-error-depth% 0)
+(defvar *error-throw-up-count* 0)
+
+(proclaim '(special lisp::*real-terminal-io*))
+
+;;; ERROR-ERROR can be called when the error system is in trouble and needs
+;;; to punt fast.  Prints a message without using format.  If we get into
+;;; this recursively, then halt.
+;;;
+(defun error-error (&rest messages)
+  (let ((%error-error-depth% (1+ %error-error-depth%)))
+    (when (> *error-throw-up-count* 50)
+      (system:%primitive lisp::halt)
+      (throw 'lisp::top-level-catcher nil))
+    (case %error-error-depth%
+      (1)
+      (2
+       (setq *terminal-io* lisp::*real-terminal-io*))
+      (3
+       (incf *error-throw-up-count*)
+       (throw 'lisp::top-level-catcher nil))
+      (t
+       (system:%primitive lisp::halt)
+       (throw 'lisp::top-level-catcher nil)))
+    
+    (dolist (item messages) (princ item *terminal-io*))
+    (debug:internal-debug)))
+
+
+
+;;;; Fetching errorful function name.
+
+#+new-compiler
+;;; FIND-NAME returns the name of a function if it is a subr or named-lambda.
+;;; If the function is a regular lambda, the whole list is returned, and if
+;;; the function can't be recognized, () is returned.
+(defun find-name (function)
+  (declare (ignore function))
+  'hunoz)
+
+;;; GET-CALLER returns a form that returns the function which called the
+;;; currently active function.
+(defmacro get-caller ()
+  'nil)
+
+
+;;;; ERROR, CERROR, BREAK, WARN.
+
+(define-condition serious-condition (condition) ())
+
+(define-condition error (serious-condition)
+  ((function-name nil)))
+
+#+new-compiler
+(defun error (datum &rest arguments)
+  "Invokes the signal facility on a condition formed from datum and arguments.
+   If the condition is not handled, the debugger is invoked."
+  (infinite-error-protect
+   (let ((condition (coerce-to-condition datum arguments 'simple-error 'error)))
+     (unless (error-function-name condition)
+       (setf (error-function-name condition) (find-name (get-caller))))
+     (signal condition)
+     (invoke-debugger condition))))
+
+#+new-compiler
+;;; CERROR must take care to no use arguments when datum is already a condition
+;;; object.  Furthermore, we must set ERROR-FUNCTION-NAME here instead of
+;;; letting ERROR do it, so we get the correct function name.
+;;;
+(defun cerror (continue-string datum &rest arguments)
+  (with-simple-restart
+      (continue "~A" (apply #'format nil continue-string arguments))
+    (let ((condition (if (typep datum 'condition)
+			 datum
+			 (coerce-to-condition datum arguments
+					      'simple-error 'error))))
+      (unless (error-function-name condition)
+	(setf (error-function-name condition) (find-name (get-caller))))
+      (error condition)))
+  nil)
+
+#+new-compiler
+(defun break (&optional (format-string "Break") &rest format-arguments)
+  "Prints a message and invokes the debugger without allowing any possibility
+   of condition handling occurring."
+  (with-simple-restart (continue "Return from BREAK.")
+    (invoke-debugger
+      (make-condition 'simple-condition
+		      :format-string format-string
+		      :format-arguments format-arguments)))
+  nil)
+
+(define-condition warning (condition) ())
+
+(defvar *break-on-warnings* ()
+  "If non-NIL, then WARN will enter a break loop before returning.")
+
+#+new-compiler
+(defun warn (datum &rest arguments)
+  "Warns about a situation by signalling a condition formed by datum and
+   arguments.  Before signalling, if *break-on-warnings* is set, then BREAK
+   is called.  While the condition is being signaled, a muffle-warning restart
+   exists that causes WARN to immediately return nil."
+  (let ((condition (coerce-to-condition datum arguments 'simple-warning 'warn)))
+    (check-type condition warning "a warning condition")
+    (if *break-on-warnings*
+	(break "~A~%Break entered because of *break-on-warnings*."
+	       condition))
+    (restart-case (signal condition)
+      (muffle-warning ()
+	  :report "Skip warning."
+	(return-from warn nil)))
+    (format *error-output* "~&Warning:~%~A~%" condition)
+    nil))
+
+
+
+;;;; Condition definitions.
+
+;;; Serious-condition and error are defined on the previous page, so ERROR and
+;;; CERROR can SETF a slot in the error condition object.
+;;;
+
+
+(defun simple-condition-printer (condition stream)
+  (apply #'format stream (simple-condition-format-string condition)
+	 		 (simple-condition-format-arguments condition)))
+
+;;; The simple-condition type has a conc-name, so SIMPLE-CONDITION-FORMAT-STRING
+;;; and SIMPLE-CONDITION-FORMAT-ARGUMENTS could be written to handle the
+;;; simple-condition, simple-warning, simple-type-error, and simple-error types.
+;;; This seems to create some kind of bogus multiple inheritance that the user
+;;; sees.
+;;;
+(define-condition simple-condition (condition)
+  (format-string
+   (format-arguments '()))
+  (:conc-name internal-simple-condition-)
+  (:report simple-condition-printer))
+
+;;; The simple-warning type has a conc-name, so SIMPLE-CONDITION-FORMAT-STRING
+;;; and SIMPLE-CONDITION-FORMAT-ARGUMENTS could be written to handle the
+;;; simple-condition, simple-warning, simple-type-error, and simple-error types.
+;;; This seems to create some kind of bogus multiple inheritance that the user
+;;; sees.
+;;;
+(define-condition simple-warning (warning)
+  (format-string
+   (format-arguments '()))
+  (:conc-name internal-simple-warning-)
+  (:report simple-condition-printer))
+
+
+(defun print-simple-error (condition stream)
+  (format stream "~&Error in function ~S.~%~?"
+	  (internal-simple-error-function-name condition)
+	  (internal-simple-error-format-string condition)
+	  (internal-simple-error-format-arguments condition)))
+
+;;; The simple-error type has a conc-name, so SIMPLE-CONDITION-FORMAT-STRING
+;;; and SIMPLE-CONDITION-FORMAT-ARGUMENTS could be written to handle the
+;;; simple-condition, simple-warning, simple-type-error, and simple-error types.
+;;; This seems to create some kind of bogus multiple inheritance that the user
+;;; sees.
+;;;
+(define-condition simple-error (error)
+  (format-string
+   (format-arguments '()))
+  (:conc-name internal-simple-error-)
+  (:report print-simple-error))
+
+
+(define-condition storage-condition (serious-condition) ())
+
+(define-condition stack-overflow    (storage-condition) ())
+(define-condition storage-exhausted (storage-condition) ())
+
+(define-condition type-error (error)
+  (datum
+   expected-type))
+
+;;; The simple-type-error type has a conc-name, so
+;;; SIMPLE-CONDITION-FORMAT-STRING and SIMPLE-CONDITION-FORMAT-ARGUMENTS could
+;;; be written to handle the simple-condition, simple-warning,
+;;; simple-type-error, and simple-error types.  This seems to create some kind
+;;; of bogus multiple inheritance that the user sees.
+;;;
+(define-condition simple-type-error (type-error)
+  (format-string
+   (format-arguments '()))
+  (:conc-name internal-simple-type-error-)
+  (:report simple-condition-printer))
+
+(define-condition case-failure (type-error)
+  (name
+   possibilities)
+  (:report
+    (lambda (condition stream)
+      (format stream "~S fell through ~S expression.~%Wanted one of ~:S."
+	      (type-error-datum condition)
+	      (case-failure-name condition)
+	      (case-failure-possibilities condition)))))
+
+
+;;; SIMPLE-CONDITION-FORMAT-STRING and SIMPLE-CONDITION-FORMAT-ARGUMENTS.
+;;; These exist for the obvious types to seemingly give the impression of
+;;; multiple inheritance.  That is, the last three types inherit from warning,
+;;; type-error, and error while inheriting from simple-condition also.
+;;;
+(defun simple-condition-format-string (condition)
+  (etypecase condition
+    (simple-condition  (internal-simple-condition-format-string  condition))
+    (simple-warning    (internal-simple-warning-format-string    condition))
+    (simple-type-error (internal-simple-type-error-format-string condition))
+    (simple-error      (internal-simple-error-format-string      condition))))
+;;;
+(defun simple-condition-format-arguments (condition)
+  (etypecase condition
+    (simple-condition  (internal-simple-condition-format-arguments  condition))
+    (simple-warning    (internal-simple-warning-format-arguments    condition))
+    (simple-type-error (internal-simple-type-error-format-arguments condition))
+    (simple-error      (internal-simple-error-format-arguments      condition))))
+
+
+(define-condition program-error (error) ())
+
+
+(defun print-control-error (condition stream)
+  (apply #'format
+	 stream "~&Error in function ~S.~%~?"
+	 (control-error-function-name condition)
+	 (control-error-format-string condition)
+	 (control-error-format-arguments condition)))
+
+(define-condition control-error (error)
+  (format-string
+   (format-arguments nil))
+  (:report print-control-error))
+
+
+(define-condition stream-error (error) (stream))
+
+(define-condition end-of-file (stream-error) ())
+
+(define-condition file-error (error) (pathname))
+
+(define-condition package-error (error) (pathname))
+
+(define-condition cell-error (error) (name))
+
+(define-condition unbound-variable (cell-error) ()
+  (:report (lambda (condition stream)
+	     (format stream "The variable ~S is unbound."
+		     (cell-error-name condition)))))
+  
+(define-condition undefined-function (cell-error) ()
+  (:report (lambda (condition stream)
+	     (format stream "The function ~S is undefined."
+		     (cell-error-name condition)))))
+
+(define-condition arithmetic-error (error) (operation operands))
+
+(define-condition division-by-zero         (arithmetic-error) ())
+(define-condition floating-point-overflow  (arithmetic-error) ())
+(define-condition floating-point-underflow (arithmetic-error) ())
+
+
+
+;;;; HANDLER-CASE and IGNORE-ERRORS.
+
+(defmacro handler-case (form &rest cases)
+  "(HANDLER-CASE form
+   { (type ([var]) body) }* )
+   Executes form in a context with handlers established for the condition
+   types.  A peculiar property allows type to be :no-error.  If such a clause
+   occurs, and form returns normally, all its values are passed to this clause
+   as if by MULTIPLE-VALUE-CALL.  The :no-error clause accepts more than one
+   var specification."
+  (let ((no-error-clause (assoc ':no-error cases)))
+    (if no-error-clause
+	(let ((normal-return (make-symbol "normal-return"))
+	      (error-return  (make-symbol "error-return")))
+	  `(block ,error-return
+	     (multiple-value-call #'(lambda ,@(cdr no-error-clause))
+	       (block ,normal-return
+		 (return-from ,error-return
+		   (handler-case (return-from ,normal-return ,form)
+		     ,@(remove no-error-clause cases)))))))
+	(let ((var (gensym))
+	      (outer-tag (gensym))
+	      (inner-tag (gensym))
+	      (tag-var (gensym))
+	      (annotated-cases (mapcar #'(lambda (case) (cons (gensym) case))
+				       cases)))
+	  `(let ((,outer-tag (cons nil nil))
+		 (,inner-tag (cons nil nil))
+		 ,var ,tag-var)
+	     ,var			;ignoreable
+	     (catch ,outer-tag
+	       (catch ,inner-tag
+		 (throw ,outer-tag
+			(handler-bind
+			    ,(mapcar #'(lambda (annotated-case)
+					 `(,(cadr annotated-case)
+					   #'(lambda (temp)
+					       ,(if (caddr annotated-case)
+						    `(setq ,var temp)
+						    '(declare (ignore temp)))
+					       (setf ,tag-var
+						     ',(car annotated-case))
+					       (throw ,inner-tag nil))))
+				     annotated-cases)
+			  ,form)))
+	       (case ,tag-var
+		 ,@(mapcar #'(lambda (annotated-case)
+			       (let ((body (cdddr annotated-case))
+				     (varp (caddr annotated-case)))
+				 `(,(car annotated-case)
+				   ,@(if varp
+					 `((let ((,(car varp) ,var))
+					     ,@body))
+					 body))))
+			   annotated-cases))))))))
+#|
+This macro doesn't work in our system due to lossage in closing over tags.
+The previous version sets up unique run-time tags.
+
+(defmacro handler-case (form &rest cases)
+  "(HANDLER-CASE form
+   { (type ([var]) body) }* )
+   Executes form in a context with handlers established for the condition
+   types.  A peculiar property allows type to be :no-error.  If such a clause
+   occurs, and form returns normally, all its values are passed to this clause
+   as if by MULTIPLE-VALUE-CALL.  The :no-error clause accepts more than one
+   var specification."
+  (let ((no-error-clause (assoc ':no-error cases)))
+    (if no-error-clause
+	(let ((normal-return (make-symbol "normal-return"))
+	      (error-return  (make-symbol "error-return")))
+	  `(block ,error-return
+	     (multiple-value-call #'(lambda ,@(cdr no-error-clause))
+	       (block ,normal-return
+		 (return-from ,error-return
+		   (handler-case (return-from ,normal-return ,form)
+		     ,@(remove no-error-clause cases)))))))
+	(let ((tag (gensym))
+	      (var (gensym))
+	      (annotated-cases (mapcar #'(lambda (case) (cons (gensym) case))
+				       cases)))
+	  `(block ,tag
+	     (let ((,var nil))
+	       ,var				;ignorable
+	       (tagbody
+		 (handler-bind
+		  ,(mapcar #'(lambda (annotated-case)
+			       (list (cadr annotated-case)
+				     `#'(lambda (temp)
+					  ,(if (caddr annotated-case)
+					       `(setq ,var temp)
+					       '(declare (ignore temp)))
+					  (go ,(car annotated-case)))))
+			   annotated-cases)
+			       (return-from ,tag ,form))
+		 ,@(mapcan
+		    #'(lambda (annotated-case)
+			(list (car annotated-case)
+			      (let ((body (cdddr annotated-case)))
+				`(return-from
+				  ,tag
+				  ,(cond ((caddr annotated-case)
+					  `(let ((,(caaddr annotated-case)
+						  ,var))
+					     ,@body))
+					 ((not (cdr body))
+					  (car body))
+					 (t
+					  `(progn ,@body)))))))
+			   annotated-cases))))))))
+|#
+
+(defmacro ignore-errors (&rest forms)
+  "Executes forms after establishing a handler for all error conditions that
+   returns from this form nil and the condition signalled."
+  `(handler-case (progn ,@forms)
+     (error (condition) (values nil condition))))
+
+
+
+;;;; Restart definitions.
+
+(define-condition abort-failure (control-error) ()
+  (:report
+   "Found an \"abort\" restart that failed to transfer control dynamically."))
+
+;;; ABORT signals an error in case there was a restart named abort that did
+;;; not tranfer control dynamically.  This could happen with RESTART-BIND.
+;;;
+(defun abort ()
+  "Transfers control to a restart named abort, signalling a control-error if
+   none exists."
+  (invoke-restart 'abort)
+  (error 'abort-failure))
+
+
+(defun muffle-warning ()
+  "Transfers control to a restart named muffle-warning, signalling a
+   control-error if none exists."
+  (invoke-restart 'muffle-warning))
+
+
+;;; DEFINE-NIL-RETURNING-RESTART finds the restart before invoking it to keep
+;;; INVOKE-RESTART from signalling a control-error condition.
+;;;
+(defmacro define-nil-returning-restart (name args doc)
+  `(defun ,name ,args
+     ,doc
+     (if (find-restart ',name) (invoke-restart ',name ,@args))))
+
+(define-nil-returning-restart continue ()
+  "Transfer control to a restart named continue, returning nil if none exists.")
+
+(define-nil-returning-restart store-value (value)
+  "Transfer control and value to a restart named store-value, returning nil if
+   none exists.")
+
+(define-nil-returning-restart use-value (value)
+  "Transfer control and value to a restart named use-value, returning nil if
+   none exists.")
+
+
+
+
+;;;; Internal Error Codes.
+
+;;; *Internal-error-table* contains a vector, by error code, of functions.
+;;; This is used in %SP-INTERNAL-ERROR, and initialized MAKE-ERROR-TABLE.
+;;;
+(defvar *internal-error-table*)
+
+#+new-compiler
+;;; %SP-INTERNAL-ERROR is called by the microcode when an internal error
+;;; occurrs.  It is simply a dispatch routine which looks up a specialized
+;;; function to call in the special variable, *internal-error-table*.
+;;;
+;;; ERR-CODE -- a fixnum which identifies the specific error.
+;;; PC -- the relative offset of the NEXT macro instruction to be
+;;;        executed in the code vector of the errorful function.
+;;; ARG3 & ARG4 -- arbitrary meaning determined by ERR-CODE.
+;;;
+(defun lisp::%sp-internal-error (err-code arg3 arg4)
+  (infinite-error-protect
+   (funcall (svref *internal-error-table* err-code)
+	    (find-name (get-caller))
+	    0
+	    arg3
+	    arg4)))
+
+;;; DEF-INTERNAL-ERROR defines a form which can be put into the system init
+;;; file (spinit, or vaxinit) to define the errors which the microcode may
+;;; signal.  The form looks like
+;;;
+;;; (def-internal-error err-code condition flag control-string &rest args)
+;;;  ERR-CODE -- the internal code for this error. less than or equal to
+;;;               max-internal-error which is declared in the init file.
+;;;  CONDITION -- the name of the error to signal
+;;;  FLAG -- one of CORRECTABLE, FATAL or SYSTEM-ERROR.  (not evaluated)
+;;;           if CORRECTABLE, %sp-internal-error may return correction values
+;;;           if SYSTEM-ERROR, the CONDITION arg is ignored.
+;;;  CONTROL-STRING -- the error message as a format control string.
+;;;  ARGS -- The args to the control string.  The 3rd & 4th args to
+;;;           %sp-internal-error are available as the variables ARG3 & ARG4.
+;;;
+;;; NOTE: system-error is never supplied, and condition is never used.  Maybe
+;;;       it will be when we signal appropriate conditions for certain
+;;;       situations.
+;;;
+
+;example
+;  (def-internal-error 6 :unbound-symbol correctable
+;    "Unbound symbol: ~s." arg3)
+
+
+(defmacro def-internal-error (number condition flag control-string &rest args)
+  (declare (ignore condition))
+  `(setf (svref *internal-error-table* ,number)
+	 #'(lambda (callers-name PC arg3 arg4)
+	     (declare (ignore ,@(unless (eq flag 'system-error) '(PC))
+			      ,@(unless (member 'arg3 args) '(arg3))
+			      ,@(unless (member 'arg4 args) '(arg4))))
+	     ,(case flag
+		((fatal) `(error 'simple-error
+				 :function-name callers-name
+				 :format-string ,control-string
+				 :format-arguments (list ,@args)))
+		((correctable) `(cerror 'simple-error
+					:function-name callers-name
+					:format-string ,control-string
+					:format-arguments (list ,@args)))))))
+
+
+(defconstant max-internal-error 100
+  "The largest internal error number for Spice Lisp.")
+
+(proclaim '(special allocation-space))
+
+
+(defun make-error-table ()
+  (setq *internal-error-table*
+	(make-array (1+ max-internal-error)
+		    :initial-element
+		    #'(lambda (&rest ignore)
+			(declare (ignore ignore))
+			(break "Undefined Error."))))
+
+  (def-internal-error 1 :wrong-type-argument fatal
+    "Wrong type argument, ~s, should have been of type ~s." arg3 'List)
+  (def-internal-error 2 :wrong-type-argument fatal
+    "Wrong type argument, ~s, should have been of type ~s." arg3 'Symbol)
+  (def-internal-error 3 :wrong-type-argument fatal
+    "Wrong type argument, ~s, should have been of type ~s." arg3 'Number)
+  (def-internal-error 4 :wrong-type-argument fatal
+    "Wrong type argument, ~s, should have been of type ~s." arg3 'Integer)
+  (def-internal-error 5 :wrong-type-argument fatal
+    "Wrong type argument, ~s, should have been of type ~s." arg3 'Ratio)
+  (def-internal-error 6 :wrong-type-argument fatal
+    "Wrong type argument, ~s, should have been of type ~s." arg3 'Complex)
+  (def-internal-error 7 :wrong-type-argument fatal
+    "Wrong type argument, ~s, should have been of type ~s." arg3 'Vector-like)
+  (def-internal-error 8 :wrong-type-argument fatal
+    "Wrong type argument, ~s, should have been of type ~s." arg3 'simple-vector)
+  (def-internal-error 9 :invalid-function fatal
+    "Invalid function: ~s." arg3)
+  (def-internal-error 10 :wrong-type-argument fatal
+    "Wrong type argument, ~s, should have been a function or an array." arg3)
+  (def-internal-error 11 :wrong-type-argument fatal
+    "Wrong type argument, ~s, should have been of type ~s." arg3 'U-vector-like)
+  (def-internal-error 12 :wrong-type-argument fatal
+    "Wrong type argument, ~s, should have been of type ~s."
+    arg3 'simple-bit-vector)
+  (def-internal-error 13 :wrong-type-argument fatal
+    "Wrong type argument, ~s, should have been of type ~s." arg3
+    'simple-string)
+  (def-internal-error 14 :wrong-type-argument fatal
+    "Wrong type argument, ~s, should have been of type ~s." arg3 'character)
+  (def-internal-error 15 :wrong-type-argument fatal
+    "Wrong type argument, ~s, should have been of type ~s."
+    arg3 'Control-Stack-Pointer)
+  (def-internal-error 16 :wrong-type-argument fatal
+    "Wrong type argument, ~s, should have been of type ~s."
+    arg3 'Binding-Stack-Pointer)
+  (def-internal-error 17 :wrong-type-argument fatal
+    "Wrong type argument, ~s, should have been of type ~s." arg3 'Array)
+  (def-internal-error 18 :wrong-type-argument fatal
+    "Wrong type argument, ~s, should have been of type ~s."
+    arg3 'Positive-Fixnum)
+  (def-internal-error 19 :wrong-type-argument fatal
+    "Wrong type argument, ~s, should have been of type ~s." arg3 'SAP-pointer)
+  (def-internal-error 20 :wrong-type-argument fatal
+    "Wrong type argument, ~s, should have been of tyep ~s." arg3 'system-pointer)
+  (def-internal-error 21 :wrong-type-argument fatal
+    "Wrong type argument, ~s, should have been of type ~s." arg3 'float)
+  (def-internal-error 22 :wrong-type-argument fatal
+    "Wrong type argument, ~s, should have been of type ~s." arg3 'rational)
+  (def-internal-error 23 :wrong-type-argument fatal
+    "Wrong type argument, ~s, should have been a non-complex number." arg3)
+
+  (def-internal-error 25 :unbound-variable fatal
+    "Unbound variable: ~s." arg3)
+  (def-internal-error 26 :undefined-function fatal
+    "Undefined function: ~s." arg3)
+  (def-internal-error 27 :error fatal
+    "Attempt to alter NIL.")
+  (def-internal-error 28 :error fatal
+    "Attempt to alter NIL.")
+  (def-internal-error 29 :error fatal
+    "Circularity detected in chain of symbols from definition cell of symbol ~S."
+    arg3)
+
+  ;;Special because handlers won't work while allocation-space is wrong.
+  (setf (svref *internal-error-table* 24)
+	#'(lambda (callers-name ignore0 ignore1 ignore2)
+	    (declare (ignore ignore0 ignore1 ignore2))
+	    (let ((bazfaz allocation-space))
+	      (setq allocation-space 0)
+	      (error 'simple-error
+		     :function-name callers-name
+		     :format-string "Illegal allocation-space value: ~S."
+		     :format-arguments (list bazfaz)))))
+
+  (def-internal-error 30 :error fatal
+    "Illegal u-vector access type: ~s." arg3)
+  (def-internal-error 31 :error fatal
+    "Illegal vector length: ~s." arg3)
+  (def-internal-error 32 :error fatal
+    "Vector index, ~s, out of bounds." arg3)
+  (def-internal-error 33 :error fatal
+    "Illegal index: ~s." arg3)
+  (def-internal-error 34 :error fatal
+    "Illegal shrink value: ~s." arg3)
+  (def-internal-error 35 :error fatal
+    "Shrink value, ~s, is greater than current length of ~s." arg3 arg4)
+  (def-internal-error 36 :error fatal
+    "Illegal data vector, ~S, in an array." arg3)
+  (def-internal-error 37 :error fatal
+    "Too few arguments passed to two or three dimension array access miscop.")
+  (def-internal-error 38 :error fatal
+    "Too many arguments passed to two or three dimension array access miscop.")
+  (def-internal-error 39 :error fatal
+    "Illegal to allocate vector of size: ~s." arg3)
+
+  (def-internal-error 40 :error fatal
+    "Illegal byte pointer: (byte ~s ~s)." arg3 arg4)
+  (def-internal-error 41 :error fatal
+    "Illegal position, ~s, in byte spec." arg3)
+  (def-internal-error 42 :error fatal
+    "Illegal size, ~s, in byte spec." arg3)
+  (def-internal-error 43 :error fatal
+    "Illegal shift count: ~s." arg3)
+  (def-internal-error 44 :error fatal
+    "Illegal boole operation: ~s." arg3)
+
+  (def-internal-error 50 :error fatal "Wrong number of arguments: ~D." arg3)
+
+  (def-internal-error 55 :error fatal
+    "~s is not <= to ~s (Alien index out of bounds.)" arg3 arg4)
+
+  (def-internal-error 60 :error fatal
+    "Attempt to divide ~s by ~s." arg3 arg4)
+  (def-internal-error 61 :unseen-throw-tag fatal
+    "No catcher for throw tag ~s." arg3)
+  (def-internal-error 62 :error fatal
+    "Something using ~S and ~S lead to a short-float underflow." arg3 arg4)
+  (def-internal-error 63 :error fatal
+    "Something using ~S and ~S lead to a short-float overflow." arg3 arg4)
+#|
+  (def-internal-error 64 :error fatal
+    "Something using ~S and ~S lead to a single-float underflow." arg3 arg4)
+  (def-internal-error 65 :error fatal
+    "Something using ~S and ~S lead to a single-float overflow." arg3 arg4)
+|#
+  (def-internal-error 66 :error fatal
+    "Something using ~S and ~S lead to a long-float underflow." arg3 arg4)
+  (def-internal-error 67 :error fatal
+    "Something using ~S and ~S lead to a long-float overflow." arg3 arg4)
+  (def-internal-error 68 :error fatal
+    "Something using ~S caused a short-float underflow." arg3)
+  (def-internal-error 69 :error fatal
+    "Something using ~S caused a short-float overflow." arg3)
+  (def-internal-error 70 :error fatal
+    "Something using ~S caused a long-float underflow." arg3)
+  (def-internal-error 71 :error fatal
+    "Something using ~S caused a long-float overflow." arg3)
+  (def-internal-error 72 :error fatal
+    "~S is not a legal argument to log, it should be non-zero." arg3)
+  (def-internal-error 73 :wrong-type-argument fatal
+    "Wrong type argument, ~s, should have been of type ~s." arg3 'string-char)
+  (def-internal-error 74 :wrong-type-argument fatal
+    "Wrong type argument, ~s, should have been of type ~s." arg3 'short-float)
+  (def-internal-error 75 :wrong-type-argument fatal
+    "Wrong type argument, ~s, should have been of type ~s." arg3 'long-float)
+  (def-internal-error 76 :wrong-type-argument fatal
+    "Wrong type argument, ~s, should have been of type ~s." arg3 'fixnum)
+  (def-internal-error 77 :wrong-type-argument fatal
+    "Wrong type argument, ~s, should have been of type ~s." arg3 'cons)
+  (def-internal-error 78 :error fatal
+    "Invalid exit.")
+  (def-internal-error 79 :error fatal
+    "Odd number of arguments in keyword part of argument list.")
+  (def-internal-error 80 :error fatal
+    "~S is not a known keyword argument specifier." arg3)
+  (def-internal-error 81 :wrong-type-argument fatal
+    "Wrong type argument, ~s, should have been of type ~s." arg3 arg4)
+  (def-internal-error 82 :wrong-type-argument fatal
+    "Wrong type argument, ~s, should have been of type ~s." arg3
+    '(or function symbol))
+  (def-internal-error 83 :error fatal
+    "~S is not = to ~S (Alien index out of bounds.)" arg3 arg4)
+  
+  )
+
+
+
+;;; ERROR-INIT is called at init time to initialize the error system.
+;;; It initializes the internal error table, and sets a variable.
+;;;
+(defun error-init ()
+  (make-error-table)
+  (setq *error-system-initialized* t))
+
+#-new-compiler
+(eval-when (compile)
+  (setq lisp::*bootstrap-defmacro* nil))
diff --git a/code/eval.lisp b/code/eval.lisp
new file mode 100644
index 000000000..07da893c9
--- /dev/null
+++ b/code/eval.lisp
@@ -0,0 +1,366 @@
+;;; -*- Log: code.log; Package: Lisp -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;;    
+(in-package "LISP")
+(export '(eval *evalhook*
+	  *applyhook* evalhook applyhook constantp quote proclaim
+	  eval-when progn prog1 prog2 let let*
+	  do do* dotimes dolist progv and or cond if the
+	  macro-function special-form-p *macroexpand-hook*
+	  macroexpand-1 macroexpand block return-from
+	  return function setq psetq apply funcall
+	  compiler-let progv flet labels macrolet
+	  mapcar maplist mapc mapl mapcan mapcon
+	  tagbody prog prog* go 
+	  values multiple-values-limit
+	  values-list multiple-value-list multiple-value-call
+	  multiple-value-prog1 multiple-value-bind multiple-value-setq
+	  catch unwind-protect throw defun
+	  lambda-list-keywords call-arguments-limit lambda-parameters-limit
+	  function-lambda-expression
+          ;;
+          ;; Declaration symbols referenced in the cold load.
+          declare special 
+	  ;;
+	  ;; Magical markers...
+	  lambda &optional &rest &key &aux &body &whole
+	  &allow-other-keys &environment))
+
+(export '(eval::interpreted-function-p
+	  eval::interpreted-function-lambda-expression)
+	"EVAL")
+(import '(eval::*eval-stack-top*))
+
+(in-package 'system)
+(export '(parse-body find-if-in-closure))
+
+(in-package "LISP")
+
+
+(defconstant lambda-list-keywords
+  '(&optional &rest &key &aux &body &whole &allow-other-keys &environment)
+  "Keywords that you can put in a lambda-list, supposing you should want
+  to do such a thing.")
+
+(defconstant call-arguments-limit most-positive-fixnum
+  "The exclusive upper bound on the number of arguments which may be passed
+  to a function, including rest args.")
+
+(defconstant lambda-parameters-limit most-positive-fixnum
+  "The exclusive upper bound on the number of parameters which may be specifed
+  in a given lambda list.  This is actually the limit on required and optional
+  parameters.  With &key and &aux you can get more.")
+
+(defconstant multiple-values-limit most-positive-fixnum
+  "The exclusive upper bound on the number of multiple-values that you can
+  have.")
+
+
+
+;;;; EVAL and friends.
+
+;;;
+;;; This flag is used by EVAL-WHEN to keep track of when code has already been
+;;; evaluated so that it can avoid multiple evaluation of nested EVAL-WHEN
+;;; (COMPILE)s.
+(defvar *already-evaled-this* nil)
+
+;;;
+;;; This needs to be initialized in the cold load, since the top-level catcher
+;;; will always restore the initial value.
+(defvar *eval-stack-top* 0)
+
+;;; EVAL  --  Public
+;;;
+;;;    Pick off a few easy cases, and call INTERNAL-EVAL for the rest.  If
+;;; *ALREADY-EVALED-THIS* is true, then we bind it to NIL before doing a call
+;;; so that the effect is confined to the lexical scope of the EVAL-WHEN.
+;;;
+(defun eval (exp)
+  "Evaluates its single arg in a null lexical environment, returns the
+  result or results."
+  (let ((exp (macroexpand exp)))
+    (typecase exp
+      (symbol (symbol-value exp))
+      (list
+       (let ((name (first exp))
+	     (args (1- (length exp))))
+	 (case name
+	   (function
+	    (unless (= args 1)
+	      (error "Wrong number of args to FUNCTION:~% ~S." exp))
+	    (let ((name (second exp)))
+	      (if (or (atom name)
+		      (and (consp name)
+			   (eq (car name) 'setf)))
+		  (fdefinition name)
+		  (eval:make-interpreted-function name))))
+	   (quote
+	    (unless (= args 1)
+	      (error "Wrong number of args to QUOTE:~% ~S." exp))
+	    (second exp))
+	   (setq
+	    (unless (evenp args)
+	      (error "Odd number of args to SETQ:~% ~S." exp))
+	    (unless (zerop args)
+	      (do ((name (cdr exp) (cddr name)))
+		  ((null name)
+		   (do ((args (cdr exp) (cddr args)))
+		       ((null (cddr args))
+			(set (first args) (eval (second args))))
+		     (set (first args) (eval (second args)))))
+		(unless (eq (info variable kind (first name)) :special)
+		  (return (eval:internal-eval exp))))))
+	   ((progn)
+	    (when (> args 0)
+	      (dolist (x (butlast (rest exp)) (eval (car (last exp))))
+		(eval x))))
+	   (t
+	    (if (and (symbolp name)
+		     (eq (info function kind name) :function))
+		(collect ((args))
+		  (dolist (arg (rest exp))
+		    (args (eval arg)))
+		  (if *already-evaled-this*
+		      (let ((*already-evaled-this* nil))
+			(apply (symbol-function name) (args)))
+		      (apply (symbol-function name) (args))))
+		(eval:internal-eval exp))))))
+      (t
+       exp))))
+
+
+;;; INTERPRETED-FUNCTION-P  --  Interface
+;;;
+;;;    This is defined here so that the printer &c can call it before the full
+;;; interpreter is loaded.
+;;;
+(defun eval:interpreted-function-p (x)
+  (and (functionp x)
+       (= (%primitive get-vector-subtype x) %function-closure-subtype)
+       (fboundp 'eval::leaf-value)
+       (let ((const (%primitive header-ref
+				(%primitive header-ref x %function-name-slot)
+				%function-entry-constants-slot)))
+	 (or (eq (%primitive header-ref #'eval::leaf-value
+			     %function-entry-constants-slot)
+		 const)
+	     (eq (%primitive header-ref #'eval:make-interpreted-function
+			     %function-entry-constants-slot)
+		 const)))))
+
+
+;;; FUNCTION-LAMBDA-EXPRESSION  --  Public
+;;;
+;;;    If interpreted, use the interpreter interface.  Otherwise, see if it was
+;;; compiled with COMPILE.  If that fails, check for an inline expansion.
+;;;
+(defun function-lambda-expression (fun)
+  "Given a function, return three values:
+   1] A lambda expression that could be used to define the function, or NIL if
+      the definition isn't available.
+   2] NIL if the function was definitely defined in a null lexical environment,
+      and T otherwise.
+   3] Some object that \"names\" the function.  Although this is allowed to be
+      any object, CMU CL always returns a valid function name or a string."
+  (declare (type function fun))
+  (if (eval:interpreted-function-p fun)
+      (eval:interpreted-function-lambda-expression fun)
+      (case (%primitive get-vector-subtype fun)
+	(#.%function-closure-subtype
+	 (function-lambda-expression
+	  (%primitive header-ref fun %function-name-slot)))
+	((#.%function-entry-subtype #.%function-closure-entry-subtype)
+	 (let ((name (%primitive header-ref fun %function-name-slot))
+	       (info (%primitive header-ref
+				 (%primitive header-ref fun
+					     %function-entry-constants-slot)
+				 %function-constants-debug-info-slot)))
+	   (if info
+	       (let ((source (first (c::compiled-debug-info-source info))))
+		 (cond ((eq (c::debug-source-from source) :lisp)
+			(values (c::debug-source-name source)
+				nil name))
+		       ((stringp name)
+			(values nil t name))
+		       (t
+			(let ((exp (info function inline-expansion name)))
+			  (if exp
+			      (values exp nil name)
+			      (values nil t name))))))
+	       (values nil t name)))))))
+
+
+;;; FIND-IF-IN-CLOSURE  --  Interface
+;;;
+;;;    Like FIND-IF, only we do it on a compiled closure's environment.
+;;;
+(defun find-if-in-closure (test fun)
+  (do ((i %function-closure-variables-offset (1+ i))
+       (len (%primitive header-length fun)))
+      ((= i len) nil)
+    (let ((elt (%primitive header-ref fun i)))
+      (when (funcall test elt)
+	(return elt)))))
+
+(defvar *evalhook* nil
+  "Used to substitute another function for EVAL, for use by STEP, etc.
+  If *EVALHOOK* is not NIL, its value must be a function of the two
+  arguments, the form to evaluate and the environment to evaluate in.
+  This function does the evaluation instead of EVAL.")
+
+(defvar *applyhook* nil
+  "Used to substitute another function for the implicit APPLY normally done
+  within EVAL.  If *APPLYHOOK* is not NIL, its value must be a function 
+  which takes as arguments the function to be applied, the list of arguments
+  it is to be applied to, and the lexical environment.  This function does
+  the application instead of EVAL.")
+
+#|
+(defun evalhook (form evalhookfn applyhookfn &optional env)
+  "Evaluates Form with *Evalhook* bound to Evalhookfn and *Applyhook* bound
+  to applyhookfn.  Ignores these hooks once, for the top-level evaluation
+  of Form."
+  ###)
+|#
+
+#|
+(defun applyhook (function args evalhookfn applyhookfn &optional env)
+  "Applies Function to Args, with *Evalhook* bound to Evalhookfn and with
+  *Applyhook* bound to Applyhookfn.  Ignores the hook function once, for the
+  top-level application of Function to Args."
+  ###)
+|#
+
+
+;;;; Syntactic environment access:
+
+(defun special-form-p (symbol)
+  "If the symbol globally names a special form, returns the definition in a
+  mysterious internal format (a FEXPR), else returns NIL."
+  (declare (symbol symbol))
+  (eq (info function kind symbol) :special-form))
+
+(defvar *macroexpand-hook* 'funcall
+  "The value of this variable must be a function that can take three
+  arguments, a macro expander function, the macro form to be expanded,
+  and the lexical environment to expand in.  The function should
+  return the expanded form.  This function is called by MACROEXPAND-1
+  whenever a runtime expansion is needed.  Initially this is set to
+  FUNCALL.")
+
+
+;;; Macroexpand-1  --  Public
+;;;
+;;;    The Env arg may actually be the compiler *fenv* alist.
+;;;
+(defun macroexpand-1 (form &optional env)
+  "If form is a macro, expands it once.  Returns two values, the
+  expanded form and a T-or-NIL flag indicating whether the form was,
+  in fact, a macro.  Env is the lexical environment to expand in,
+  which defaults to the null environment."
+  (let ((fenv #|(if (listp env) env
+		  (lexical-environment-fenv env))|#
+	      env))
+    (if (and (consp form) (symbolp (car form)))
+	(let ((local-def (cdr (assoc (car form) fenv))))
+	  (if local-def
+	      (if (and (consp local-def) (eq (car local-def) 'MACRO))
+		  (values (funcall *macroexpand-hook* (cdr local-def)
+				   form fenv)
+			  t)
+		  (values form nil))
+	      (let ((global-def (macro-function (car form))))
+		(if global-def
+		    (values (funcall *macroexpand-hook* global-def form fenv)
+			    t)
+		    (values form nil)))))
+	(values form nil))))
+
+
+(defun macroexpand (form &optional env)
+  "If Form is a macro call, then the form is expanded until the result is not
+  a macro.  Returns as multiple values, the form after any expansion has
+  been done and T if expansion was done, or NIL otherwise.  Env is the
+  lexical environment to expand in, which defaults to the null environment."
+  (prog (flag)
+    (multiple-value-setq (form flag) (macroexpand-1 form env))
+    (unless flag (return (values form nil)))
+    loop
+    (multiple-value-setq (form flag) (macroexpand-1 form env))
+    (if flag (go loop) (return (values form t)))))
+
+
+(defun macro-function (symbol)
+  "If the symbol globally names a macro, returns the expansion function,
+  else returns NIL."
+  (declare (symbol symbol))
+  (if (eq (info function kind symbol) :macro)
+      (info function macro-function symbol)
+      nil))
+
+
+(defun (setf macro-function) (symbol function)
+  (declare (symbol symbol) (type function function))
+
+  (when (eq (info function kind symbol) :special-form)
+    (error "~S names a special form." symbol))
+
+  (setf (info function kind symbol) :macro)
+  (setf (info function macro-function symbol) function)
+  (fmakunbound symbol)
+  function)
+
+
+(defun constantp (object)
+  "True of any Lisp object that has a constant value: types that eval to
+  themselves, keywords, constants, and list whose car is QUOTE."
+  (typecase object
+    (number t)
+    (character t)
+    (array t)
+    (symbol
+     (eq (info variable kind object) :constant))
+    (list (eq (car object) 'quote))))
+
+
+;;; Function invocation:
+
+(defun apply (function arg &rest args)
+  "Applies FUNCTION to a list of arguments produced by evaluating ARGS in
+  the manner of LIST*.  That is, a list is made of the values of all but the
+  last argument, appended to the value of the last argument, which must be a
+  list."
+  (cond ((atom args)
+	 (apply function arg))
+	((atom (cdr args))
+	 (apply function (cons arg (car args))))
+	(t (do* ((a1 args a2)
+		 (a2 (cdr args) (cdr a2)))
+		((atom (cdr a2))
+		 (rplacd a1 (car a2))
+		 (apply function (cons arg args)))))))
+
+
+(defun funcall (function &rest arguments)
+  "Calls Function with the given Arguments."
+  (apply function arguments))
+
+
+
+;;; Multiple-Value forms:
+
+(defun values (&rest values)
+  "Returns all of its arguments, in order, as values."
+  (values-list values))
+
+(defun values-list (list)
+  "Returns all of the elements of List, in order, as values."
+  (values-list list))
diff --git a/code/extensions.lisp b/code/extensions.lisp
new file mode 100644
index 000000000..8e7ea31c0
--- /dev/null
+++ b/code/extensions.lisp
@@ -0,0 +1,349 @@
+;;; -*- Log: code.log; Package: Extensions -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; Spice Lisp extensions to the language.
+;;;
+;;; Letf written by Steven Handerson.
+;;;
+;;; **********************************************************************
+(in-package "EXTENSIONS")
+
+(export '(letf* letf dovector deletef indenting-further
+		read-char-no-edit listen-skip-whitespace concat-pnames
+		iterate once-only collect do-anonymous undefined-value))
+
+(import 'lisp::whitespace-char-p)
+
+
+;;; Undefined-Value  --  Public
+;;;
+;;;    This is here until we figure out what to do with it.
+;;;
+(proclaim '(inline undefined-value))
+(defun undefined-value ()
+  '%undefined%)
+
+
+(defun skip-whitespace (&optional (stream *standard-input*))
+  (loop (let ((char (read-char stream)))
+	  (if (not (lisp::whitespacep char))
+	      (return (unread-char char stream))))))
+
+  
+(defun listen-skip-whitespace (&optional (stream *standard-input*))
+  "See listen.  Any whitespace in the input stream will be flushed."
+  (do ((char (read-char-no-hang stream nil nil nil)
+	     (read-char-no-hang stream nil nil nil)))
+      ((null char) nil)
+    (cond ((not (whitespace-char-p char))
+	   (unread-char char stream)
+	   (return T)))))
+
+;;; These macros waste time as opposed to space.
+
+(defmacro letf* (bindings &body body &environment env)
+  "Does what one might expect, saving the old values and setting the generalized
+  variables to the new values in sequence.  Unwind-protects and get-setf-method
+  are used to preserve the semantics one might expect in analogy to let*,
+  and the once-only evaluation of subforms."
+  (labels ((do-bindings
+	    (bindings)
+	    (cond ((null bindings) body)
+		  (t (multiple-value-bind (dummies vals newval setter getter)
+					  (lisp::foo-get-setf-method (caar bindings) env)
+		       (let ((save (gensym)))
+			 `((let* (,@(mapcar #'list dummies vals)
+				  (,(car newval) ,(cadar bindings))
+				  (,save ,getter))
+			     (unwind-protect
+			       (progn ,setter
+				      ,@(do-bindings (cdr bindings)))
+			       (setq ,(car newval) ,save)
+			       ,setter)))))))))
+    (car (do-bindings bindings))))
+
+
+(defmacro letf (bindings &body body &environment env)
+  "Like letf*, but evaluates all the implicit subforms and new values of all
+  the implied setfs before altering any values.  However, the store forms
+  (see get-setf-method) must still be evaluated in sequence.  Uses unwind-
+  protects to protect the environment."
+  (let (temps)
+    (labels
+      ((do-bindings
+	(bindings)
+	(cond ((null bindings) body)
+	      (t (let ((binding (car bindings)))
+		   (multiple-value-bind (dummies vals newval setter getter)
+					(lisp::foo-get-setf-method (car binding) env)
+		     (let ((save (gensym)))
+		       (mapcar #'(lambda (a b) (push (list a b) temps))
+			       dummies vals) 
+		       (push (list save getter) temps)
+		       (push (list (car newval) (cadr binding)) temps)
+		       `((unwind-protect
+			   (progn ,setter
+				  ,@(do-bindings (cdr bindings)))
+			   (setq ,(car newval) ,save)
+			   ,setter)))))))))
+      (let ((form (car (do-bindings bindings))))
+	`(let* ,(nreverse temps)
+	   ,form)))))
+
+
+(define-setf-method logbitp (index int &environment env)
+  (multiple-value-bind (temps vals stores store-form access-form)
+		       (lisp::foo-get-setf-method int env)
+    (let ((ind (gensym))
+	  (store (gensym))
+	  (stemp (first stores)))
+      (values `(,ind ,@temps)
+	      `(,index
+		,@vals)
+	      (list store)
+	      `(let ((,stemp
+		      (dpb (if ,store 1 0) (byte 1 ,ind) ,access-form)))
+		 ,store-form
+		 ,store)
+	      `(logbitp ,ind ,access-form)))))
+
+
+;;; Indenting-Further is a user-level macro which may be used to locally increment
+;;; the indentation of a stream.
+
+(defmacro indenting-further (stream more &rest body)
+  "Causes the output of the indenting Stream to indent More spaces.  More is
+  evaluated twice."
+  `(unwind-protect
+     (progn
+      (incf (lisp::indenting-stream-indentation ,stream) ,more)
+      ,@body)
+     (decf (lisp::indenting-stream-indentation ,stream) ,more)))
+
+
+;;; Deletef
+
+(defmacro deletef (elt list &rest keys &environment env)
+  (multiple-value-bind (dummies vals newval setter getter)
+		       (lisp::foo-get-setf-method list env)
+    (let ((eltsym (gensym))
+	  (listsym (gensym)))
+      `(let* ((,eltsym ,elt)
+	      ,@(mapcar #'list dummies vals)
+	      (,listsym ,getter)
+	      (,(car newval) (delete ,eltsym ,listsym ,@keys)))
+	 ,setter))))
+
+
+(defmacro dovector ((elt vector) &rest forms)
+  "Just like dolist, but with one-dimensional arrays."
+  (let ((index (gensym))
+	(length (gensym))
+	(vec (gensym)))
+    `(let ((,vec ,vector))
+       (do ((,index 0 (1+ ,index))
+	    (,length (length ,vec)))
+	   ((>= ,index ,length) nil)
+	 (let ((,elt (aref ,vec ,index)))
+	   ,@forms)))))
+
+
+(eval-when (compile load eval)
+  (defun concat-pnames (name1 name2)
+    (if name1
+	(intern (concatenate 'simple-string (symbol-name name1)
+			     (symbol-name name2)))
+	name2)))
+
+
+;;; Iterate  --  Public
+;;;
+;;;    The ultimate iteration macro...
+;;;
+(defmacro iterate (name binds &body body)
+  "Iterate Name ({(Var Initial-Value)}*) Declaration* Form*
+  This is syntactic sugar for Labels.  It creates a local function Name with
+  the specified Vars as its arguments and the Declarations and Forms as its
+  body.  This function is then called with the Initial-Values, and the result
+  of the call is return from the macro."
+  (dolist (x binds)
+    (unless (and (listp x)
+		 (= (length x) 2))
+      (error "Malformed iterate variable spec: ~S." x)))
+  
+  `(labels ((,name ,(mapcar #'first binds) ,@body))
+     (,name ,@(mapcar #'second binds))))
+
+
+;;;; The Collect macro:
+
+;;; Collect-Normal-Expander  --  Internal
+;;;
+;;;    This function does the real work of macroexpansion for normal collection
+;;; macros.  N-Value is the name of the variable which holds the current
+;;; value.  Fun is the function which does collection.  Forms is the list of
+;;; forms whose values we are supposed to collect.
+;;;
+(defun collect-normal-expander (n-value fun forms)
+  `(progn
+    ,@(mapcar #'(lambda (form) `(setq ,n-value (,fun ,form ,n-value))) forms)
+    ,n-value))
+
+;;; Collect-List-Expander  --  Internal
+;;;
+;;;    This function deals with the list collection case.  N-Tail is the pointer
+;;; to the current tail of the list, which is NIL if the list is empty.
+;;;
+(defun collect-list-expander (n-value n-tail forms)
+  (let ((n-res (gensym)))
+    `(progn
+      ,@(mapcar #'(lambda (form)
+		    `(let ((,n-res (cons ,form nil)))
+		       (cond (,n-tail
+			      (setf (cdr ,n-tail) ,n-res)
+			      (setq ,n-tail ,n-res))
+			     (t
+			      (setq ,n-tail ,n-res  ,n-value ,n-res)))))
+		forms)
+      ,n-value)))
+
+
+;;; Collect  --  Public
+;;;
+;;;    The ultimate collection macro...
+;;;
+(defmacro collect (collections &body body)
+  "Collect ({(Name [Initial-Value] [Function])}*) {Form}*
+  Collect some values somehow.  Each of the collections specifies a bunch of
+  things which collected during the evaluation of the body of the form.  The
+  name of the collection is used to define a local macro, a la MACROLET.
+  Within the body, this macro will evaluate each of its arguments and collect
+  the result, returning the current value after the collection is done.  The
+  body is evaluated as a PROGN; to get the final values when you are done, just
+  call the collection macro with no arguments.
+
+  Initial-Value is the value that the collection starts out with, which
+  defaults to NIL.  Function is the function which does the collection.  It is
+  a function which will accept two arguments: the value to be collected and the
+  current collection.  The result of the function is made the new value for the
+  collection.  As a totally magical special-case, the Function may be Collect,
+  which tells us to build a list in forward order; this is the default.  If an
+  Initial-Value is supplied for Collect, the stuff will be rplacd'd onto the
+  end.  Note that Function may be anything that can appear in the functional
+  position, including macros and lambdas."
+
+  (let ((macros ())
+	(binds ()))
+    (dolist (spec collections)
+      (unless (<= 1 (length spec) 3)
+	(error "Malformed collection specifier: ~S." spec))
+      (let ((n-value (gensym))
+	    (name (first spec))
+	    (default (second spec))
+	    (kind (or (third spec) 'collect)))
+	(push `(,n-value ,default) binds)
+	(if (eq kind 'collect)
+	    (let ((n-tail (gensym)))
+	      (if default
+		  (push `(,n-tail (last ,n-value)) binds)
+		  (push n-tail binds))
+	      (push `(,name (&rest args)
+			    (collect-list-expander ',n-value ',n-tail args))
+		    macros))
+	    (push `(,name (&rest args)
+			  (collect-normal-expander ',n-value ',kind args))
+		  macros))))
+    `(macrolet ,macros (let* ,(nreverse binds) ,@body))))
+
+
+;;;; The Once-Only macro:
+
+;;; Once-Only  --  Interface
+;;;
+;;;    Once-Only is a utility useful in writing source transforms and macros.
+;;; It provides an easy way to wrap a let around some code to ensure that some
+;;; forms are only evaluated once.
+;;;
+(defmacro once-only (specs &body body)
+  "Once-Only ({(Var Value-Expression)}*) Form*
+  Create Let which evaluates each Value-Expression, binding a temporary
+  variable to the result, and wrapping the Let around the result of the
+  evaluation of Body.  Within the body, each Var is bound to the corresponding
+  temporary variable.  If the Value-Expression is a constant, then we just pass
+  it through."
+  (let ((n-binds (gensym))
+	(n-temp (gensym)))
+    (collect ((names)
+	      (temp-binds))
+      (dolist (spec specs)
+	(when (/= (length spec) 2)
+	  (error "Malformed Once-Only binding spec: ~S." spec))
+	(let ((name (first spec))
+	      (exp (second spec)))
+	  (names `(,name ,exp))
+	  (temp-binds
+	   `(let ((,n-temp (gensym)))
+	      (,n-binds `(,,n-temp ,,name))
+	      (setq ,name ,n-temp)))))
+      `(let ,(names)
+	 (collect ((,n-binds))
+	   ,@(temp-binds)
+	   (list 'let (,n-binds) (progn ,@body)))))))
+
+
+;;;; DO-ANONYMOUS:
+
+;;; ### Bootstrap hack...  Renamed to avoid clobbering function in bootstrap
+;;; environment.
+;;;
+(defun lisp::do-do-body (varlist endlist code decl bind step name block)
+  (let* ((inits ())
+	 (steps ())
+	 (l1 (gensym))
+	 (l2 (gensym)))
+    ;; Check for illegal old-style do.
+    (when (or (not (listp varlist)) (atom endlist))
+      (error "Ill-formed ~S -- possibly illegal old style DO?" name))
+    ;; Parse the varlist to get inits and steps.
+    (dolist (v varlist)
+      (cond ((symbolp v) (push v inits))
+	    ((listp v)
+	     (unless (symbolp (first v))
+	       (error "~S step variable is not a symbol: ~S" name (first v)))
+	     (case (length v)
+	       (1 (push (first v) inits))
+	       (2 (push v inits))
+	       (3 (push (list (first v) (second v)) inits)
+		  (setq steps (list* (third v) (first v) steps)))
+	       (t (error "~S is an illegal form for a ~S varlist." v name))))
+	    (t (error "~S is an illegal form for a ~S varlist." v name))))
+    ;; And finally construct the new form.
+    `(block ,BLOCK
+       (,bind ,(nreverse inits)
+	,@decl
+	(tagbody
+	 (go ,L2)
+	 ,L1
+	 ,@code
+	 (,step ,@(nreverse steps))
+  	 ,L2 
+	 (unless ,(car endlist) (go ,L1))
+	 (return-from ,BLOCK (progn ,@(cdr endlist))))))))
+
+
+(defmacro do-anonymous (varlist endlist &body (body decls))
+  "DO-ANONYMOUS ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form*
+  Like DO, but has no implicit NIL block.  Each Var is initialized in parallel
+  to the value of the specified Init form.  On subsequent iterations, the Vars
+  are assigned the value of the Step form (if any) in paralell.  The Test is
+  evaluated before each evaluation of the body Forms.  When the Test is true,
+  the the Exit-Forms are evaluated as a PROGN, with the result being the value
+  of the DO."
+  (lisp::do-do-body varlist endlist body decls 'let 'psetq
+		    'do-anonymous (gensym)))
diff --git a/code/fdefinition.lisp b/code/fdefinition.lisp
new file mode 100644
index 000000000..f7c0634af
--- /dev/null
+++ b/code/fdefinition.lisp
@@ -0,0 +1,68 @@
+;;; -*- Package: Lisp; Log: code.log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;;    Functions that hack on the global function namespace (primarily
+;;; concerned with SETF functions here.)
+;;;
+;;; Written by Rob MacLachlan
+;;;
+(in-package 'lisp)
+(export '(fdefinition fboundp fmakunbound))
+
+(defvar *setf-functions* (make-hash-table :test #'equal))
+
+(eval-when (compile eval)
+
+;;; With-Function-Name  --  Internal
+;;;
+(defmacro with-function-name (name symbol-form setf-form)
+  `(typecase ,name
+     (symbol ,symbol-form)
+     (cons
+      (unless (and (eq (car ,name) 'setf)
+		   (consp (cdr ,name))
+		   (symbolp (cadr ,name)))
+	(error "Malformed function name: ~S." ,name))
+      ,setf-form)
+     (t
+      (error "Malformed function name: ~S." ,name))))
+
+); Eval-When (Compile Eval)
+
+(defun fdefinition (name)
+  "Return Name's global function definition."
+  (with-function-name name
+    (careful-symbol-function name)
+    (or (gethash (cadr name) *setf-functions*)
+	(error "Undefined function: ~S." name))))
+
+(defsetf fdefinition %set-fdefinition)
+
+(defun %set-fdefinition (name new-value)
+  "Set Name's global function definition."
+  (declare (type function new-value))
+  (with-function-name name
+    (set-symbol-function-carefully name new-value)
+    (setf (gethash (cadr name) *setf-functions*) new-value)))
+
+#+new-compiler
+(defun fboundp (name)
+  "Return true if Name has a global function definition."
+  (with-function-name name
+    (functionp (%primitive fast-symbol-function name))
+    (functionp (gethash (cadr name) *setf-functions*))))
+
+#+new-compiler
+(defun fmakunbound (name)
+  "Make Name have no global function definition."
+  (with-function-name name
+    (%primitive set-symbol-function name
+		(%primitive make-immediate-type 0 %trap-type))
+    (remhash (cadr name) *setf-functions*))
+  t)
diff --git a/code/filesys.lisp b/code/filesys.lisp
new file mode 100644
index 000000000..c317b9613
--- /dev/null
+++ b/code/filesys.lisp
@@ -0,0 +1,1278 @@
+;;; -*- Log: code.log; Package: Lisp -*-
+;;; ### Some day fix to accept :wild in any pathname component.
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; Ugly pathname functions for Spice Lisp.
+;;;    these functions are part of the standard Spice Lisp environment.
+;;;
+;;; Written by Jim Large and Rob MacLachlan
+;;;
+;;; **********************************************************************
+(in-package 'lisp)
+(export '(pathname pathnamep *default-pathname-defaults* truename
+	  parse-namestring merge-pathnames make-pathname
+	  pathname-host pathname-device pathname-directory
+	  pathname-name pathname-type pathname-version
+	  namestring file-namestring directory-namestring
+	  host-namestring enough-namestring user-homedir-pathname
+          probe-file rename-file delete-file file-write-date
+	  file-author directory))
+
+(use-package "EXTENSIONS")
+
+(in-package "EXTENSIONS")
+(export '(print-directory complete-file ambiguous-files default-directory
+			  file-writable))
+(in-package 'lisp)
+
+
+;;; Pathname structure
+
+
+;;; *Default-Pathname-defaults* has all values unspecified except for the
+;;;  host.  All pathnames must have a host.
+(defvar *default-pathname-defaults* ()
+  "Set to the default pathname-defaults pathname (Got that?)")
+
+(defun filesys-init ()
+  (setq *default-pathname-defaults* 
+	(%make-pathname "Mach" nil nil nil nil nil)))
+
+
+;;; The pathname type is defined with a defstruct.
+;;; This declaration implicitly defines the common lisp function Pathnamep
+(defstruct (pathname
+	    (:conc-name %pathname-)
+	    (:print-function %print-pathname)
+	    (:constructor
+	     %make-pathname (host device directory name type version))
+	    (:predicate pathnamep))
+  "Pathname is the structure of the file pathname.  It consists of a
+   host, a device, a directory, a name, and a type."
+  (host nil :type (or simple-string null))
+  (device nil :type (or simple-string (member nil :absolute)))
+  (directory nil :type (or simple-vector null))
+  (name nil :type (or simple-string null))
+  (type nil :type (or simple-string null))
+  (version nil :type (or integer (member nil :newest))))
+
+(defun %print-pathname (s stream d)
+  (declare (ignore d))
+  (format stream "#.(pathname ~S)" (namestring s)))
+
+(defun make-pathname (&key defaults (host nil hostp) (device nil devicep)
+			   (directory nil directoryp) (name nil namep)
+			   (type nil typep) (version nil versionp))
+  "Create a pathname from :host, :device, :directory, :name, :type and :version.
+  If any field is ommitted, it is obtained from :defaults as though by 
+  merge-pathnames."
+  (if defaults
+      (let ((defaults (pathname defaults)))
+	(unless hostp
+	  (setq host (%pathname-host defaults)))
+	(unless devicep
+	  (setq device (%pathname-device defaults)))
+	(unless directoryp
+	  (setq directory (%pathname-directory defaults)))
+	(unless namep
+	  (setq name (%pathname-name defaults)))
+	(unless typep
+	  (setq type (%pathname-type defaults)))
+	(unless versionp
+	  (setq version (%pathname-version defaults))))
+      (unless hostp
+	(setq host (%pathname-host *default-pathname-defaults*))))
+
+  (when (stringp directory)
+    (setq directory (%pathname-directory (parse-namestring directory))))
+  (%make-pathname
+   (if (stringp host) (coerce host 'simple-string) host)
+   (if (stringp device) (coerce device 'simple-string) device)
+   directory
+   (if (stringp name) (coerce name 'simple-string) name)
+   (if (stringp type) (coerce type 'simple-string) type)
+   version))
+
+
+;;; These can not be done by the accessors because the pathname arg may be
+;;;  a string or a symbol or etc.
+
+(defun pathname-host (pathname)
+  "Returns the host slot of pathname.  Pathname may be a string, symbol,
+  or stream."
+  (%pathname-host (if (pathnamep pathname) pathname (pathname pathname))))
+
+(defun pathname-device (pathname)
+  "Returns the device slot of pathname.  Pathname may be a string, symbol,
+  or stream."
+  (%pathname-device (if (pathnamep pathname) pathname (pathname pathname))))
+
+(defun pathname-directory (pathname)
+  "Returns the directory slot of pathname.  Pathname may be a string,
+  symbol, or stream."
+  (%pathname-directory (if (pathnamep pathname) pathname (pathname pathname))))
+
+(defun pathname-name (pathname)
+  "Returns the name slot of pathname.  Pathname may be a string,
+  symbol, or stream."
+  (%pathname-name (if (pathnamep pathname) pathname (pathname pathname))))
+
+(defun pathname-type (pathname)
+  "Returns the type slot of pathname.  Pathname may be a string,
+  symbol, or stream."
+  (%pathname-type (if (pathnamep pathname) pathname (pathname pathname))))
+
+(defun pathname-version (pathname)
+  "Returns the version slot of pathname.  Pathname may be a string,
+  symbol, or stream."
+  (%pathname-version (if (pathnamep pathname) pathname (pathname pathname))))
+
+
+
+;;;; FSM Compiler
+
+(eval-when (compile eval)
+;;; These macros are used in the code emitted by deflex.  They refer
+;;; to local vars in the defined function.
+
+(defmacro fsm-scan ()
+  '(progn
+    (incf pointer)
+    (setq current-char (if (>= pointer end)
+			   :end
+			   (char string pointer)))))
+
+;;; fsm-emit expands into a form which pushes FLAG onto *deflex-tokens* and
+;;;  then pushes a string containing the ACCUMULATED characters
+(defmacro fsm-emit (flag)
+  `(progn
+    (vector-push-extend ,flag *deflex-tokens*)
+    (vector-push-extend (subseq buffer 0 buffer-index) *deflex-tokens*)
+    (setq buffer-index 0)))
+
+;;; fsm-dotfix expands into a form which replaces the last EMITTED flag with
+;;;  FLAG, and the last EMITTED token with its self + "." + the ACCUMULATED
+;;;  characters.
+(defmacro fsm-dotfix (flag)
+  `(let ((prev-token (vector-pop *deflex-tokens*)))
+     (setf (aref *deflex-tokens* (1- (fill-pointer *deflex-tokens*))) ,flag)
+     (vector-push (concatenate 'simple-string
+			       prev-token
+			       "."
+			       (subseq buffer 0 buffer-index))
+		  *deflex-tokens*)
+     (setq buffer-index 0)))
+
+
+(defun deflex-arc (arc)
+  (do ((set (nth 0 arc))
+       (new-state (nth 2 arc))
+       (actions (nth 3 arc) (if (member (car actions) '(EMIT DOTFIX))
+				(cddr actions)
+				(cdr actions)))
+       (action-forms
+	()
+	(cons (case (car actions)
+		(ACCUMULATE '(progn 
+			      (setf (schar buffer buffer-index) current-char)
+			      (incf buffer-index)))
+		(SCAN '(fsm-scan))
+		(EMIT `(fsm-emit ,(nth 1 actions)))
+		(DOTFIX `(fsm-dotfix ,(nth 1 actions)))
+		(t (error "Illegal action ~s" (car actions))))
+	      action-forms)))
+      ((null actions)
+       `(when ,(cond ((eq set ':end) `(eq current-char ,set))
+		     ((eq set T) T)
+		     (t
+		      `(and (not (eq current-char :end))
+			    ,(if (characterp set)
+				 `(char= current-char ,set)
+				 `(find current-char
+					(the simple-string ,set))))))
+	  ,@(nreverse action-forms)
+	  (go ,new-state)))))
+
+
+(defun deflex-state (state)
+  (do ((state-name (car state))
+       (arc-list (cdr state) (cdr arc-list))
+       (form-list () (cons (deflex-arc (car arc-list)) form-list)))
+      ((null arc-list)
+       `(,state-name
+	 ,@(nreverse form-list)
+	 (go JAM)))))
+
+(defmacro deflex (name &rest states)
+  (do ((states states (cdr states))
+       (body-forms () (append body-forms (deflex-state (car states)))))
+      ((null states)
+       `(defun ,(concat-pnames 'lex- name)
+	       (string &optional (start 0) (end (length string)))
+	  (declare (simple-string string)
+		   (fixnum start end))
+	  (setf (fill-pointer *deflex-tokens*) 0)
+	  (prog ((current-char (if (> end start)
+				   (char string start) :end))
+		 (pointer start)
+		 (buffer *deflex-buffer*)
+		 (buffer-index 0))
+	    (declare (simple-string buffer))
+	    ,@body-forms
+	    
+	    WIN (return (values T pointer))
+	    JAM (return (values NIL pointer)))))))
+
+); eval-when (compile eval)
+
+
+(defvar *deflex-buffer* (make-string 100))
+(defvar *deflex-tokens* (make-array 20 :adjustable t :fill-pointer 0))
+
+
+
+;;;; FSM for lexing pathnames.
+
+(defconstant ses-name-char
+  "#@$-+*%0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz~")
+
+(defconstant fs-whitespace ;whitespace in filenames
+  " 	
+")
+
+;;; Lex-ses-file-spec separates a sesame file name into its components
+;;;
+;;;  STRING -- the string containing the file spec.
+;;; &optional
+;;;  START  -- the first character to look at (defaults to 0)
+;;;  END    -- 1+ the last character to look at (defaluts to (length STRING))
+;;;
+;;; Returns multiple values.
+;;;  1st -- () for failure or a list of tokens.
+;;;  2nd -- the index of the character that stopped the parse
+;;;
+;;;    Tokens are represented by a keyword and a string in *deflex-tokens*.
+;;; The first token is of type :logical-name (string is log name) or :absolute.
+;;; Subsequent tokens are of type :directory-name, :file-name, :extension, or
+;;; the string being a pathname component.
+;;;
+(deflex ses-file-spec
+  ;;S1 waits for the first non whitespace character
+  (S1 (fs-whitespace --> S1 (SCAN))
+      (#\- --> JAM)			;- illegal as start of file name
+      (#\/ --> S3 (EMIT :absolute SCAN));/ starts an absolute pathname
+      (#\\ --> S2a (ACCUMULATE SCAN))   ;\ quotes char in name or logname
+      (#\. --> S5 (EMIT :file-name SCAN))     ;. maybe ends file name
+      (ses-name-char --> S2 (ACCUMULATE SCAN))  ;first char in a name or logname
+      (:end --> WIN)			; Null filename is legal.
+      )
+
+  ;;S2 accumulates chars in a file name, logical name, or directory name.
+  (S2 (#\: --> S3 (EMIT :logical-name SCAN))  ;: ends log-name, starts next name
+      (#\/ --> S3 (EMIT :directory-name SCAN));/ ends directory name,starts next
+      (#\\ --> S2a (ACCUMULATE SCAN))         ;\ quotes char in name
+      (#\. --> S5 (EMIT :file-name SCAN))     ;. maybe ends file name
+      (:end --> WIN (EMIT :file-name))
+      (ses-name-char --> S2 (ACCUMULATE SCAN))
+      (fs-whitespace --> S9 (EMIT :file-name SCAN))
+      (T --> JAM (EMIT :file-name))
+      )
+
+  ;;S2a waits for any char following a \ found in S2
+  (S2a (:END --> JAM)
+       (T --> S2 (ACCUMULATE SCAN)))
+
+  ;;S3 accumulates chars in a file name or directory name
+  (S3 (#\/ --> JAM)
+      (T --> S3b))
+  (S3b (#\/ --> S3 (EMIT :directory-name SCAN));/ ends directory name,starts next
+       (#\. --> S4 (EMIT :file-name SCAN))     ;. maybe ends file name
+       (#\\ --> S3a (ACCUMULATE SCAN))         ;\ quotes char in name
+       (:end --> WIN (EMIT :file-name))
+       (ses-name-char --> S3b (ACCUMULATE SCAN))
+       (fs-whitespace --> S9 (EMIT :file-name SCAN))
+       (T --> JAM (EMIT :file-name))
+       )
+
+  ;;S3a waits for any char following a \ found in S3
+  (S3a (:end --> JAM)
+       (T --> S3b (ACCUMULATE SCAN)))
+
+  ;;S4 waits for chars in a name following a dot.  If it encounters the end of
+  ;; the pathname, then the chars are the extension.  Otherwise, the chars are
+  ;; really part of the last token, so we mash them back on with dotfix.
+  (S4 (#\/ --> S3 (DOTFIX :directory-name SCAN))
+      (#\\ --> S4a (ACCUMULATE SCAN))
+      (#\. --> S4 (DOTFIX :file-name SCAN))
+      (:end --> WIN (EMIT :extension))
+      (fs-whitespace --> S9 (EMIT :extension SCAN))
+      (ses-name-char --> S4 (ACCUMULATE SCAN))
+      (T --> JAM (EMIT :extension))
+      )
+
+  ;;S4a waits for any char following a \ found in S4
+  (S4a (:end --> JAM)
+       (T --> S4 (ACCUMULATE SCAN)))
+
+  ;;S5 is the same as S4 but name may also be logical name
+  (S5 (#\/ --> S3 (DOTFIX :directory-name SCAN))
+      (#\: --> S3 (DOTFIX :logical-name SCAN))
+      (#\\ --> S5a (ACCUMULATE SCAN))
+      (#\. --> S5 (DOTFIX :file-name SCAN))
+      (:end --> WIN (EMIT :extension))
+      (fs-whitespace --> S9 (EMIT :extension SCAN))
+      (ses-name-char --> S5 (ACCUMULATE SCAN))
+      (T --> JAM (EMIT :extension))
+      )
+
+  ;;S5a waits for any char following a \ found in S5
+  (S5a (:end --> JAM)
+       (T --> S5 (ACCUMULATE SCAN)))
+
+  ;;S9 eats trailing whitespace.
+  (S9 (fs-whitespace --> S9 (SCAN))
+      (:end --> WIN)
+      (t --> JAM))
+  )
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; ses-tokens->pathname converts the contents of *deflex-tokens* into a pathname
+;;; 
+(defun ses-tokens->pathname ()
+  (do ((end (fill-pointer *deflex-tokens*))
+       (result (make-pathname))
+       (dirlist ())
+       (token-val ())
+       (ix 0 (+ ix 2))
+       (default t))
+      ((>= ix end)
+       (setf (%pathname-directory result)
+	     (cond (dirlist
+		    (when default (setf (%pathname-device result) "Default"))
+		    (coerce (the list (nreverse dirlist)) 'simple-vector))
+		   (default nil)
+		   (t '#())))
+       result)
+    (declare (list dirlist)
+	     (fixnum ix end))
+    (setq token-val (aref *deflex-tokens* (1+ ix)))
+    (case (aref *deflex-tokens* ix)
+      (:ABSOLUTE
+       (setf (%pathname-device result) :ABSOLUTE)
+       (setq default nil))
+      (:LOGICAL-NAME
+       (setf (%pathname-device result) token-val)
+       (setq default nil))
+      (:DIRECTORY-NAME (push token-val dirlist))
+      (:FILE-NAME
+       (unless (zerop (length (the simple-string token-val)))
+	 (setf (%pathname-name result) token-val)))
+      (:EXTENSION (setf (%pathname-type result) token-val)))))
+
+
+
+;;;; PARSE-NAMESTRING and PATHNAME.
+
+(defun parse-namestring (thing &optional host 
+			       (defaults *default-pathname-defaults*)
+			       &key (start 0) end (junk-allowed nil))
+  "Parses a string representation of a pathname into a pathname."
+  (declare (ignore host defaults))
+  (let* ((thing (typecase thing
+		  (string (coerce thing 'simple-string))
+		  (pathname (return-from parse-namestring (values thing start)))
+		  (stream (file-name thing))
+		  (symbol (symbol-name thing))
+		  (t (error "This thing is a bad thing for parse-namestring: ~S"
+			    thing))))
+	 (end (or end (length thing))))
+    (declare (simple-string thing))
+    (multiple-value-bind (won next-field)
+			 (lex-ses-file-spec thing start end)
+      (unless (or won junk-allowed)
+	(error "There's junk in this thing that you gave to parse-namestring:~%~
+		~4T\"~A\"~%~0,1,V,'.@A" thing (+ next-field 5) #\^))
+      (values (ses-tokens->pathname) next-field))))
+
+(defun pathname (thing)
+  "Turns thing into a pathname.  Thing may be a string, symbol, stream, or
+   pathname."
+  (values (parse-namestring thing)))
+
+
+
+;;; Merge-Pathnames  --  Public
+;;;
+;;; Returns a new pathname whose fields are the same as the fields in PATHNAME
+;;;  except that () fields are filled in from defaults.  Type and Version field
+;;;  are only done if name field has to be done (see manual for explanation).
+;;;
+(defun merge-pathnames (pathname &optional
+				 (defaults *default-pathname-defaults*)
+				 default-version)
+  "Fills in unspecified slots of Pathname from Defaults (defaults to
+  *default-pathname-defaults*).  If the version remains unspecified,
+  gets it from Default-Version."
+  ;;
+  ;; finish hairy argument defaulting
+  (setq pathname (pathname pathname))
+  (setq defaults (pathname defaults))
+  ;;
+  ;; make a new pathname
+  (let ((name (%pathname-name pathname))
+	(device (%pathname-device pathname)))
+    (%make-pathname
+     (or (%pathname-host pathname) (%pathname-host defaults))
+     (or device (%pathname-device defaults))
+     (or (%pathname-directory pathname) (%pathname-directory defaults))
+     (or name (%pathname-name defaults))
+     (or (%pathname-type pathname) (%pathname-type defaults))
+     (or (%pathname-version pathname)
+	 (if name
+	     default-version
+	     (or (%pathname-version defaults) default-version))))))
+
+
+;;;; NAMESTRING and other stringification stuff.
+
+;;; %Dirstring  --  Internal
+;;;
+;;; %Dirstring converts a vector of the form #("foo" "bar" ... "baz") into a
+;;;  string of the form "foo/bar/ ... /baz/"
+
+(defun %dirstring (dirlist)
+  (declare (simple-vector dirlist))
+  (let* ((numdirs (length dirlist))
+	 (length numdirs))
+    (declare (fixnum numdirs length))
+    (dotimes (i numdirs)
+      (incf length (the fixnum (length (svref dirlist i)))))
+    (do ((result (make-string length))
+	 (index 0 (1+ index))
+	 (position 0))
+	((= index numdirs) result)
+      (declare (simple-string result))
+      (let* ((string (svref dirlist index))
+	     (len (length string))
+	     (end (+ position len)))
+	(declare (simple-string string)
+		 (fixnum len end))
+	(replace result string :start1 position  :end1 end  :end2 len)
+	(setf (schar result end) #\/)
+	(setq position (+ end 1))))))
+
+(defun quick-integer-to-string (n)
+  (cond ((zerop n) "0")
+	((eql n 1) "1")
+	((minusp n)
+	 (concatenate 'simple-string "-"
+		      (the simple-string (quick-integer-to-string (- n)))))
+	(t
+	 (do* ((len (1+ (truncate (integer-length n) 3)))
+	       (res (make-string len))
+	       (i (1- len) (1- i))
+	       (q n)
+	       (r 0))
+	      ((zerop q)
+	       (incf i)
+	       (replace res res :start2 i :end2 len)
+	       (%primitive shrink-vector res (- len i)))
+	   (declare (simple-string res)
+		    (fixnum len i r))
+	   (multiple-value-setq (q r) (truncate q 10))
+	   (setf (schar res i) (schar "0123456789" r))))))
+	   
+(defun %device-string (device)
+  (cond ((eq device :absolute) "/")
+	(device
+	 (if (string-equal device "Default")
+	     ""
+	     (concatenate 'simple-string (the simple-string device) ":")))
+	(T "")))
+
+(defun namestring (pathname)
+  "Returns the full form of PATHNAME as a string."
+  (setq pathname (pathname pathname))
+  (let* ((directory (%pathname-directory pathname))
+	 (name (%pathname-name pathname))
+	 (type (%pathname-type pathname))
+	 (result (%device-string (%pathname-device pathname))))
+    (declare (simple-string result))
+    (when directory
+      (setq result (concatenate 'simple-string result
+				(the simple-string (%dirstring directory)))))
+    (when name
+      (setq result (concatenate 'simple-string result 
+				(the simple-string name))))
+    (when type
+      (setq result (concatenate 'simple-string result "."
+				(the simple-string type))))
+    result))
+
+(defun %ses-get-useful-name (pathname)
+  "NAMESTRING of pathname ignoring the device slot."
+  (setq pathname (pathname pathname))
+  (let* ((directory (%pathname-directory pathname))
+	 (name (%pathname-name pathname))
+	 (type (%pathname-type pathname))
+	 (result ""))
+    (declare (simple-string result))
+    (when directory
+      (setq result (concatenate 'simple-string result
+				(the simple-string (%dirstring directory)))))
+    (when name
+      (setq result (concatenate 'simple-string result 
+				(the simple-string name))))
+    (when type
+      (setq result (concatenate 'simple-string result "."
+				(the simple-string type))))
+    result))
+
+;;; This function is somewhat bummed to make the Hemlock directory command
+;;; is fast.
+;;;
+(defun file-namestring (pathname)
+  "Returns the name, type, and version of PATHNAME as a string."
+  (unless (pathnamep pathname) (setq pathname (pathname pathname)))
+  (let* ((name (%pathname-name pathname))
+	 (type (%pathname-type pathname))
+	 (result (or name "")))
+    (declare (simple-string result))
+    (if type
+	(concatenate 'simple-string result "." type)
+	result)))
+
+(defun directory-namestring (pathname)
+  "Returns the device & directory parts of PATHNAME as a string."
+  (setq pathname (pathname pathname))
+  (let* ((directory (%pathname-directory pathname))
+ 	 (result (%device-string (%pathname-device pathname))))
+    (declare (simple-string result))
+    (when directory
+      (setq result (concatenate 'simple-string result
+				(the simple-string (%dirstring directory)))))
+    result))
+
+(defun host-namestring (pathname)
+  "Returns the host part of PATHNAME as a string."
+  (setq pathname (pathname pathname))
+  (%pathname-host pathname))
+
+
+
+;;;; ENOUGH-NAMESTRING
+
+(defun enough-namestring (pathname &optional
+				   (defaults *default-pathname-defaults*))
+  "Returns a string which uniquely identifies PATHNAME w.r.t. DEFAULTS." 
+  (setq pathname (pathname pathname))
+  (setq defaults (pathname defaults))
+  (let* ((device (%pathname-device pathname))
+	 (directory (%pathname-directory pathname))
+	 (name (%pathname-name pathname))
+	 (type (%pathname-type pathname))
+	 (result "")
+	 (need-name nil))
+    (declare (simple-string result))
+    (when (and device (string-not-equal device (%pathname-device defaults)))
+      (setq result (%device-string device)))
+    (when (and directory
+	       (not (equalp directory (%pathname-directory defaults))))
+      (setq result (concatenate 'simple-string result
+				(the simple-string (%dirstring directory)))))
+    (when (and name (string-not-equal name (%pathname-name defaults)))
+      (setq result (concatenate 'simple-string result 
+				(the simple-string name))
+	    need-name t))
+    (when (and type (or need-name
+			(string-not-equal type (%pathname-type defaults))))
+      (setq result (concatenate 'simple-string result "."
+				(the simple-string type))))
+    result))
+
+
+
+;;;; TRUENAME and other stuff probing stuff.
+
+;;; Truename  --  Public
+;;;
+;;;    Another silly file function trivially different from another function.
+;;;
+(defun truename (pathname)
+  "Return the pathname for the actual file described by the pathname
+  An error is signalled if no such file exists."
+  (let ((result (probe-file pathname)))
+    (unless result
+      (error "The file ~S does not exist." (namestring pathname)))
+    result))
+
+;;; Do-Search-List  --  Internal
+;;;
+;;;    Bind var in turn to each element of search list with the specifed
+;;; name.
+;;;
+(defmacro do-search-list ((var name &optional exit-form) . body)
+  "Do-Search-List (Var Name [Exit-Form]) {Form}*"
+  `(dolist (,var (resolve-search-list ,name nil) ,exit-form)
+     (declare (simple-string ,var))
+     ,@body))
+
+
+;;; Sub-Probe-File  --  Internal
+;;;
+;;;    Does the work of Probe-File, returning an additional value which
+;;; indicates whether the name is really a file.
+;;;
+(defun sub-probe-file (pathname)
+  (setq pathname (pathname pathname))
+  (flet ((pathnamify (ns etype)
+	   (declare (simple-string ns))
+	   (case etype
+	     (:entry_remote
+	      (values (parse-namestring (concatenate 'simple-string ns "/"))
+		      :entry_directory))
+	     (t
+	      (values (parse-namestring ns) etype)))))
+    (let ((log-name (or (%pathname-device pathname) "default")))
+      (if (eq log-name :absolute)
+	  (let ((namestring (namestring pathname)))
+	    (multiple-value-bind (name etype)
+				 (mach:unix-subtestname namestring)
+	      (if (null name) NIL
+		  (pathnamify name etype))))
+	  (if (null (%pathname-device pathname))
+	      (multiple-value-bind (name etype)
+				   (mach:unix-subtestname
+				    (%ses-get-useful-name pathname))
+		(if (null name) NIL (pathnamify name etype)))
+	      (let ((namestring (%ses-get-useful-name pathname)))
+		(do-search-list (entry log-name)
+		  (let ((str (concatenate 'simple-string entry namestring)))
+		    (declare (simple-string str))
+		    (multiple-value-bind (name etype)
+					 (mach:unix-subtestname str)
+		      (when name
+			(return (pathnamify name etype))))))))))))
+
+
+;;; Probe-File  --  Public
+;;;
+;;;    Just call Sub-Probe-File and return nil when it isn't a file.
+;;;
+(defun probe-file (pathname)
+  "Return a pathname which is the truename of the file if it exists, NIL
+  otherwise.  Returns NIL for directories and other non-file entries."
+  (multiple-value-bind (pn f)
+		       (sub-probe-file pathname)
+    (if (eq f :entry_file) pn)))
+
+
+
+;;; Predict-Name  --  Internal
+;;;
+;;;    Predict-Name is a function used by Open to get an absolute pathname 
+;;; for a file being opened.  Returns the truename of the file and
+;;; whether it really exists or not.
+;;;
+(defun predict-name (file-name for-input)
+  (let* ((pathname (pathname file-name))
+	 (device (%pathname-device pathname))
+	 (truename (probe-file pathname)))
+    (cond ((eq device :absolute)
+	   (if truename
+	       (values (namestring truename) t)
+	       ;; Try again in case file-name is a directory.
+	       (predict-name-with-subtest (namestring pathname))))
+	  ((and for-input truename)
+	   (values (namestring truename) t))
+	  (t
+	   (let ((expansion (resolve-search-list (or device "default") t)))
+	     (let ((name (concatenate 'simple-string (car expansion)
+				      (%ses-get-useful-name pathname))))
+	       (declare (simple-string name))
+	       (predict-name-with-subtest name)))))))
+
+(defun predict-name-with-subtest (name)
+  (let ((gr (mach:unix-subtestname name)))
+    (if gr
+	(values gr t)
+	(values (mach::simplify-file-name name) nil))))
+
+
+
+;;; Rename-File  --  Public
+;;;
+;;;    If File is a File-Stream, then rename the associated file if it exists,
+;;; otherwise just change the name in the stream.  If not a file stream, then
+;;; just rename the file.
+;;;
+(defun rename-file (file new-name)
+  "Rename File to have the specified New-Name.  If file is a stream open to a
+  file, then the associated file is renamed.  If the file does not yet exist
+  then the file is created with the New-Name when the stream is closed."
+  (if (streamp file)
+      (let* ((name (file-name file))
+	     (pn (parse-namestring name))
+	     (npn (merge-pathnames new-name pn))
+	     (new (predict-name npn nil)))
+	(when (mach:quick-subtestname name)
+	  (multiple-value-bind (res err) (mach:Unix-rename name new)
+	    (if (null res) (error "Failed to rename ~A to ~A, unix error: ~A."
+				  name new (mach:get-unix-error-msg err)))))
+	(file-name file new)
+	(values npn pn (parse-namestring new)))
+      (let* ((pn (or (sub-probe-file file)
+		     (error "File to rename does not exist: ~S" file)))
+	     (npn (merge-pathnames new-name pn))
+	     (new (predict-name npn nil)))
+	(multiple-value-bind (res err) (mach:unix-rename (namestring pn) new)
+	  (if res (values npn pn (parse-namestring new))
+	      (error "Failed to rename ~A to ~A, unix error: ~A."
+		     (namestring pn) new (mach:get-unix-error-msg err)))))))
+
+;;; Delete-File  --  Public
+;;;
+;;;    Delete the file, Man.
+;;;
+(defun delete-file (file)
+  "Delete the specified file."
+  (let ((tn (sub-probe-file file)))
+    (when (streamp file)
+      (close file :abort t))
+    (if tn
+	(let ((ns (namestring tn)))
+	  (multiple-value-bind (res err) (mach:unix-unlink ns)
+	    (if (null res)
+		(error "Failed to delete ~A, unix error: ~A."
+		       ns (mach:get-unix-error-msg err)))))
+	(unless (streamp file)
+	  (error "File to be deleted does not exist: ~S" file)))) 
+  t)
+
+;;; User-Homedir-Pathname  --  Public
+;;;
+;;;    If the user wants a meaningful homedir, she has to define Home:.
+;;; Someday, login may do this for us.  Since we must always return something,
+;;; we just return Default: if it isn't defined.
+;;;
+(defun user-homedir-pathname (&optional host)
+  "Returns the home directory of the logged in user as a pathname.
+  This is obtained from the logical name \"home:\".  If this is not defined,
+  then we return \"default:\""
+  (declare (ignore host))
+  (let ((home (cdr (assoc :home *environment-list* :test #'eq))))
+    (if home
+	(pathname (if (string-equal home "/") "/"
+		      (concatenate 'simple-string home "/")))
+	(let ((expansion (if (search-list "home:")
+			     (resolve-search-list "home" t))))
+	  (if expansion
+	      (car expansion)
+	      (make-pathname :device "default"))))))
+
+;;; File-Write-Date  --  Public
+;;;
+(defun file-write-date (file)
+  "Return file's creation date, or NIL if it doesn't exist."
+  (let ((tn (sub-probe-file file)))
+    (when tn
+      (multiple-value-bind (res dev ino mode nlink uid gid
+				rdev size atime mtime)
+			   (mach:unix-stat (namestring tn))
+	(declare (ignore dev ino mode nlink uid gid rdev size atime))
+	(if (null res) 0
+	    (+ unix-to-universal-time mtime))))))
+
+;;; File-Author  --  Public
+;;;
+(defun file-author (file)
+  "Returns the file author as a string, or nil if the author cannot be
+   determined.  Signals an error if file doesn't exist."
+  (let ((filename (truename file)))
+    (multiple-value-bind (winp dev ino mode nlink uid)
+			 (mach:unix-stat (namestring filename))
+      (declare (ignore dev ino mode nlink))
+      (if winp (lookup-login-name uid)))))
+
+
+
+;;;; DIRECTORY.
+
+;;; DO-DIRECTORY searches a directory, binding the vars to the name and entry
+;;; type.  Pattern and All are used in MACH:UNIX-SEARCH-DIRECTORY.
+;;;
+(defmacro do-directory ((name-var etype-var pattern &optional (all t) result)
+			. body)
+  "Do-Directory (Name Entry-Type Pattern [All] [Result]) {Form}*.
+   If All is non-nil (the default), then Unix dot files to be processed.
+   Unix dot and dot-dot are never processed."
+  (let ((file (gensym))
+	(res (gensym))
+	(type (gensym))
+	(p (gensym)))
+    `(dolist (,file (mach:unix-search-directory ,pattern ,all)
+		    ,result)
+       (declare (simple-string ,file))
+       (let* ((,p (position #\/ ,file :from-end t))
+	      (,name-var
+	       (if ,p
+		   (subseq ,file (the fixnum (1+ (the fixnum ,p))))
+		   ,file)))
+	 (declare (simple-string ,name-var))
+	 (unless (or (string= "." ,name-var) (string= ".." ,name-var))
+	   (let ((,etype-var (multiple-value-bind (,res ,type)
+						  (mach:quick-subtestname ,file)
+			       (declare (ignore ,res))
+			       ,type)))
+	     ,@body))))))
+
+(defun directory (pathname &key (all t))
+  "Returns a list of pathnames, one for each file that matches the given
+   pathname.  Supplying :all as nil causes this to ignore Unix dot files.  This
+   never includes Unix dot and dot-dot in the result."
+  (setq pathname (pathname pathname))
+  (multiple-value-bind (dir pattern) (find-directory pathname)
+    (let ((res ()))
+      (do-directory (name etype pattern all)
+	(if (eq etype :entry_file)
+	    (let ((last-dot (position #\. name :from-end t)))
+	      (push
+	       (%make-pathname
+		"Mach" :absolute dir
+		(if last-dot (subseq name 0 last-dot) name)
+		(if last-dot (subseq name (1+ last-dot)))
+		nil)
+	       res))
+	    (push
+	     (%make-pathname
+	      "Mach" :absolute
+	      (concatenate 'simple-vector dir (vector name))
+	      nil nil nil)
+	     res)))
+      (nreverse res))))
+
+;;; FIND-DIRECTORY returns an absolute directory vector for pathname as a
+;;; first argument and an absolute namestring.  The namestring includes a
+;;; trailing asterisk, wildcard, when the given pathname is immediately
+;;; probe-able as a directory.
+;;;
+(defun find-directory (pathname)
+  (multiple-value-bind (pn type)
+		       (sub-probe-file pathname)
+    (if pn
+	(let ((ns (namestring pn)))
+	  (declare (simple-string ns))
+	  (case type
+	    (:entry_directory
+	     (when (char/= (schar ns (the fixnum (1- (length ns)))) #\/)
+	       (setq ns (concatenate 'simple-string ns "/")))
+	     (values (%pathname-directory (pathname ns))
+		     (concatenate 'simple-string ns "*")))
+	    (t (values (%pathname-directory pn) ns))))
+	(multiple-value-bind (pn type)
+			     (sub-probe-file
+			      (make-pathname
+			       :directory (%pathname-directory pathname)
+			       :device (%pathname-device pathname)))
+	  (unless pn
+	    (error "Directory does not exist: ~S" pathname))
+	  (let ((ns (namestring pn)))
+	    (case type
+	      (:entry_directory
+	       (values
+		(%pathname-directory pn)
+		(concatenate 'simple-string ns (file-namestring pathname))))
+	      (t
+	       (error "~S is not a directory." pathname))))))))
+
+
+
+;;;; Printing directories and determining file owner names.
+
+;;; PRINT-DIRECTORY is exported from the EXTENSIONS package.
+;;; 
+(defun print-directory (pathname &optional stream &key all verbose return-list)
+  "Like Directory, but prints a terse, multi-coloumn directory listing
+   instead of returning a list of pathnames.  When :all is supplied and
+   non-nil, then Unix dot files are included too (as ls -a).  When :vervose
+   is supplied and non-nil, then a long listing of miscellaneous
+   information is output one file per line."
+  (setf pathname (pathname pathname))
+  (let ((*standard-output* (out-synonym-of stream)))
+    (if verbose
+	(print-directory-verbose pathname all return-list)
+	(print-directory-formatted pathname all return-list))))
+
+(defun print-directory-verbose (pathname all return-list)
+  (multiple-value-bind (dir pattern) (find-directory pathname)
+    (declare (ignore dir))
+    (format t "Directory of ~A :~%" pattern)
+    (let ((dir-name (directory-namestring pattern))
+	  (result ()))
+      (do-directory (name etype pattern all (nreverse result))
+	(let ((slash-name (if (eq etype :entry_file)
+			      name
+			      (concatenate 'simple-string name "/"))))
+	  (declare (simple-string slash-name))
+	  (when return-list
+	    (push (pathname (concatenate 'simple-string dir-name slash-name))
+		  result))
+	  (multiple-value-bind 
+	      (reslt dev-or-err ino mode nlink uid gid rdev size atime mtime)
+	      (mach:unix-stat (concatenate 'simple-string dir-name name))
+	    (declare (ignore ino gid rdev atime)
+		     (fixnum uid mode))
+	    (cond (reslt
+		   ;;
+		   ;; Print characters for file modes.
+		   (macrolet ((frob (bit name &optional sbit sname negate)
+				`(if ,(if negate
+					  `(not (logbitp ,bit mode))
+					  `(logbitp ,bit mode))
+				     ,(if sbit
+					  `(if (logbitp ,sbit mode)
+					       (write-char ,sname)
+					       (write-char ,name))
+					  `(write-char ,name))
+				     (write-char #\-))))
+		     (frob 15 #\d nil nil t)
+		     (frob 8 #\r)
+		     (frob 7 #\w)
+		     (frob 6 #\x 11 #\s)
+		     (frob 5 #\r)
+		     (frob 4 #\w)
+		     (frob 3 #\x 10 #\s)
+		     (frob 2 #\r)
+		     (frob 1 #\w)
+		     (frob 0 #\x))
+		   ;;
+		   ;; Print the rest.
+		   (multiple-value-bind (sec min hour date month year)
+					(get-decoded-time)
+		     (declare (ignore sec min hour date month))
+		     (format t "~2D ~8A ~8D ~12A ~A~%"
+			     nlink
+			     (or (lookup-login-name uid) uid)
+			     size
+			     (decode-universal-time-for-files mtime year)
+			     slash-name)))
+		  (t (format t "Couldn't stat ~A -- ~A.~%"
+			     slash-name
+			     (mach:get-unix-error-msg dev-or-err))))))))))
+
+(defun decode-universal-time-for-files (time current-year)
+  (multiple-value-bind (sec min hour day month year)
+		       (decode-universal-time (+ time unix-to-universal-time))
+    (declare (ignore sec))
+    (format nil "~A ~2,' D ~:[ ~D~;~*~2,'0D:~2,'0D~]"
+	    (svref '#("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug"
+		      "Sep" "Oct" "Nov" "Dec")
+		   (1- month))
+	    day (= current-year year) year hour min)))
+
+(defun print-directory-formatted (pathname all return-list)
+  (let ((width (or (line-length *standard-output*) 80))
+	(names ())
+	(cnt 0)
+	(max-len 0)
+	(result ()))
+    (declare (list names) (fixnum max-len cnt))
+    ;;
+    ;; Get the data.
+    (multiple-value-bind (dir pattern) (find-directory pathname)
+      (declare (ignore dir))
+      (do-directory (name etype pattern all)
+	(let* ((slash-name (if (eql etype :entry_file)
+			       name
+			       (concatenate 'simple-string name "/")))
+	       (len (length slash-name)))
+	  (declare (simple-string slash-name)
+		   (fixnum len))
+	  (when return-list
+	    (push (pathname (concatenate 'simple-string
+					 (directory-namestring pattern)
+					 slash-name))
+		  result))
+	  
+	  (if (> len max-len) (setq max-len len))
+	  (incf cnt)
+	  (push slash-name names)))
+      (setq names (nreverse names))
+      ;;
+      ;; Do the output.
+      (let* ((col-width (1+ max-len))
+	     (cols (max (truncate width col-width) 1))
+	     (lines (ceiling cnt cols)))
+	(declare (fixnum cols lines))
+	(format t "Directory of ~A :~%" pattern)
+	(dotimes (i lines)
+	  (declare (fixnum i))
+	  (dotimes (j cols)
+	    (declare (fixnum j))
+	    (let ((name (nth (+ i (the fixnum (* j lines))) names)))
+	      (when name
+		(write-string name)
+		(unless (eql j (1- cols))
+		  (tab-over 
+		   (- col-width (length (the simple-string name))))))))
+	  (terpri))))
+    (when return-list (nreverse result))))
+
+
+
+;;;; Translating uid's and gid's.
+
+(defvar *uid-hash-table* (make-hash-table)
+  "Hash table for keeping track of uid's and login names.")
+
+;;; LOOKUP-LOGIN-NAME translates a user id into a login name.  Previous
+;;; lookups are cached in a hash table since groveling the passwd(s) files
+;;; is somewhat expensive.  The table may hold nil for id's that cannot
+;;; be looked up since this means the files are searched in their entirety
+;;; each time this id is translated.
+;;; 
+(defun lookup-login-name (uid)
+  (multiple-value-bind (login-name foundp) (gethash uid *uid-hash-table*)
+    (if foundp
+	login-name
+	(setf (gethash uid *uid-hash-table*)
+	      (get-group-or-user-name :user uid)))))
+
+(defvar *gid-hash-table* (make-hash-table)
+  "Hash table for keeping track of gid's and group names.")
+
+;;; LOOKUP-GROUP-NAME translates a group id into a group name.  Previous
+;;; lookups are cached in a hash table since groveling the group(s) files
+;;; is somewhat expensive.  The table may hold nil for id's that cannot
+;;; be looked up since this means the files are searched in their entirety
+;;; each time this id is translated.
+;;; 
+(defun lookup-group-name (gid)
+  (multiple-value-bind (group-name foundp) (gethash gid *gid-hash-table*)
+    (if foundp
+	group-name
+	(setf (gethash gid *gid-hash-table*)
+	      (get-group-or-user-name :group gid)))))
+
+
+;;; GET-GROUP-OR-USER-NAME first tries "/etc/passwd" ("/etc/group") since it is
+;;; a much smaller file, contains all the local id's, and most uses probably
+;;; involve id's on machines one would login into.  Then if necessary, we look
+;;; in "/etc/passwds" ("/etc/groups") which is really long and has to be
+;;; fetched over the net.
+;;;
+(defun get-group-or-user-name (group-or-user id)
+  "Returns the simple-string user or group name of the user whose uid or gid
+   is id, or NIL if no such user or group exists.  Group-or-user is either
+   :group or :user."
+  (let ((id-string (let ((*print-base* 10)) (prin1-to-string id))))
+    (declare (simple-string id-string))
+    (multiple-value-bind (file1 file2)
+			 (ecase group-or-user
+			   (:group (values "/etc/group" "/etc/groups"))
+			   (:user (values "/etc/passwd" "/etc/passwd")))
+      (or (get-group-or-user-name-aux id-string file1)
+	  (get-group-or-user-name-aux id-string file2)))))
+
+(defun get-group-or-user-name-aux (id-string passwd-file)
+  (with-open-file (stream passwd-file)
+    (loop
+      (let ((entry (read-line stream nil)))
+	(unless entry (return nil))
+	(let ((name-end (position #\: (the simple-string entry)
+				  :test #'char=)))
+	  (when name-end
+	    (let ((id-start (position #\: (the simple-string entry)
+				      :start (1+ name-end) :test #'char=)))
+	      (when id-start
+		(incf id-start)
+		(let ((id-end (position #\: (the simple-string entry)
+					:start id-start :test #'char=)))
+		  (when (and id-end
+			     (string= id-string entry
+				      :start2 id-start :end2 id-end))
+		    (return (subseq entry 0 name-end))))))))))))
+
+
+
+;;; Complete-One-File  --  Internal
+;;;
+;;;    Return as values a string and the greatest common prefix of all
+;;; the files corresponding to pattern.
+;;;
+(defun complete-one-file (pattern default-type ignore-types)
+  (let ((first nil)
+	(length nil))
+    (do-directory (name etype pattern nil)
+      (declare (ignore etype))
+      (let* ((last-dot (position #\. name :from-end t))
+	     (type (if last-dot (subseq name (1+ last-dot)))))
+	(cond ((and (not (string= type default-type))
+		    (member type ignore-types :test #'string=)))
+	      (first
+	       (let ((msm (string-not-equal name first :end2 length)))
+		 (when (and msm (< msm length))
+		   (setq length msm))))
+	      (t
+	       (setq first name)
+	       (setq length (length name))))))
+    (values first length)))
+
+
+;;; Complete-File  --  Public
+;;;
+;;;    If the pathname is absolute, just call Complete-One-File on and test
+;;; whether the result is a file.  If a relative pathname, do it on each
+;;; directory, accumulating the result.
+;;;
+(defun complete-file (pathname &key defaults ignore-types)
+  "Attempt to complete Pathname as the name of a file.  If the resulting
+  completion is unique, return T as the second value.  If there is no
+  possible completion, return both values NIL."
+  (setq pathname (pathname pathname))
+  (setq defaults (if defaults (pathname defaults) *default-pathname-defaults*))
+  (flet ((pathnamify (res len ambiguous pathname)
+		     (values 
+		      (make-pathname :device (%pathname-device pathname)
+				     :directory (%pathname-directory pathname)
+				     :defaults (parse-namestring (subseq res 0 len)))
+		      (not ambiguous))))
+    (let ((dev (or (%pathname-device pathname) "default"))
+	  (default-type (%pathname-type defaults)))
+      (if (eq dev :absolute)
+	  (multiple-value-bind
+	      (res len)
+	      (complete-one-file (concatenate 'simple-string
+					      (namestring pathname)
+					      "*")
+				 default-type ignore-types)
+	    (declare (fixnum len))
+	    (if res
+		(pathnamify res len
+			    (/= (the fixnum (length res)) len)
+			    pathname)
+		(values nil nil)))
+	  (let ((namestring (%ses-get-useful-name pathname))		 
+		(dirs (if (and (%pathname-directory defaults)
+			       (string-equal dev "default"))
+			  (list (directory-namestring defaults))
+			  ()))
+		(max most-positive-fixnum)
+		(max-str nil)
+		(ambiguous nil))
+	    (declare (simple-string namestring))
+	    (do-search-list (entry dev)
+			    (pushnew entry dirs :test #'string-equal))
+	    (dolist (entry dirs)
+	      (let ((str (concatenate 'simple-string entry namestring "*")))
+		(declare (simple-string str))
+		(multiple-value-bind
+		    (res len)
+		    (complete-one-file str default-type ignore-types)
+		  (when res
+		    (unless ambiguous
+		      (setq ambiguous (or max-str (/= (length res) len))))
+		    (if max-str
+			(setq max (or (string-not-equal res max-str :end1 len
+							:end2 max)
+				      max))
+			(setq max len  max-str res))))))
+	    (if max-str
+		(pathnamify max-str max ambiguous pathname)
+		(values nil nil)))))))
+
+;;; File-writable -- exported from extensions.
+;;;
+;;;   Determines whether the single argument (which should be a pathname)
+;;;   can be written by the the current task.
+
+(defun file-writable (name)
+  "File-writable accepts a pathname and returns T if the current
+  process can write it, and NIL otherwise."
+  (multiple-value-bind (tn exists) (predict-name name nil)
+    (if exists
+	(values (mach:unix-access tn mach:w_ok))
+	(values (mach:unix-access (directory-namestring tn)
+				  (logior mach:w_ok mach:x_ok))))))
+
+
+;;; Pathname-Order  --  Internal
+;;;
+;;;    Predicate to order pathnames by.  Goes by name.
+;;;
+(defun pathname-order (x y)
+  (let ((xn (%pathname-name x))
+	(yn (%pathname-name y)))
+    (if (and xn yn)
+	(let ((res (string-lessp xn yn)))
+	  (cond ((not res) nil)
+		((= res (length (the simple-string xn))) t)
+		((= res (length (the simple-string yn))) nil)
+		(t t)))
+	xn)))
+
+;;; Ambiguous-Files  --  Public
+;;;
+;;;    If the pathname is absolute, just do a directory.  If it is relative,
+;;; do a directory on each directory in the search-list and merge the results.
+;;;
+(defun ambiguous-files (pathname &optional defaults)
+  "Return a list of all files which are possible completions of Pathname.
+  We look in the directory specified by Defaults as well as looking down
+  the search list."
+  (setq pathname (pathname pathname)
+	defaults (if defaults (pathname defaults) *default-pathname-defaults*))
+  (let ((dev (or (%pathname-device pathname) "default")))
+    (if (eq dev :absolute)
+	(directory (concatenate 'simple-string (namestring pathname) "*"))
+	(let ((namestring (%ses-get-useful-name pathname))		 
+	      (dirs (if (and (%pathname-directory defaults)
+			     (string-equal dev "default"))
+			(list (directory-namestring defaults))
+			()))
+	      (res ()))
+	  (declare (simple-string namestring))
+	  (do-search-list (entry dev) (pushnew entry dirs :test #'string-equal))
+	  (dolist (entry dirs)
+	    (let ((str (concatenate 'simple-string entry namestring "*")))
+	      (declare (simple-string str))
+	      (setq res (merge 'list res (directory str)
+			       #'pathname-order))))
+	  res))))
+
+;;; Default-Directory  --  Public
+;;;
+;;;    This fills in a hole in Common Lisp.  We return the first thing we
+;;; find by doing a ResolveSearchList on Default.
+;;; 
+(defun default-directory ()
+  "Returns the pathname for the default directory.  This is the place where
+  a file will be written if no directory is specified.  This may be changed
+  with setf."
+  (multiple-value-bind (gr dir-or-error)
+		       (mach:unix-current-directory)
+    (if gr
+	dir-or-error
+	(error (mach:get-unix-error-msg dir-or-error)))))
+
+;;;
+;;; Maybe this shouldn't go here...
+(defsetf default-directory %set-default-directory)
+
+;;; %Set-Default-Directory  --  Internal
+;;;
+;;;    The setf method for Default-Directory.  We actually set the environment
+;;; variable Current which is by convention the head of the search list.
+;;; 
+(defun %set-default-directory (new-val)
+  (multiple-value-bind (gr error)
+		       (mach:unix-chdir (predict-name new-val nil))
+    (if gr
+	(car (setf (search-list "default:")
+		   (cdr (multiple-value-list (mach:unix-current-directory)))))
+	(error (mach:get-unix-error-msg error)))))
diff --git a/code/foreign.lisp b/code/foreign.lisp
new file mode 100644
index 000000000..da62b5a32
--- /dev/null
+++ b/code/foreign.lisp
@@ -0,0 +1,281 @@
+;;; -*- Log: code.log; Package: Extensions -*-
+
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+
+;;; Functions for dealing with foreign function calls in Common Lisp.
+
+;;; Written by David B. McDonald, January 1987.
+
+;;; *******************************************************************
+(in-package "EXTENSIONS" :nicknames '("EXT") :use '("LISP" "SYSTEM"))
+
+(export '(load-foreign get-code-pointer get-data-pointer))
+
+(defconstant Unix-OMagic #x107)
+(defconstant Unix-NMagic #x108)
+(defconstant Unix-ZMagic #x10b)
+
+(defconstant Unix-header-size 32)
+(defconstant Symbol-Table-Entry-Size 12)
+
+(defconstant n_undf #x0)
+(defconstant n_abs #x2)
+(defconstant n_text #x4)
+(defconstant n_data #x6)
+(defconstant n_bss #x8)
+(defconstant n_comm #x12)
+(defconstant n_fn #x1f)
+(defconstant n_ext #x1)
+
+(defvar file-count 0
+  "Number of foreign function files loaded into the current Lisp.")
+
+(defvar temporary-foreign-files NIL
+  "List of dotted pairs containing location and size of object code
+   loaded so that foreign functions can be called.")
+
+(proclaim '(fixnum file-count))
+
+(defstruct unix-ste
+  (type 0 :type fixnum)
+  (location 0))
+
+
+(defvar foreign-symbols (make-hash-table :size 1000 :test #'equal))
+
+(defmacro read-cword (sap offset)
+  `(let ((rsap ,sap)
+	 (roff ,offset))
+     (declare (fixnum roff))
+     (setq roff (the fixnum (ash roff 1)))
+     (logior (ash (%primitive 16bit-system-ref rsap roff) 16)
+	     (%primitive 16bit-system-ref rsap (the fixnum (1+ roff))))))
+
+(defun read-miscop-free-pointer ()
+  (let ((aa lisp::alloctable-address)
+	(in (ash lisp::%assembler-code-type lisp::%alloc-ref-type-shift)))
+    (declare (fixnum in))
+    (logand (+ (logior (%primitive 16bit-system-ref aa (the fixnum (1+ in)))
+		       (ash (%primitive 16bit-system-ref aa in) 16)) 3)
+	    (lognot 3))))
+
+(defun write-miscop-free-pointer (value)
+  (let ((aa lisp::alloctable-address)
+	(in (ash lisp::%assembler-code-type lisp::%alloc-ref-type-shift))
+	(vl (logand value #xFFFF))
+	(vh (logand (ash value -16) #xFFFF)))
+    (declare (fixnum in))
+    (%primitive 16bit-system-set aa (the fixnum (1+ in)) vl)
+    (%primitive 16bit-system-set aa in vh)))
+
+;;; Load-foreign accepts a file or a list of files to be loaded into the
+;;; currently running Lisp core.  These files should be standard object
+;;; files created by you favourite compiler (e.g., cc).  It accepts two
+;;; optional parameters: libraries is a list of libraries to search
+;;; for unresolved references (default is the standard C library), and
+;;; env which is a list of Unix environment strings (default is what
+;;; lisp started with).  Load-foreign runs ld creating an object file
+;;; that has been linked so that it can be loaded into a predetermined
+;;; location in memory.
+
+(defun load-foreign (files &optional
+			   (libraries '("-lc"))
+			   (linker "/usr/cs/bin/ld")
+			   (base-file "/usr/misc/.lisp/bin/lisp")
+			   (env lisp::original-lisp-environment))
+  "Load-foreign loads a list of C object files into a running Lisp.  The
+  files argument should be a single file or a list of files.  The files
+  may be specified as namestrings or as pathnames.  The libraries
+  argument should be a list of library files as would be specified to
+  ld.  They will be searched in the order given.  The default is just
+  \"-lc\", i.e., the C library.  The linker argument is used to specifier
+  the Unix linker to use to link the object files (the default is
+  /usr/cs/bin/ld).  The base-file argument is used to specify a file to
+  use as the starting place for defined symbols.  The default is the C
+  start up code for Lisp.  The env argument is the Unix environment
+  variable definitions for the invocation of the linker.  The default is
+  the environment passed to Lisp."
+  (if (null (listp files)) (setq files (list files)))
+  (format t "[Loading foreign files ~A ...~%" files)
+  (let ((tfl (if files (format nil "/tmp/L~d.~d"
+			       (mach:unix-getuid)
+			       (the fixnum (+ (the fixnum (mach:unix-getpid))
+					      file-count)))
+		 base-file))
+	(ofl (get-last-loaded-file file-count base-file))
+	(addr (read-miscop-free-pointer)))
+    (when files
+      (setq file-count (the fixnum (1+ file-count)))
+      (format t "  [Running ld ...")
+      (force-output t)
+      (let ((nfiles ()))
+	(dolist (f files)
+	  (let* ((pn (merge-pathnames f *default-pathname-defaults*))
+		 (tn (probe-file pn)))
+	    (push (if tn (namestring tn) f) nfiles)))
+	(setf files (nreverse nfiles)))
+      (run-program linker `("-N" "-A" ,ofl "-T"
+			    ,(format nil "~X" (+ addr unix-header-size))
+			    "-o" ,tfl ,@files ,@libraries)
+		   :env env :wait t :output t :error t)
+      (push tfl temporary-foreign-files)
+      (format t " done.]~%"))
+    (multiple-value-bind (res dev ino mode nlnk uid gid rdev len)
+			 (mach:unix-stat tfl)
+      (declare (ignore ino mode nlnk uid gid rdev))
+      (when (null res)
+	(error "Could not stat intermediate file ~a, unix error: ~A."
+	       tfl (mach:get-unix-error-msg dev)))
+      (format t "  [Reading Unix object file ...")
+      (force-output t)
+      (multiple-value-bind (fd err) (mach:unix-open tfl mach:o_rdonly 0)
+	(when (null fd)
+	  (error "Failed to open intermediate file ~A, unix error: ~A."
+		 (mach:get-unix-error-msg err)))
+	(multiple-value-bind (bytes err2)
+			     (mach:unix-read fd (int-sap addr)
+					     len)
+	  (when (or (null bytes) (not (eq bytes len)))
+	    (if (null bytes)
+		(error "Read of intermediate file ~A failed, unix error: ~A"
+		       tfl (mach:get-unix-error-msg err2))
+		(error "Read of intermediate file ~A only read ~d of ~d bytes."
+		       tfl bytes len))))
+	(mach:unix-close fd)))
+    (format t " done.]~%")
+    (let ((fsize (logand (+ (load-object-file tfl addr files) 4) (lognot 3))))
+      (when files (write-miscop-free-pointer (+ addr fsize)))))
+  (format t "done.]~%"))
+
+;;; Get-last-loaded-file attempts to find the file that was last loaded into
+;;; Lisp.  If one is found, load-foreign uses it as the bases for the initial
+;;; symbol table.  Otherwise, it uses the lisp startup code.
+
+(defun get-last-loaded-file (fc base-file)
+  (declare (fixnum fc))
+  (do ((i (the fixnum (1- fc)) (1- i)))
+      ((< i 0) base-file)
+    (declare (fixnum i))
+    (let ((tfl (format nil "/tmp/L~d.~d" (mach:unix-getuid)
+		       (the fixnum (+ (the fixnum (mach:unix-getpid)) i)))))
+      (if (probe-file tfl) (return tfl)))))
+
+;;; Load-object-file, actually loads the object file created by ld.
+;;; It makes sure that it is a legal object file.
+
+(defun load-object-file (file addr flag)
+  (format t "  [Loading symbol table information ...")
+  (force-output t)
+  (let* ((sap (int-sap addr))
+	 (magic (read-cword sap 0))
+	 (text-size (read-cword sap 1))
+	 (idata-size (read-cword sap 2))
+	 (udata-size (read-cword sap 3))
+	 (symtab-size (read-cword sap 4))
+	 (epoint (read-cword sap 5))
+	 (treloc-size (read-cword sap 6))
+	 (dreloc-size (read-cword sap 7))
+	 (load-size (+ text-size idata-size udata-size unix-header-size))
+	 (symstart (+ text-size idata-size (if flag unix-header-size 2048)))
+	 (strstart (+ symstart (the fixnum symtab-size))))
+    (declare (fixnum magic text-size idata-size udata-size
+		     symtab-size symstart strstart treloc-size
+		     dreloc-size)
+	     (ignore epoint))
+    (unless (or (null flag)
+		(and (= magic unix-OMagic) (= treloc-size 0) (= dreloc-size 0)))
+      (error "File ~A is not a legal Unix object file." file))
+    (read-symbol-table (the fixnum (+ (the fixnum sap) symstart))
+		       symtab-size (the fixnum (+ (the fixnum sap) strstart)))
+    (setq load-size (logand (the fixnum (+ load-size 8192)) (lognot 8191)))
+    (do ((ind (truncate (+ text-size idata-size unix-header-size) 2)
+	      (1+ ind))
+	 (end (truncate udata-size 2)))
+	((>= ind end))
+      (%primitive 16bit-system-set sap ind 0))
+    (format t " done.]~%")
+    load-size))
+
+;;; Read-symbol-table reads the symbol table out of the object, making
+;;; external symbols available to Lisp, so that they can be used to
+;;; link to the C routines.
+
+(defun read-symbol-table (symstart symtab-size strstart)
+  (let ((end (the fixnum (+ (the fixnum symstart) (the fixnum symtab-size)))))
+    (do* ((se symstart (the fixnum (+ (the fixnum se) symbol-table-entry-size)))
+	  (si (logior (ash (%primitive 16bit-system-ref se 0) 16)
+		      (%primitive 16bit-system-ref se 1))
+	      (logior (ash (%primitive 16bit-system-ref se 0) 16)
+		      (%primitive 16bit-system-ref se 1)))
+	  (st (%primitive 8bit-system-ref se 4)
+	      (%primitive 8bit-system-ref se 4))
+	  (sv (logior (ash (%primitive 16bit-system-ref se 4) 16)
+		      (%primitive 16bit-system-ref se 5))
+	      (logior (ash (%primitive 16bit-system-ref se 4) 16)
+		      (%primitive 16bit-system-ref se 5))))
+	 ((>= (the fixnum se) (the fixnum end)))
+      (declare (fixnum st))
+      (when (or (= st (logior n_text n_ext))
+		(= st (logior n_data n_ext))
+		(= st (logior n_bss n_ext)))
+	(let* ((strend (%primitive find-character strstart si (+ si 512) 0)))
+	  (when (null strend)
+	    (error "Symbol table string didn't terminate."))
+	  (let ((strlen (the fixnum (- (the fixnum strend) (the fixnum si))))
+		(offset 0)
+		(code NIL)
+		(str NIL))
+	    (declare (fixnum strlen offset))
+	    (when (eq (%primitive 8bit-system-ref strstart si) (char-code #\_))
+	      (setq offset (the fixnum (1+ offset)))
+	      (when (eq (%primitive 8bit-system-ref strstart
+				    (the fixnum (1+ (the fixnum si))))
+			(char-code #\.))
+		(setq code T)
+ 		(setq offset (the fixnum (1+ offset)))))
+	    (setq str (make-string (the fixnum (- strlen offset))))
+	    (%primitive byte-blt strstart
+			(the fixnum (+ (the fixnum si) offset)) str 0 strlen)
+	    (if (let ((x (ash sv (- (+ clc::type-shift-16 16)))))
+		  (not (<= clc::first-pointer-type x clc::last-pointer-type)))
+		(let ((ste (gethash str foreign-symbols))
+		      (loc (int-sap sv)))
+		  (cond ((null ste)
+			 (setf (gethash str foreign-symbols)
+			       (make-unix-ste :type (if code
+							(logior n_text
+								n_ext) st)
+					      :location (if code nil loc))))
+			(code
+			 (setf (unix-ste-type ste) (logior n_text n_ext)))
+			(T
+			 (setf (unix-ste-location ste) loc)))))))))))
+
+;;; Get-code-pointer accepts a simple string which should be the name
+;;; of a C routine that has already been loaded into the Lisp core image.
+;;; This name should use the correct capitalization of the C name without
+;;; the default underscore.
+(defun get-code-pointer (name)
+  (let ((ste (gethash name foreign-symbols)))
+    (when (null ste)
+      (error "There is no foreign function named ~A loaded." name))
+    (when (not (eq (unix-ste-type ste) (logior n_text n_ext)))
+      (error "~A is a foreign external variable, not a foreign function." name))
+    (unix-ste-location ste)))
+
+
+;;; Get-data-pointer is similar to get-code-pointer, except it returns the
+;;; address of a foreign global variable.
+
+(defun get-data-pointer (name)
+  (let ((ste (gethash name foreign-symbols)))
+    (when (null ste)
+      (error "There is no foreign variable named ~A loaded." name))
+    (when (eq (unix-ste-type ste) (logior n_text n_ext))
+      (error "~A is a foreign function, not a foreign variable." name))
+    (unix-ste-location ste)))
diff --git a/code/format.lisp b/code/format.lisp
new file mode 100644
index 000000000..975514f0f
--- /dev/null
+++ b/code/format.lisp
@@ -0,0 +1,1514 @@
+;;; -*- Log: code.log; Package: Lisp -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; Functions to implement FORMAT for Spice Lisp.
+;;;
+;;; Original by David Adam.
+;;; Re-write by Bill Maddox.
+;;; Currently not maintained.
+;;;
+;;; FORMAT is part of the standard Spice Lisp environment.
+;;;
+;;; **********************************************************************
+
+(in-package 'lisp)
+(export 'format)
+
+;;; Special variables local to FORMAT
+
+(defvar *format-control-string* ""
+  "The current FORMAT control string")
+
+(defvar *format-index* 0
+  "The current index into *format-control-string*")
+
+(defvar *format-length* 0
+  "The length of the current FORMAT control string")
+
+(defvar *format-arguments* ()
+  "Arguments to the current call of FORMAT")
+
+(defvar *format-original-arguments* ()
+ "Saved arglist from top-level FORMAT call for ~* and ~@*")
+
+(defvar *format-stream-stack* ()
+  "A stack of string streams for collecting FORMAT output")
+
+(defvar *format-dispatch-table* ()
+  "Dispatch table for FORMAT commands")
+
+
+;;; Specials imported from PRINT and STREAM
+
+(proclaim '(special *print-base* *standard-output* *terminal-io*))
+
+;;; Specials imported from ERRORFUNS
+
+(proclaim '(special *error-output*))
+
+
+
+;;; ERRORS
+
+;;; Since errors may occur while an indirect control string is being
+;;; processed, i.e. by ~? or ~{~:}, some sort of backtrace is necessary
+;;; in order to indicate the location in the control string where the
+;;; error was detected.  To this end, errors detected by format are
+;;; signalled by throwing a list of the form ((control-string args))
+;;; to the tag FORMAT-ERROR.  This throw will be caught at each level
+;;; of indirection, and the list of error messages re-thrown with an
+;;; additional message indicating that indirection was present CONSed
+;;; onto it.  Ultimately, the last throw will be caught by the top level
+;;; FORMAT function, which will then signal an error to the Lisp error
+;;; system in such a way that all the errror messages will be displayed
+;;; in reverse order.
+
+(defun format-error (complaint &rest args)
+  (throw 'format-error
+	 (list (list "~1{~:}~%~S~%~V@T^" complaint args
+		     *format-control-string* (1+ *format-index*)))))
+
+
+
+;;; MACROS
+
+;;; This macro establishes the correct environment for processing
+;;; an indirect control string.  CONTROL-STRING is the string to
+;;; process, and FORMS are the forms to do the processing.  They 
+;;; invariably will involve a call to SUB-FORMAT.  CONTROL-STRING
+;;; is guaranteed to be evaluated exactly once.
+
+(defmacro format-with-control-string (control-string &body forms)
+  `(let ((string (if (simple-string-p ,control-string)
+		     ,control-string
+		     (coerce ,control-string 'simple-string))))
+     (declare (simple-string string))
+     (let ((error (catch 'format-error
+			 (let ((*format-control-string* string)
+			       (*format-length* (length string))
+			       (*format-index* 0))
+			   (declare (simple-string *format-control-string*)
+				    (fixnum *format-length* *format-index*))
+			   ,@forms
+			   nil))))
+       (when error
+	 (throw 'format-error
+	   (cons (list "While processing indirect control string~%~S~%~V@T^"
+		       *format-control-string*
+		       (1+ *format-index*))
+	       error))))))
+
+
+;;; This macro rebinds collects output to the standard output stream
+;;; in a string.  For efficiency, we avoid consing a new stream on
+;;; every call.  A stack of string streams is maintained in order to
+;;; guarantee re-entrancy.
+
+(defmacro format-stringify-output (&body forms)
+  `(let ((*standard-output*
+	  (if *format-stream-stack*
+	      (pop *format-stream-stack*)
+	      (make-string-output-stream))))
+     (unwind-protect
+      (progn ,@forms
+	     (prog1
+	      (get-output-stream-string *standard-output*)
+	      (push *standard-output* *format-stream-stack*)))
+      (get-output-stream-string *standard-output*))))
+
+
+
+;;; Pops an argument from the current argument list.  This is either the
+;;; list of arguments given to the top-level call to FORMAT, or the argument
+;;; list for the current iteration in a ~{~} construct.  An error is signalled
+;;; if the argument list is empty.
+
+(defmacro pop-format-arg ()
+  '(if *format-arguments*
+       (pop *format-arguments*)
+       (format-error "Missing argument")))
+
+
+;;; This macro decomposes the argument list returned by PARSE-FORMAT-OPERATION.
+;;; PARMVAR is the list of parameters.  PARMDEFS is a list of lists of the form
+;;; (<var> <default>).  The FORMS are evaluated in an environment where each 
+;;; <var> is bound to either the value of the parameter supplied in the 
+;;; parameter list, or to its <default> value if the parameter was omitted or
+;;; explicitly defaulted.
+
+(defmacro with-format-parameters (parmvar parmdefs &body forms)
+  (do ((parmdefs parmdefs (cdr parmdefs))
+       (bindings () (cons `(,(caar parmdefs) (or (if ,parmvar (pop ,parmvar))
+						 ,(cadar parmdefs)))
+			 bindings)))
+      ((null parmdefs)
+       `(let ,(nreverse bindings)
+	  (when ,parmvar
+	    (format-error "Too many parameters"))
+	  ,@forms))))
+
+
+
+;;; CONTROL STRING PARSING 
+
+;;; The current control string is kept in *format-control-string*. 
+;;; The variable *format-index* is the position of the last character
+;;; processed, indexing from zero.  The variable *format-length* is the
+;;; length of the control string, which is one greater than the maximum
+;;; value of *format-index*.  
+
+
+;;; Gets the next character from the current control string.  It is an
+;;; error if there is none.  Leave *format-index* pointing to the
+;;; character returned.
+
+(defmacro nextchar ()
+  '(if (< (the fixnum (incf (the fixnum *format-index*)))
+	  (the fixnum *format-length*))
+       (schar *format-control-string* *format-index*)
+       (format-error "Syntax error")))
+
+
+;;; Returns the current character, i.e. the one pointed to by *format-index*.
+
+(defmacro format-peek ()
+  '(schar *format-control-string* *format-index*))
+
+
+;;; Returns the index of the first occurrence of the specified character
+;;; between indices START (inclusive) and END (exclusive) in the control
+;;; string.
+
+
+(defmacro format-find-char (char start end)
+  `(position ,char (the simple-string *format-control-string*)
+	     :start ,start :end ,end :test #'char=))
+
+
+;;; Attempts to parse a parameter, starting at the current index.
+;;; Returns the value of the parameter, or NIL if none is found. 
+;;; On exit, *format-index* points to the first character which is
+;;; not a part of the recognized parameter.
+
+(defun format-get-parameter ()
+  (case (format-peek)
+    (#\# (nextchar) (length (the list *format-arguments*)))
+    ((#\V #\v) (prog1 (pop-format-arg) (nextchar)))
+    (#\' (prog1 (nextchar) (nextchar)))
+    ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
+     (do* ((number (digit-char-p (format-peek))
+		   (+ (* 10 number) (digit-char-p (format-peek)))))
+	  ((not (digit-char-p (nextchar))) number)))
+    (#\-
+     (nextchar)
+     (case (format-peek)
+       ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
+	(do* ((number (digit-char-p (format-peek))
+		      (+ (* 10 number) (digit-char-p (format-peek)))))
+	     ((not (digit-char-p (nextchar))) (- number))))
+       (t (decf (the fixnum *format-index*))  ; put back to out of place "-"
+	  nil)))
+    (#\+
+     (nextchar)
+     (case (format-peek)
+       ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
+	(do* ((number (digit-char-p (format-peek))
+		      (+ (* 10 number) (digit-char-p (format-peek)))))
+	     ((not (digit-char-p (nextchar))) number)))
+       (t (decf (the fixnum *format-index*))  ; put back to out of place "-"
+	  nil)))
+    (t nil)))
+
+
+;;; Parses a format directive, including flags and parameters.  On entry,
+;;; *format-index* should point to the "~" preceding the command.  On
+;;; exit, *format-index* points to the command character itself.
+;;; Returns the list of parameters, the ":" flag, the "@" flag, and the
+;;; command character as multiple values.  Explicitly defaulted parameters
+;;; appear in the list of parameters as NIL.  Omitted parameters are simply 
+;;; not included in the list at all.
+
+(defun parse-format-operation ()
+  (let ((ch (nextchar)))
+    (values (if (or (digit-char-p ch)
+		    (member ch '(#\, #\# #\V #\v #\' #\+ #\-) :test #'char=))
+		(do ((parms (list (format-get-parameter))
+			    (cons (format-get-parameter) parms)))
+		    ((char/= (format-peek) #\,) (nreverse parms))
+		  (declare (list parms))
+		  (nextchar))
+		'())
+	    (if (char= (format-peek) #\:) (nextchar) nil)
+	    (if (char= (format-peek) #\@) (nextchar) nil)
+	    (format-peek))))
+
+
+
+;;; Starting at the current value of *format-index*, finds the first
+;;; occurrence of one of the specified directives. Embedded constructs,
+;;; i.e. those inside ~(~), ~[~], ~{~}, or ~<~>, are ignored.  And error is
+;;; signalled if no satisfactory command is found.  Otherwise, the
+;;; following are returned as multiple values:
+;;;
+;;;     The value of *format-index* at the start of the search
+;;;     The index of the "~" character preceding the command
+;;;     The parameter list of the command
+;;;     The ":" flag
+;;;     The "@" flag
+;;;     The command character
+;;;
+;;; Implementation note:  The present implementation is not particulary
+;;; careful with storage allocation.  It would be a good idea to have
+;;; a separate function for skipping embedded constructs which did not
+;;; bother to cons parameter lists and then throw them away.
+;;;
+;;; We go to some trouble here to use POSITION for most of the searching.
+;;;
+;;; Another note: *FORMAT-ARGUMENTS* is let bound here so that we can
+;;; guarantee that that list is not changed by FORMAT-FIND-COMMAND.
+;;; This is necessary since PARSE-FORMAT-OPERATION (called below) calls
+;;; FORMAT-GET-PARAMETER.  If the parameter is #\V or #\v then
+;;; FORMAT-GET-PARAMETER will pop *FORMAT-ARGUMENTS*.  This causes the
+;;; argument to be lost when we actually go to do the real formatting.
+;;;
+(defun format-find-command (command-list)
+  (let ((start *format-index*)
+	(*format-arguments* *format-arguments*))
+    (do ((place start *format-index*)
+	 (tilde (format-find-char #\~ start *format-length*)
+		(format-find-char #\~ place *format-length*)))
+	((not tilde)
+	 (format-error "Expecting one of ~S" command-list))
+      (setq *format-index* tilde)
+      (multiple-value-bind (parms colon atsign command)
+			   (parse-format-operation)
+	(when (member command command-list :test #'char=)
+	  (return (values start tilde parms colon atsign command)))
+	(case command
+	  (#\{ (nextchar)(format-find-command '(#\})))
+	  (#\< (nextchar)(format-find-command '(#\>)))
+	  (#\( (nextchar)(format-find-command '(#\))))
+	  (#\[ (nextchar)(format-find-command '(#\])))
+	  ((#\} #\> #\) #\])
+	   (format-error "No matching bracket")))))))
+
+ 
+
+;;; This is the FORMAT top-level function.
+
+(defun format (destination control-string &rest format-arguments)
+  "Provides various facilities for formatting output.
+  CONTROL-STRING contains a string to be output, possibly with embedded
+  directives, which are flagged with the escape character \"~\".  Directives
+  generally expand into additional text to be output, usually consuming one
+  or more of the FORMAT-ARGUMENTS in the process.  A few useful directives
+  are:
+        ~A or ~nA     Prints one argument as if by PRINC
+        ~S or ~nS     Prints one argument as if by PRIN1
+        ~D or ~nD     Prints one argument as a decimal integer
+        ~%            Does a TERPRI
+        ~&            Does a FRESH-LINE
+
+         where n is the width of the field in which the object is printed.
+  
+  DESTINATION controls where the result will go.  If DESTINATION is T, then
+  the output is sent to the standard output stream.  If it is NIL, then the
+  output is returned in a string as the value of the call.  Otherwise,
+  DESTINATION must be a stream to which the output will be sent.
+
+  Example:   (FORMAT NIL \"The answer is ~D.\" 10) => \"The answer is 10.\"
+
+  FORMAT has many additional capabilities not described here.  Consult the
+  manual for details."
+
+  (let ((*format-original-arguments* format-arguments)	;for abs. and rel. goto
+	(*format-arguments* format-arguments)
+	(*print-radix* nil)
+	(*format-control-string*
+	 (if (simple-string-p control-string)
+	     control-string
+	     (coerce control-string 'simple-string))))
+    (declare (simple-string *format-control-string*))
+    (cond
+     ((not destination)
+      (format-stringify-output
+       (let ((errorp (catch 'format-error
+		       (catch 'format-escape
+			 (catch 'format-colon-escape
+			   (sub-format 0 (length *format-control-string*))))
+		       nil)))
+	 (when errorp
+	   (error "~%~:{~@?~%~}" (nreverse errorp))))))
+     ((and (stringp destination) (array-has-fill-pointer-p destination))
+      (with-output-to-string (*standard-output* destination)
+	(let ((errorp (catch 'format-error
+			(catch 'format-escape
+			  (catch 'format-colon-escape
+			    (sub-format 0 (length *format-control-string*))))
+			nil)))
+	  (when errorp
+	    (error "~%~:{~@?~%~}" (nreverse errorp)))
+	  nil)))
+     (t
+      (let ((*standard-output*
+	     (if (or (eq destination 't)
+		     (and (synonym-stream-p destination)
+			  (eq (synonym-stream-symbol destination)
+			      '*standard-output*)))
+		 *standard-output*
+		 destination)))
+	(let ((errorp (catch 'format-error
+			(catch 'format-escape
+			  (catch 'format-colon-escape
+			    (sub-format 0 (length *format-control-string*))))
+			nil)))
+	  (when errorp
+	    (error "~%~:{~@?~%~}" (nreverse errorp))))
+	nil)))))
+
+;;; This function does the real work of format.  The segment of the control
+;;; string between indiced START (inclusive) and END (exclusive) is processed
+;;; as follows: Text not part of a directive is output without further
+;;; processing.  Directives are parsed along with their parameters and flags,
+;;; and the appropriate handlers invoked with the arguments COLON, ATSIGN, and
+;;; PARMS. 
+;;;
+;;; Implementation Note: FORMAT-FIND-CHAR uses the POSITION sequence operation
+;;; for speed.  This is potentially faster than character-at-a-time searching.
+
+(defun sub-format (start end)
+  (declare (fixnum start end))
+  (let ((*format-index* start)
+	(*format-length* end))
+    (declare (fixnum *format-index* *format-length*))
+    (do* ((place start *format-index*)
+	  (tilde (format-find-char #\~ start end)
+		 (format-find-char #\~ place end)))
+	 ((not tilde)
+	  (write-string *format-control-string*	*standard-output*
+			:start place :end end))
+      (declare (fixnum place) (type (or fixnum null) tilde))
+      (when (> tilde place)
+	(write-string *format-control-string* *standard-output*
+		      :start place :end tilde))
+      (setq *format-index* tilde)
+      (multiple-value-bind
+       (parms colon atsign command)
+       (parse-format-operation)
+       (let ((cmdfun (svref *format-dispatch-table* (char-code command))))
+	 (if cmdfun
+	     (funcall cmdfun colon atsign parms)
+	     (format-error "Illegal FORMAT command ~~~S" command))))
+      (unless (< (the fixnum (incf (the fixnum *format-index*))) end)
+	(return)))))
+
+
+
+;;; Conditional case conversion  ~( ... ~)
+
+(defun format-capitalization (colon atsign parms)
+  (when parms
+    (format-error "No parameters allowed to ~~("))
+  (nextchar)
+  (multiple-value-bind
+   (prev tilde end-parms end-colon end-atsign)
+   (format-find-command '(#\)))
+   (when (or end-parms end-colon end-atsign)
+     (format-error "Flags or parameters not allowed"))
+   (let ((string (format-stringify-output (sub-format prev tilde))))
+     (declare (string string))
+     (write-string
+      (cond ((and atsign colon)
+	     (nstring-upcase string))
+	    (colon
+	     (nstring-capitalize string))
+	    (atsign
+	     (let ((strlen (length string)))
+	       (declare (fixnum strlen))
+	       ;; Capitalize the first word only
+	       (nstring-downcase string)
+	       (do ((i 0 (1+ i)))
+		   ((or (<= strlen i) (alpha-char-p (char string i)))
+		    (setf (char string i) (char-upcase (char string i)))
+		    string)
+		 (declare (fixnum i)))))
+	    (t (nstring-downcase string)))))))
+
+
+
+;;; Up and Out (Escape)  ~^
+
+(defun format-escape (colon atsign parms)
+  (when atsign
+    (format-error "FORMAT command ~~~:[~;:~]@^ is undefined" colon))
+  (when (if (first parms)
+	    (if (second parms)
+		(if (third parms)
+		    (typecase (second parms)
+		      (integer
+		       (<= (first parms) (second parms) (third parms)))
+		      (character
+		       (char< (first parms) (second parms) (third parms)))
+		      (t nil))
+		    (equal (first parms) (second parms)))
+		(zerop (first parms)))
+	    (not *format-arguments*))
+    (throw (if colon 'format-colon-escape 'format-escape) nil)))
+
+
+;;; Conditional expression  ~[ ... ]
+
+
+;;; ~[ 
+
+(defun format-untagged-condition ()
+  (let ((test (pop-format-arg)))
+    (unless (integerp test)
+      (format-error "Argument to ~~[ must be integer - ~S" test))
+    (do ((count 0 (1+ count)))
+	((= count test)
+	 (multiple-value-bind
+	  (prev tilde parms colon atsign cmd)
+	  (format-find-command '(#\; #\]))
+	  (declare (ignore colon))
+	  (when atsign
+	    (format-error "Atsign flag not allowed"))
+	  (when parms
+	    (format-error "No parameters allowed"))
+	  (sub-format prev tilde)
+	  (unless (char= cmd #\])
+	    (format-find-command '(#\])))))
+      (multiple-value-bind
+       (prev tilde parms colon atsign cmd)
+       (format-find-command '(#\; #\]))
+       (declare (ignore prev tilde))
+       (when atsign
+	 (format-error "Atsign flag not allowed"))
+       (when parms
+	 (format-error "Parameters not allowed"))
+       (when (char= cmd #\]) (return))
+       (when colon
+	 (nextchar)
+	 (multiple-value-bind (prev tilde parms colon atsign cmd)
+			      (format-find-command '(#\; #\]))
+	   (declare (ignore parms colon atsign))
+	   (sub-format prev tilde)
+	   (unless (char= cmd #\])
+	     (format-find-command '(#\]))))
+	 (return))
+       (nextchar)))))
+
+
+;;; ~@[
+
+(defun format-funny-condition ()
+  (multiple-value-bind
+   (prev tilde parms colon atsign)
+   (format-find-command '(#\]))
+   (when (or colon atsign parms)
+     (format-error "Flags or arguments not allowed"))
+   (if *format-arguments*
+       (if (car *format-arguments*)
+	   (sub-format prev tilde)
+	   (pop *format-arguments*))
+       (format-error "Missing argument"))))
+
+
+;;; ~:[ 
+
+(defun format-boolean-condition ()
+  (multiple-value-bind
+   (prev tilde parms colon atsign)
+   (format-find-command '(#\;))
+   (when (or parms colon atsign)
+     (format-error "Flags or parameters not allowed"))
+   (nextchar)			  
+   (if (pop-format-arg)
+       (multiple-value-bind
+	(prev tilde parms colon atsign)
+	(format-find-command '(#\]))
+	(when (or colon atsign parms)
+	  (format-error "Flags or parameters not allowed"))
+	(sub-format prev tilde))
+       (progn
+	(sub-format prev tilde)
+	(format-find-command '(#\]))))))
+
+
+(defun format-condition (colon atsign parms)
+  (when parms
+    (push (pop parms) *format-arguments*)
+    (unless (null parms)
+      (format-error "Too many parameters to ~[")))
+  (nextchar)
+  (cond (colon
+	 (when atsign
+	   (format-error  "~~:@[ undefined"))
+	 (format-boolean-condition))
+	(atsign
+	 (format-funny-condition))
+	(t (format-untagged-condition))))
+
+
+;;; Iteration  ~{ ... ~}
+
+(defun format-iteration (colon atsign parms)
+  (with-format-parameters parms ((max-iter -1))
+    (nextchar)
+    (multiple-value-bind
+     (prev tilde end-parms end-colon end-atsign)
+     (format-find-command '(#\}))
+     (when (or end-atsign end-parms)
+       (format-error "Illegal terminator for ~~{"))
+     (if (= prev tilde)
+	 ;; Use an argument as the control string if ~{~} is empty
+	 (let ((string (pop-format-arg)))
+	   (unless (stringp string)
+	     (format-error "Control string is not a string"))
+	   (format-with-control-string string
+	     (format-do-iteration 0 *format-length*
+				  max-iter colon atsign end-colon)))
+	 (format-do-iteration prev tilde max-iter colon atsign end-colon)))))
+
+
+;;; The two catch tags FORMAT-ESCAPE and FORMAT-COLON-ESCAPE are needed here
+;;; to correctly implement ~^ and ~:^.  The former aborts only the current
+;;; iteration, but the latter aborts the entire iteration process.
+
+(defun format-do-iteration (start end max-iter colon atsign at-least-once-p)
+  (catch 'format-colon-escape
+    (catch 'format-escape
+      (if atsign
+	  (do* ((count 0 (1+ count)))
+	       ((or (= count max-iter)
+		    (and (null *format-arguments*)
+			 (if (= count 0) (not at-least-once-p) t))))
+	    (catch 'format-escape
+	      (if colon
+		  (let* ((*format-original-arguments* (pop-format-arg))
+			 (*format-arguments* *format-original-arguments*))
+		    (unless (listp *format-arguments*)
+		      (format-error "Argument must be a list"))
+		    (sub-format start end))
+		  (sub-format start end))))
+	  (let* ((*format-original-arguments* (pop-format-arg))
+		 (*format-arguments* *format-original-arguments*))
+	    (unless (listp *format-arguments*)
+	      (format-error "Argument must be a list"))
+	    (do* ((count 0 (1+ count)))
+		 ((or (= count max-iter)
+		      (and (null *format-arguments*)
+			   (if (= count 0) (not at-least-once-p) t))))
+	      (catch 'format-escape
+		(if colon
+		    (let* ((*format-original-arguments* (pop-format-arg))
+			   (*format-arguments* *format-original-arguments*))
+		      (unless (listp *format-arguments*)
+			(format-error "Argument must be a list of lists"))
+		      (sub-format start end))
+		    (sub-format start end)))))))))
+  
+
+
+;;; Justification  ~< ... ~>
+
+;;; Parses a list of clauses delimited by ~; and terminated by ~>.
+;;; Recursively invoke SUB-FORMAT to process them, and return a list
+;;; of the results, the length of this list, and the total number of
+;;; characters in the strings composing the list.
+
+(defun format-get-trailing-segments ()
+  (nextchar)
+  (multiple-value-bind
+   (prev tilde colon atsign parms cmd)
+   (format-find-command '(#\; #\>))
+   (when colon
+     (format-error "~~:; allowed only after first segment in ~~<"))
+   (when (or atsign parms)
+     (format-error "Flags and parameters not allowed"))
+   (let ((str (catch 'format-escape
+		(format-stringify-output (sub-format prev tilde)))))
+     (declare (string str))
+     (if str
+	 (if (char= cmd #\;)
+	     (multiple-value-bind
+	      (segments numsegs numchars)
+	      (format-get-trailing-segments)
+	      (values (cons str segments)
+		      (1+ numsegs) (+ numchars (length str))))
+	     (values (list str) 1 (length str)))
+	 (values () 0 0)))))
+
+
+;;; Gets the first segment, which is treated specially.  Call 
+;;; FORMAT-GET-TRAILING-SEGMENTS to get the rest.
+
+(defun format-get-segments ()
+  (multiple-value-bind
+   (prev tilde parms colon atsign cmd)
+   (format-find-command '(#\; #\>))
+   (when atsign
+     (format-error "Atsign flag not allowed"))
+   (let ((first-seg (format-stringify-output (sub-format prev tilde))))
+     (if (char= cmd #\;)
+	 (multiple-value-bind
+	  (segments numsegs numchars)
+	  (format-get-trailing-segments)
+	  (if colon
+	      (values first-seg parms segments numsegs numchars)
+	      (values nil nil (cons first-seg segments) (1+ numsegs)
+		      (+ (length first-seg) numchars))))
+	 (values nil nil (list first-seg) 1 (length first-seg))))))
+
+
+   
+
+;;; Given the total number of SPACES needed for padding, and the number
+;;; of padding segments needed (PADDINGS), returns a list of such segments.
+;;; We try to allocate the spaces equally to each segment.  When this is
+;;; not possible, allocate any left over spaces to the first segment.
+
+(defun make-pad-segs (spaces padding-segs)
+  (do* ((extra-space () (and (plusp extra-spaces)
+			     extra-inc
+			     (zerop (rem segs extra-inc))))
+	(result () (cons (cond ((= segs 1) (+ min-space extra-spaces))
+			       (extra-space (1+ min-space))
+			       (t min-space))
+			 result))
+	(min-space (truncate spaces padding-segs))
+	(extra-spaces (- spaces (* padding-segs min-space))
+		      (if extra-space
+			  (1- extra-spaces) extra-spaces))
+	(extra-inc (if (plusp extra-spaces)
+		       (truncate spaces extra-spaces)))
+	(segs padding-segs (1- segs)))
+       ((zerop segs) result)))
+  
+
+;;; Determine the actual width to be used for a field requiring WIDTH
+;;; characters according to the following rule:  If WIDTH is less than or
+;;; equal to MINCOL, use WIDTH as the actual width.  Otherwise, round up 
+;;; to MINCOL + k * COLINC for the smallest possible positive integer k.
+
+(defun format-round-columns (width mincol colinc)
+  (if (> width mincol)
+      (multiple-value-bind
+       (quotient remainder)
+       (floor (- width mincol) colinc)
+       (+ mincol (* quotient colinc) (if (zerop remainder) 0 colinc)))
+      mincol))
+
+
+
+(defun format-justification (colon atsign parms)
+  (with-format-parameters parms
+    ((mincol 0) (colinc 1) (minpad 0) (padchar #\space))
+    (unless (and (integerp mincol) (not (minusp mincol)))
+      (format-error "Mincol must be a non-negative integer - ~S" mincol))
+    (unless (and (integerp colinc) (plusp colinc))
+      (format-error "Colinc must be a positive integer - ~S" colinc))
+    (unless (and (integerp minpad) (not (minusp minpad)))
+      (format-error "Minpad must be a non-negative integer - ~S" minpad))
+    (unless (characterp padchar)
+      (format-error "Padchar must be a character - ~S" padchar))
+    (nextchar)
+    (multiple-value-bind
+	(special-arg special-parms segments numsegs numchars)
+	(format-get-segments)
+      (let* ((padsegs (+ (if (or colon (= numsegs 1)) 1 0)
+			 (1- numsegs)
+			 (if (and atsign (or (/= numsegs 1) colon))
+			     1 0)))
+	     (width (format-round-columns (+ numchars (* minpad padsegs))
+					  mincol colinc))
+	     (spaces (append (if (or colon (= numsegs 1)) () '(0))
+			     (make-pad-segs (- width numchars) padsegs)
+			     (if (and atsign (or (/= numsegs 1) colon))
+				 () '(0)))))
+	(when special-arg
+	  (with-format-parameters special-parms ((spare 0)
+						 (linel (or (line-length) 72)))
+	    (let ((pos (or (charpos *standard-output*) 0)))
+	      (when (> (+ pos width spare) linel)
+		(write-string special-arg)))))
+	(cond ((and atsign (= numsegs 1) (not colon))
+	       (write-string (car segments))
+	       (dotimes (i (car spaces)) (write-char padchar)))
+	      (t
+	       (do ((segs segments (cdr segs))
+		    (spcs spaces (cdr spcs)))
+		   ((null segs) (dotimes (i (car spcs)) (write-char padchar)))
+		 (dotimes (i (car spcs)) (write-char padchar))
+		 (write-string (car segs)))))))))
+
+;;; Newline  ~&
+
+(defun format-terpri (colon atsign parms)
+  (when (or colon atsign)
+    (format-error "Flags not allowed"))
+  (with-format-parameters parms ((repeat-count 1))
+    (dotimes (i repeat-count) (terpri))))
+
+
+;;; Fresh-line  ~%
+
+(defun format-freshline (colon atsign parms)
+  (when (or colon atsign)
+    (format-error "Flags not allowed"))
+  (with-format-parameters parms ((repeat-count 1))
+    (fresh-line)
+    (dotimes (i (1- repeat-count)) (terpri))))
+
+
+;;; Page  ~|
+
+(defun format-page (colon atsign parms)
+  (when (or colon atsign)
+    (format-error "Flags not allowed"))
+  (with-format-parameters parms ((repeat-count 1))
+    (dotimes (i repeat-count) (write-char #\form))))
+
+
+;;; Print a tilde  ~~
+
+(defun format-tilde (colon atsign parms)
+  (when (or colon atsign)
+    (format-error "Flags not allowed"))
+  (with-format-parameters parms ((repeat-count 1))
+    (dotimes (i repeat-count) (write-char #\~))))
+
+
+;;; Continue control string on next line  ~<newline>
+
+(defun format-eat-whitespace ()
+  (nextchar)
+  (setq *format-index*
+	(1- (the fixnum
+		 (position-if-not #'(lambda (ch) (or (whitespace-char-p ch)
+						     (char= ch #\linefeed)))
+				  (the simple-string *format-control-string*)
+				  :start *format-index*)))))
+
+
+(defun format-newline (colon atsign parms)
+  (when parms
+    (format-error "Parameters not allowed"))
+  (cond (colon
+	 (when atsign (format-error "~:@<newline> is undefined")))
+	(atsign (terpri)(format-eat-whitespace))
+	(t (format-eat-whitespace))))
+
+
+;;; Pluralize word  ~P
+
+(defun format-plural (colon atsign parms)
+  (when parms
+    (format-error "Parameters not allowed"))
+  (when colon
+    ;; Back up one argument first
+    (let ((cdrs (- (length (the list *format-original-arguments*))
+		   (length (the list *format-arguments*))
+		   1)))
+      (if (minusp cdrs)
+	  (format-error  "No previous argument")
+	  (setq *format-arguments*
+		(nthcdr cdrs *format-original-arguments*)))))
+  (if (eql (pop-format-arg) 1)
+      (write-string (if atsign "y" ""))
+      (write-string (if atsign "ies" "s"))))
+
+
+
+;;; Skip arguments  (relative goto)  ~*
+
+(defun format-skip-arguments (colon atsign parms)
+  (with-format-parameters parms ((count 1))
+    (cond (atsign
+	   (when (or (minusp count)
+		     (> count (length *format-original-arguments*)))
+	     (format-error "Illegal to go to non-existant argument"))
+	   (setq *format-arguments*
+		 (nthcdr count *format-original-arguments*)))
+	  (colon
+	   (let ((cdrs (- (length (the list *format-original-arguments*))
+			  (length (the list *format-arguments*))
+			  count)))
+	     (if (minusp cdrs)
+		 (format-error  "Skip to nonexistant argument")
+		 (setq *format-arguments*
+		       (nthcdr cdrs *format-original-arguments*)))))
+	  (t
+	   (if (> count (length *format-arguments*))
+	       (format-error "Skip to nonexistant argument")
+	       (setq *format-arguments* (nthcdr count *format-arguments*)))))))
+
+  
+
+;;; Indirection  ~?
+
+(defun format-indirection (colon atsign parms)
+  (if (or colon parms) (format-error "Colon flag or parameters not allowed"))
+  (let ((string (pop-format-arg)))
+    (unless (stringp string)
+      (format-error "Indirected control string is not a string"))
+    (format-with-control-string string
+      (if atsign
+	  (sub-format 0 *format-length*)
+	  (let* ((*format-original-arguments* (pop-format-arg))
+		 (*format-arguments* *format-original-arguments*))
+	    (unless (listp *format-arguments*)
+	      (format-error "Argument must be a list"))
+	    (sub-format 0 *format-length*))))))
+
+
+
+;;; Tabulation  ~T
+
+(defun format-tab (colon atsign parms)
+  (with-format-parameters parms ((colnum 1) (colinc 1))
+    (when colon
+      (format-error "Tab-to in pixel units not supported"))
+    (let* ((pos (charpos *standard-output*))
+	   (len (cond (pos (let ((col (if atsign (+ pos colnum) colnum)))
+			     (if (> pos col)
+				 (- colinc (rem (- pos col) colinc))
+				 (- col pos))))
+		      (atsign colnum)
+		      (t 2))))
+      (declare (fixnum len))
+      (do ((i len (- i 40)))
+	  ((<= i 40) (write-string "                                        "
+				   *standard-output* :start 0 :end i))
+	(declare (fixnum i))
+	(write-string "                                        "
+		      *standard-output*
+		      :start 0
+		      :end 40)))))
+
+;;; Ascii  ~A
+
+(defun format-princ (colon atsign parms)
+  (let ((arg (pop-format-arg)))
+    (if (null parms)
+	(if arg (princ arg) (write-string (if colon "()" "NIL")))
+	(with-format-parameters parms
+	   ((mincol 0) (colinc 1) (minpad 0) (padchar #\space))
+	   (format-write-field (if arg
+				   (princ-to-string arg)
+				   (if colon "()" "NIL"))
+			       mincol colinc minpad padchar atsign)))))
+
+
+
+;;; S-expression  ~S
+	    
+(defun format-prin1 (colon atsign parms)
+  (let ((arg (pop-format-arg)))
+    (if (null parms)
+	(if arg (prin1 arg) (write-string (if colon "()" "NIL")))
+	(with-format-parameters parms
+	   ((mincol 0) (colinc 1) (minpad 0) (padchar #\space))
+	   (format-write-field (if arg
+				   (prin1-to-string arg)
+				   (if colon "()" "NIL"))
+			       mincol colinc minpad padchar atsign)))))
+
+
+
+;;; Character  ~C
+
+(defun format-print-character (colon atsign parms)
+  (with-format-parameters parms ()
+    (let ((char (pop-format-arg)))
+      (unless (characterp char)
+	(format-error "Argument must be a character"))
+      (cond ((and atsign (not colon)) (prin1 char))
+	    (t (format-print-named-character char colon))))))
+
+
+(defun format-print-named-character (char longp)
+  (when (char-bit char :control) 
+    (write-string (if longp "Control-" "C-")))
+  (when (char-bit char :meta)
+    (write-string (if longp "Meta-" "M-")))
+  (when (char-bit char :super)
+    (write-string (if longp "Super-" "S-")))
+  (when (char-bit char :hyper)
+    (write-string (if longp "Hyper-" "H-")))
+  (let* ((ch (code-char (char-code char)))	;strip funny bits
+	 (name (char-name ch)))
+    (cond (name (write-string (string-capitalize name)))
+	  ;; Print control characters as "^"<char>
+	  ((<= 0 (the fixnum (char-code char)) 31)
+	   (write-char #\^)
+	   (write-char (code-char (+ 64 (the fixnum (char-code char))))))
+	  (t (write-char ch)))))
+	  
+
+
+
+;;; NUMERIC PRINTING
+
+
+;;; Insert commas after every third digit, scanning from right to left.
+
+(defun format-add-commas (string commachar)
+  (do* ((length (length (the string string)))
+	(new-length (+ length
+		       (the fixnum (floor (the fixnum (1- length)) 3))))
+	(new-string (make-string new-length :initial-element commachar) 
+		    (replace (the string new-string)
+			     (the string string)
+			     :start1 (max 0 (- new-pos 3))
+			     :end1 new-pos
+			     :start2 (max 0 (- pos 3))
+			     :end2 pos))
+	(pos length  (- pos 3))
+	(new-pos new-length (- new-pos 4)))
+       ((not (plusp pos)) new-string)
+    (declare (fixnum length new-length pos new-pos))))
+
+
+;;; Output a string in a field at MINCOL wide, padding with PADCHAR.
+;;; Pads on the left if PADLEFT is true, else on the right.  If the
+;;; length of the string plus the minimum permissible padding, MINPAD,
+;;; is greater than MINCOL, the actual field size is rounded up to
+;;; MINCOL + k * COLINC for the smallest possible positive integer k.
+
+(defun format-write-field (string mincol colinc minpad padchar padleft)
+  (unless (and (integerp mincol) (not (minusp mincol)))
+    (format-error "Mincol must be a non-negative integer - ~S" mincol))
+  (unless (and (integerp colinc) (plusp colinc))
+    (format-error "Colinc must be a positive integer - ~S" colinc))
+  (unless (and (integerp minpad) (not (minusp minpad)))
+    (format-error "Minpad must be a non-negative integer - ~S" minpad))
+  (unless (characterp padchar)
+    (format-error "Padchar must be a character - ~S" padchar))
+  (let* ((strlen (length (the string string)))
+	 (width (format-round-columns (+ strlen minpad) mincol colinc)))
+    (cond (padleft
+	   (dotimes (i (- width strlen)) (write-char padchar))
+	   (write-string string))
+	  (t
+	   (write-string string)
+	   (dotimes (i (- width strlen)) (write-char padchar))))))
+
+
+;;; This functions does most of the work for the numeric printing
+;;; directives.  The parameters are interpreted as defined for ~D.
+
+(defun format-print-number (number radix print-commas-p print-sign-p parms)
+  (with-format-parameters parms
+    ((mincol 0) (padchar #\space) (commachar #\,))
+    (let* ((*print-base* radix)
+	   (text (princ-to-string number)))
+      (if (integerp number)
+	  (format-write-field
+	   (if (and (plusp number) print-sign-p)
+	       (if print-commas-p
+		   (concatenate 'string "+" (format-add-commas text commachar))
+		   (concatenate 'string "+" text))
+	       (if print-commas-p
+		   (format-add-commas text commachar)
+		   text))
+	   mincol 1 0 padchar t)	;colinc = 1, minpad = 0, padleft = t
+	  (write-string text)))))
+
+
+;;; Print a cardinal number in English
+
+
+;;; The following are initialized in FORMAT-INIT to get around cold-loader
+;;; lossage.
+
+(defvar cardinal-ones () "Table of cardinal ones-place digits in English")
+
+(defvar cardinal-tens () "Table of cardinal tens-place digits in English")
+
+(defvar cardinal-teens () "Table of cardinal 'teens' digits in English")
+
+
+(defun format-print-small-cardinal (n)
+  (multiple-value-bind 
+   (hundreds rem) (truncate n 100)
+    (when (plusp hundreds)
+      (write-string (svref cardinal-ones hundreds))
+      (write-string " hundred")
+      (when (plusp rem) (write-char #\space)))    ; ; ; RAD
+    (when (plusp rem)
+      (multiple-value-bind (tens ones)
+			   (truncate rem 10)
+       (cond ((< 1 tens)
+	      (write-string (svref cardinal-tens tens))
+	      (when (plusp ones)
+		(write-char #\-)
+		(write-string (svref cardinal-ones ones))))
+	     ((= tens 1)
+	      (write-string (svref cardinal-teens ones)))
+	     ((plusp ones)
+	      (write-string (svref cardinal-ones ones))))))))
+
+
+(defvar cardinal-periods () "Table of cardinal 'illions' in English")
+
+
+(defun format-print-cardinal (n)
+  (cond ((minusp n)
+	 (write-string "negative ")
+	 (format-print-cardinal-aux (- n) 0 n))
+	((zerop n)
+	 (write-string "zero"))
+	(t (format-print-cardinal-aux n 0 n))))
+
+(defun format-print-cardinal-aux (n period err)
+  (multiple-value-bind (beyond here) (truncate n 1000)
+    (unless (<= period 10)
+      (format-error "Number too large to print in English: ~:D" err))
+    (unless (zerop beyond)
+      (format-print-cardinal-aux beyond (1+ period) err))
+    (unless (zerop here)
+      (unless (zerop beyond) (write-char #\space))
+      (format-print-small-cardinal here)
+      (write-string (svref cardinal-periods period)))))
+
+
+;;; Print an ordinal number in English
+
+
+(defvar ordinal-ones () "Table of ordinal ones-place digits in English")
+
+(defvar ordinal-tens () "Table of ordinal tens-place digits in English")
+
+
+(defun format-print-ordinal (n)
+  (when (minusp n)
+    (write-string "negative "))
+  (let ((number (abs n)))
+    (multiple-value-bind
+     (top bot) (truncate number 100)
+     (unless (zerop top) (format-print-cardinal (- number bot)))
+     (when (and (plusp top) (plusp bot)) (write-char #\space))
+     (multiple-value-bind
+      (tens ones) (truncate bot 10)
+      (cond ((= bot 12) (write-string "twelfth"))
+	    ((= tens 1)
+	     (write-string (svref cardinal-teens ones));;;RAD
+	     (write-string "th"))
+	    ((and (zerop tens) (plusp ones))
+	     (write-string (svref ordinal-ones ones)))
+	    ((and (zerop ones)(plusp tens))
+	     (write-string (svref ordinal-tens tens)))
+	    ((plusp bot)
+	     (write-string (svref cardinal-tens tens))
+	     (write-char #\-)
+	     (write-string (svref ordinal-ones ones)))
+	    ((plusp number) (write-string "th"))
+	    (t (write-string "zeroeth")))))))
+
+
+;;; Print Roman numerals
+
+(defun format-print-old-roman (n)
+  (unless (< 0 n 5000)
+    (format-error "Number too large to print in old Roman numerals: ~:D" n))
+  (do ((char-list '(#\D #\C #\L #\X #\V #\I) (cdr char-list))
+       (val-list '(500 100 50 10 5 1) (cdr val-list))
+       (cur-char #\M (car char-list))
+       (cur-val 1000 (car val-list))
+       (start n (do ((i start (progn (write-char cur-char) (- i cur-val))))
+		    ((< i cur-val) i))))
+      ((zerop start))))
+
+
+(defun format-print-roman (n)
+  (unless (< 0 n 4000)
+    (format-error "Number too large to print in Roman numerals: ~:D" n))
+  (do ((char-list '(#\D #\C #\L #\X #\V #\I) (cdr char-list))
+       (val-list '(500 100 50 10 5 1) (cdr val-list))
+       (sub-chars '(#\C #\X #\X #\I #\I) (cdr sub-chars))
+       (sub-val '(100 10 10 1 1 0) (cdr sub-val))
+       (cur-char #\M (car char-list))
+       (cur-val 1000 (car val-list))
+       (cur-sub-char #\C (car sub-chars))
+       (cur-sub-val 100 (car sub-val))
+       (start n (do ((i start (progn (write-char cur-char) (- i cur-val))))
+		    ((< i cur-val)
+		     (cond ((<= (- cur-val cur-sub-val) i)
+			    (write-char cur-sub-char)
+			    (write-char cur-char)
+			    (- i (- cur-val cur-sub-val)))
+			   (t i))))))
+	  ((zerop start))))
+
+
+
+;;; Decimal  ~D
+
+(defun format-print-decimal (colon atsign parms)
+  (format-print-number (pop-format-arg) 10 colon atsign parms))
+
+
+;;; Binary  ~B
+
+(defun format-print-binary (colon atsign parms)
+  (format-print-number (pop-format-arg) 2 colon atsign parms))
+
+
+;;; Octal  ~O
+
+(defun format-print-octal (colon atsign parms)
+  (format-print-number (pop-format-arg) 8 colon atsign parms))
+
+
+;;; Hexadecimal  ~X
+
+(defun format-print-hexadecimal (colon atsign parms)
+  (format-print-number (pop-format-arg) 16 colon atsign parms))
+
+
+;;; Radix  ~R
+
+(defun format-print-radix (colon atsign parms)
+  (let ((number (pop-format-arg)))
+    (if parms
+	(format-print-number number (pop parms) colon atsign parms)
+	(if atsign
+	    (if colon
+		(format-print-old-roman number)
+		(format-print-roman number))
+	    (if colon
+		(format-print-ordinal number)
+		(format-print-cardinal number))))))
+
+
+;;; FLOATING-POINT NUMBERS
+
+
+;;; Fixed-format floating point  ~F
+
+(defun format-fixed (colon atsign parms)
+  (when colon
+    (format-error "Colon flag not allowed"))
+  (with-format-parameters parms
+    ((w nil) (d nil) (k nil) (ovf nil) (pad #\space))
+    ;;Note that the scale factor k defaults to nil.  This is interpreted as
+    ;;zero by flonum-to-string, but more efficiently.
+    (let ((number (pop-format-arg)))
+      (if (floatp number)
+	  (format-fixed-aux number w d k ovf pad atsign)
+	  (if (rationalp number)
+	      (format-fixed-aux
+	       (coerce number 'short-float) w d k ovf pad atsign)
+	      (let ((*print-base* 10))
+		(format-write-field
+		 (princ-to-string number) w 1 0 #\space t)))))))
+
+
+(defun format-fixed-aux (number w d k ovf pad atsign)
+  (if (not (or w d))
+      (prin1 number)
+      (let ((spaceleft w))
+	(when (and w (or atsign (minusp number))) (decf spaceleft))
+	(multiple-value-bind 
+          (str len lpoint tpoint)
+	  (flonum-to-string (abs number) spaceleft d k)
+	  ;;if caller specifically requested no fraction digits, suppress the
+	  ;;optional trailing zero
+	  (when (and d (zerop d)) (setq tpoint nil))
+	  (when w 
+	    (decf spaceleft len)
+	    ;;optional leading zero
+	    (when lpoint
+	      (if (or (> spaceleft 0) tpoint) ;force at least one digit
+		  (decf spaceleft)
+		  (setq lpoint nil)))
+	    ;;optional trailing zero
+	    (when tpoint
+	      (if (> spaceleft 0)
+		  (decf spaceleft)
+		  (setq tpoint nil))))
+	  (cond ((and w (< spaceleft 0) ovf)
+		 ;;field width overflow
+		 (dotimes (i w) (write-char ovf)))
+		(t (when w (dotimes (i spaceleft) (write-char pad)))
+		   (if (minusp number)
+		       (write-char #\-)
+		       (if atsign (write-char #\+)))
+		   (when lpoint (write-char #\0))
+		   (write-string str)
+		   (when tpoint (write-char #\0))))))))
+
+
+;;; Exponential-format floating point  ~E
+
+
+(defun format-exponential (colon atsign parms)
+  (when colon
+    (format-error "Colon flag not allowed"))
+  (with-format-parameters parms
+    ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (marker nil))
+    (let ((number (pop-format-arg)))
+      (if (floatp number)
+	  (format-exp-aux number w d e k ovf pad marker atsign)
+	  (if (rationalp number)
+	      (format-exp-aux
+	       (coerce number 'short-float) w d e k ovf pad marker atsign)
+	      (let ((*print-base* 10))
+		(format-write-field
+		 (princ-to-string number) w 1 0 #\space t)))))))
+
+
+(defun format-exponent-marker (number)
+  (if (typep number *read-default-float-format*)
+      #\E
+      (typecase number
+	(short-float #\S)
+;	(single-float #\F)
+	(double-float #\D)
+	(long-float #\L))))
+
+
+;;;Here we prevent the scale factor from shifting all significance out of
+;;;a number to the right.  We allow insignificant zeroes to be shifted in
+;;;to the left right, athough it is an error to specify k and d such that this
+;;;occurs.  Perhaps we should detect both these condtions and flag them as
+;;;errors.  As for now, we let the user get away with it, and merely guarantee
+;;;that at least one significant digit will appear.
+
+(defun format-exp-aux (number w d e k ovf pad marker atsign)
+  (if (not (or w d))
+      (prin1 number)
+      (multiple-value-bind (num expt)
+			   (scale-exponent (abs number))
+	(let* ((expt (- expt k))
+	       (estr (princ-to-string (abs expt)))
+	       (elen (if e (max (length estr) e) (length estr)))
+	       (fdig (if d (if (plusp k) (1+ (- d k)) d) nil))
+	       (fmin (if (minusp k) (- 1 k) nil))
+	       (spaceleft (if w (- w 2 elen) nil)))
+	  (when (or atsign (minusp number)) (decf spaceleft))
+	  (if (and w e ovf (> elen e))
+	      ;;exponent overflow
+	      (dotimes (i w) (write-char ovf))
+	      (multiple-value-bind (fstr flen lpoint )			;(tpoint)
+				   (flonum-to-string num spaceleft fdig k fmin)
+		(when w 
+		  (decf spaceleft flen)
+		  ;; (when tpoint (decf spaceleft)) ; deleted as per Rutgers' fix
+		  (when lpoint
+		    (if (> spaceleft 0)
+			(decf spaceleft)
+			(setq lpoint nil))))
+		(cond ((and w (< spaceleft 0) ovf)
+		       ;;significand overflow
+		       (dotimes (i w) (write-char ovf)))
+		      (t (when w
+			   (dotimes (i spaceleft) (write-char pad)))
+			 (if (minusp number)
+			     (write-char #\-)
+			     (if atsign (write-char #\+)))
+			 (when lpoint (write-char #\0))
+			 (write-string fstr)
+			 ;; (when tpoint (write-char #\0)) ; as per Rutgers' fix
+			 (write-char (if marker
+					 marker
+					 (format-exponent-marker number)))
+			 (write-char (if (minusp expt) #\- #\+))
+			 (when e 
+			   ;;zero-fill before exponent if necessary
+			   (dotimes (i (- e (length estr))) (write-char #\0)))
+			 (write-string estr)))))))))
+
+
+
+;;; General Floating Point -  ~G
+
+(defun format-general-float (colon atsign parms)
+  (when colon
+    (format-error "Colon flag not allowed"))
+  (with-format-parameters parms
+    ((w nil) (d nil) (e nil) (k nil) (ovf #\*) (pad #\space) (marker nil))
+    (let ((number (pop-format-arg)))
+      ;;The Excelsior edition does not say what to do if
+      ;;the argument is not a float.  Here, we adopt the
+      ;;conventions used by ~F and ~E.
+      (if (floatp number)
+	  (format-general-aux number w d e k ovf pad marker atsign)
+	  (if (rationalp number)
+	      (format-general-aux
+	       (coerce number 'short-float) w d e k ovf pad marker atsign)
+	      (let ((*print-base* 10))
+		(format-write-field
+		 (princ-to-string number) w 1 0 #\space t)))))))
+
+
+(defun format-general-aux (number w d e k ovf pad marker atsign)
+  (multiple-value-bind (ignore n) 
+		       (scale-exponent (abs number))
+    (declare (ignore ignore))
+    ;;Default d if omitted.  The procedure is taken directly
+    ;;from the definition given in the manual, and is not
+    ;;very efficient, since we generate the digits twice.
+    ;;Future maintainers are encouraged to improve on this.
+    (unless d
+      (multiple-value-bind (str len) 
+			   (flonum-to-string (abs number))
+	(declare (ignore str))
+	(let ((q (if (= len 1) 1 (1- len))))
+	  (setq d (max q (min n 7))))))
+    (let* ((ee (if e (+ e 2) 4))
+	   (ww (if w (- w ee) nil))
+	   (dd (- d n)))
+      (cond ((<= 0 dd d)
+	     (format-fixed-aux number ww dd nil ovf pad atsign)
+	     (dotimes (i ee) (write-char #\space)))
+	    (t (format-exp-aux 
+		 number w d e (or k 1) ovf pad marker atsign))))))
+
+
+;;; Dollars floating-point format  ~$
+
+(defun format-dollars (colon atsign parms)
+  (with-format-parameters parms ((d 2) (n 1) (w 0) (pad #\space))
+    (let ((number (pop-format-arg)))
+      (if (rationalp number) (setq number (coerce number 'short-float)))
+      (if (floatp number)
+	  (let* ((signstr (if (minusp number) "-" (if atsign "+" "")))
+		 (signlen (length signstr)))
+	    (multiple-value-bind (str strlen ig2 ig3 pointplace)
+				 (flonum-to-string number nil d nil)
+	      (declare (ignore ig2 ig3))
+	      (when colon (write-string signstr))
+	      (dotimes (i (- w signlen (- n pointplace) strlen))
+		(write-char pad))
+	      (unless colon (write-string signstr))
+	      (dotimes (i (- n pointplace)) (write-char #\0))
+	      (write-string str)))
+	  (let ((*print-base* 10))
+	    (format-write-field (princ-to-string number) w 1 0 #\space t))))))
+
+
+;;; The following crock simulates some Common Lisp functions in the
+;;; cross-compiler's MACLISP environment for the benefit of the hairy
+;;; dispatch-table initialization macro. The internal representation
+;;; of character objects in the compiler is known to this code.  
+
+#|
+(eval-when (compile-maclisp)
+
+  (setq char-code-limit 256)
+
+  (defun char-downcase (char)
+    (let ((ch (cadr char)))
+      (if (lessp 64 ch 91) (list '**character** (+ ch 32)) char)))
+
+  (defun char-upcase (char)
+    (let ((ch (cadr char)))
+      (if (lessp 96 ch 123) (list '**character** (- ch 32)) char)))
+
+  (defun char= (a b)
+    (= (cadr a) (cadr b)))
+
+  (defun char< (a b)
+    (< (cadr a) (cadr b)))
+
+  (defun char-code (char)
+    (cadr char))
+
+  (defun code-char (code)
+    (list '**character** code)))
+|#
+
+;;; INITIALIZATION
+
+
+;;; Hairy dispatch-table initialization macro.  Takes a list of two-element
+;;; lists (<character> <function-object>) and returns a vector char-code-limit
+;;; elements in length, where the Ith element is the function associated with
+;;; the character with char-code I.  If the character is case-convertible, it
+;;; must be given in only one case; however, an entry in the vector will be
+;;; made for both.
+
+
+(defmacro make-dispatch-vector (&body entries)
+  (let ((entries (mapcan #'(lambda (x)
+			     (let ((lower (char-downcase (car x)))
+				   (upper (char-upcase (car x))))
+			       (if (char= lower upper)
+				   (list x)
+				   (list (cons upper (cdr x))
+					 (cons lower (cdr x))))))
+			 entries)))
+    (do ((entries (sort entries #'(lambda (x y) (char< (car x) (car y)))))
+	 (charidx 0 (1+ charidx))
+	 (comtab () (cons (if entries
+			      (if (= (char-code (caar entries)) charidx)
+				  (cadr (pop entries))
+				  nil)
+			      nil)
+			  comtab)))
+	((= charidx char-code-limit)
+	 (if entries
+	     (error "Garbage in dispatch vector - ~S" entries))
+	 `(vector ,@(nreverse comtab))))))
+
+
+
+;;; These initializations properly belong in the DEFVARs for these objects.
+;;; At present, they must be done after loading due to a limitation in the
+;;; cold loader.
+
+(defun format-init ()
+  (setq cardinal-ones
+	'#(nil "one" "two" "three" "four" "five" "six" "seven" "eight" "nine"))
+  (setq cardinal-tens
+	'#(nil nil "twenty" "thirty" "forty"
+	       "fifty" "sixty" "seventy" "eighty" "ninety"))
+  (setq cardinal-teens
+	'#("ten" "eleven" "twelve" "thirteen" "fourteen"  ;;; RAD
+	       "fifteen" "sixteen" "seventeen" "eighteen" "nineteen"))
+  (setq cardinal-periods
+	'#("" " thousand" " million" " billion" " trillion" " quadrillion"
+	   " quintillion" " sextillion" " septillion" " octillion" " nonillion"
+	   " decillion"))
+  (setq ordinal-ones
+	'#(nil "first" "second" "third" "fourth"
+	       "fifth" "sixth" "seventh" "eighth" "ninth"))
+  (setq ordinal-tens 
+	'#(nil "tenth" "twentieth" "thirtieth" "fortieth"
+	       "fiftieth" "sixtieth" "seventieth" "eightieth" "ninetieth"))
+  (setq *format-dispatch-table*
+	(make-dispatch-vector
+	 (#\B #'format-print-binary)
+	 (#\O #'format-print-octal)
+	 (#\D #'format-print-decimal)
+	 (#\X #'format-print-hexadecimal)
+	 (#\R #'format-print-radix)
+	 (#\F #'format-fixed)
+	 (#\E #'format-exponential)
+         (#\G #'format-general-float)
+	 (#\A #'format-princ)
+	 (#\C #'format-print-character)
+	 (#\P #'format-plural)
+	 (#\S #'format-prin1)
+	 (#\T #'format-tab)
+	 (#\% #'format-terpri)
+	 (#\& #'format-freshline)
+	 (#\* #'format-skip-arguments)
+	 (#\| #'format-page)
+	 (#\~ #'format-tilde)
+	 (#\$ #'format-dollars)
+	 (#\? #'format-indirection)
+	 (#\^ #'format-escape)
+	 (#\[ #'format-condition)
+	 (#\{ #'format-iteration)
+	 (#\< #'format-justification)
+	 (#\( #'format-capitalization)
+	 (#\newline #'format-newline))))
diff --git a/code/gc.lisp b/code/gc.lisp
new file mode 100644
index 000000000..bae155f5c
--- /dev/null
+++ b/code/gc.lisp
@@ -0,0 +1,604 @@
+;;; -*- Mode: Lisp; Package: LISP; Log: code.log -*-
+;;; 
+;;; Replacement for the GC brain damage in misc.lisp
+;;;
+;;; Written by Christopher Hoover.
+;;; 
+
+(in-package "EXTENSIONS")
+(export '(*before-gc-hooks* *after-gc-hooks* gc *ask-about-gc*
+			    *bytes-consed-between-gcs*
+			    *gc-verbose* *gc-notify-before* *gc-notify-after*
+			    *gc-inhibit-hook*
+			    get-bytes-consed))
+
+(in-package "LISP")
+
+
+;;;; Room.
+
+(defvar alloctable-address (int-sap %fixnum-alloctable-address)
+  "A system area pointer that addresses the the alloctable.")
+
+(defun alloc-ref (index)
+  (logior (%primitive 16bit-system-ref alloctable-address (1+ index))
+	  (ash (logand %type-space-mask
+		       (%primitive 16bit-system-ref alloctable-address index))
+	       16)))
+
+(defun space-usage (type)
+  (let ((base (ash type %alloc-ref-type-shift)))
+    (values (alloc-ref base)
+	    (alloc-ref (+ base 8))
+	    (alloc-ref (+ base 12)))))
+
+(defconstant type-space-names
+  '#("Bignum" "Ratio" "Complex" "Short-Float" "Short-Float" "Long-Float"
+     "String" "Bit-Vector" "Integer-Vector" "Code-Vector" "General-Vector"
+     "Array" "Function" "Symbol" "List"))
+
+(defun room-header ()
+  (fresh-line)
+  (princ "       Type        |  Dynamic  |   Static  | Read-Only |   Total")
+  (terpri)
+  (princ "-------------------|-----------|-----------|-----------|-----------")
+  (terpri))
+
+(defun room-summary (dynamic static read-only)
+  (princ "-------------------|-----------|-----------|-----------|-----------")
+  (format t "~% Totals:           |~10:D |~10:D |~10:D =~10:D~%" 
+	  dynamic static read-only (+ static dynamic read-only)))
+
+(defun describe-one-type (type dynamic static read-only)
+  (declare (fixnum type dynamic static read-only))
+  (format t "~18A |~10:D |~10:D |~10:D |~10:D~%"
+	  (elt (the simple-vector type-space-names)
+	       (the fixnum (- type (the fixnum %first-pointer-type))))
+	  dynamic static read-only (the fixnum (+ static dynamic read-only))))
+
+(defun room (&optional (x t) (object nil argp))
+  "Displays information about storage allocation.
+  If X is true then information is displayed broken down by types.
+  If Object is supplied then just display information for objects of
+  that type."
+  (when x
+    (let ((type (%primitive get-type object)))
+      (when (or (> type %last-pointer-type)
+		(< type %first-pointer-type))
+	(error "Objects of type ~S have no allocated storage."
+	       (type-of object)))
+      (room-header)
+      (cond
+       (argp
+	(multiple-value-bind (dyn stat ro)
+			     (space-usage type)
+	  (describe-one-type type dyn stat ro)))
+       (t
+        (let ((cum-dyn 0)
+	      (cum-stat 0)
+	      (cum-ro 0))
+	  (do ((type %first-pointer-type (1+ type)))
+	      ((= type (1+ %last-pointer-type)))
+	    (if (not (or (eq type %short-+-float-type)
+			 (eq type %short---float-type)))
+		(multiple-value-bind (dyn stat ro)
+				     (space-usage type)
+		  (describe-one-type type dyn stat ro)
+		  (incf cum-dyn dyn) (incf cum-stat stat) (incf cum-ro ro))))
+	  (room-summary cum-dyn cum-stat cum-ro)))))))
+
+
+;;;; DYNAMIC-USAGE
+
+;;; 
+;;; DYNAMIC-USAGE -- Interface
+;;;
+;;; Return the number of bytes of dynamic storage allocated.
+;;;
+(defun dynamic-usage ()
+  "Returns the number of bytes of dynamic storage currently allocated."
+  (system:%primitive dynamic-space-in-use))
+
+
+;;; GET-BYTES-CONSED
+
+;;;
+;;; Internal State
+;;; 
+(defvar *last-bytes-in-use* nil)
+(defvar *total-bytes-consed* 0)
+
+;;;
+;;; GET-BYTES-CONSED -- Exported
+;;; 
+(defun get-bytes-consed ()
+  "Returns the number of bytes consed since the first time this function
+  was called.  The first time it is called, it returns zero."
+  (cond ((null *last-bytes-in-use*)
+	 (setq *last-bytes-in-use* (dynamic-usage))
+	 (setq *total-bytes-consed* 0))
+	(t
+	 (let ((bytes (dynamic-usage)))
+	   (incf *total-bytes-consed* (- bytes *last-bytes-in-use*))
+	   (setq *last-bytes-in-use* bytes))))
+  *total-bytes-consed*)
+    
+
+;;;; Variables and Constants
+
+;;;
+;;; DEFAULT-BYTES-CONSED-BETWEEN-GCS
+;;;
+;;; The default value of *BYTES-CONSED-BETWEEN-GCS* and *GC-TRIGGER*.
+;;; This should not be set by the user.
+;;; 
+(defconstant default-bytes-consed-between-gcs 2000000)
+
+;;;
+;;; *BYTES-CONSED-BETWEEN-GCS*
+;;;
+;;; This variable is the user-settable variable that specifices the
+;;; minimum amount of dynamic space which must be consed before a GC
+;;; will be triggered.
+;;; 
+(defvar *bytes-consed-between-gcs* default-bytes-consed-between-gcs
+  "This number specifies the minimum number of bytes of dynamic space
+  that must be consed before the next gc will occur.")
+
+;;;
+;;; *GC-TRIGGER*
+;;; 
+;;; Internal trigger.  When the dynamic usage increases beyond this
+;;; amount, the system notes that a garbage collection needs to occur by
+;;; setting *NEED-TO-COLLECT-GARBAGE* to T.
+;;; 
+(defvar *gc-trigger* default-bytes-consed-between-gcs)
+
+
+
+;;;
+;;; The following specials are used to control when garbage collection
+;;; occurs.
+;;; 
+
+;;; 
+;;; *GC-INHIBIT*
+;;;
+;;; When Y, inhibits garbage collection.
+;;; 
+(defvar *gc-inhibit* nil)
+
+;;;
+;;; *ALREADY-MAYBE-GCING*
+;;;
+;;; This flag is used to prevent recursive entry into the garbage
+;;; collector.
+;;; 
+(defvar *already-maybe-gcing* nil)
+
+;;;
+;;; *NEED-TO-COLLECT-GARBAGE*
+;;;
+;;; When T, indicates that the dynamic usage has exceeded the value
+;;; *GC-TRIGGER*.
+;;; 
+(defvar *need-to-collect-garbage* nil)
+
+
+;;;; GC Hooks
+
+;;;
+;;; *BEFORE-GC-HOOKS*
+;;; *AFTER-GC-HOOKS*
+;;;
+;;; These variables are a list of functions which are run before and
+;;; after garbage collection occurs.
+;;;
+(defvar *before-gc-hooks* nil
+  "A list of functions that are called before garbage collection occurs.
+  The functions should take no arguments.")
+;;; 
+(defvar *after-gc-hooks* nil
+  "A list of functions that are called after garbage collection occurs.
+  The functions should take no arguments.")
+
+;;;
+;;; *GC-INHIBIT-HOOK*
+;;; 
+;;; This hook is invoked whenever SUB-GC intends to GC (unless the GC
+;;; was explicitly forced by calling EXT:GC).  If the hook function
+;;; returns NIL then the GC procedes; otherwise, the GC is inhibited and
+;;; *GC-INHIBIT* and *NEED-TO-COLLECT-GARBAGE* are left bound to T.
+;;; Presumably someone will call GC-ON later to collect the garbage.
+;;;
+(defvar *gc-inhibit-hook* nil
+  "Should be bound to a function or NIL.  If it is a function, this
+  function should take one argument, the current amount of dynamic
+  usage.  The function should return NIL if garbage collection should
+  continue and non-NIL if it should be inhibited.  Use with caution.")
+
+
+
+(defun default-gc-notify-before (bytes-in-use)
+  (system:beep *standard-output*)
+  (format t "~&[GC threshold exceeded with ~:D bytes in use.  ~
+  Commencing GC.]~%" bytes-in-use)
+  (finish-output))
+;;;
+(defparameter *gc-notify-before* #'default-gc-notify-before
+  "This function is invoked before GC'ing with the number of bytes in use.  It
+   notifies the user that the system is going into GC.")
+
+(defun default-gc-notify-after (bytes-retained bytes-freed new-trigger)
+  (format t "[GC completed with ~:D bytes retained and ~:D bytes freed.]~%"
+	  bytes-retained bytes-freed)
+  (format t "[GC will next occur when at least ~:D bytes are in use.]~%"
+	  new-trigger)
+  (system:beep *standard-output*)
+  (finish-output))
+;;;
+(defparameter *gc-notify-after* #'default-gc-notify-after
+  "This function is invoked after GC'ing with the number of bytes freed.  It
+   notifies the user that the system is going into GC.")
+
+
+;;;; Stack grovelling:
+
+;;; VECTOR-ALLOC-END  --  Internal
+;;;
+;;;    Return a pointer to past the end of the memory allocated for a
+;;; vector-like object.
+;;;
+(defun vector-alloc-end (vec)
+  (%primitive pointer+
+	      vec
+	      (* (%primitive vector-word-length vec) %word-size)))
+
+
+(defvar *gc-debug* nil)
+
+;;; PRINT-RAW-ADDR  --  Interface
+;;;
+;;;    Print the full address of an arbitary object.
+;;;
+(defun print-raw-addr (x &optional (stream *standard-output*))
+  (let ((fix (%primitive make-fixnum x)))
+    (format stream "~4,'0X~4,'0X "
+	    (logior (ash (%primitive get-type x) 11)
+		    (ash (%primitive get-space x) 9)
+		    (ash fix -16))
+	    (logand fix #xFFFF))))
+
+
+;;; GC-GROVEL-STACK  --  Internal
+;;;
+;;;    Locate all raw pointers on stack stack, and clobber them with something
+;;; that won't cause GC to gag.  We return a list of lists of the form:
+;;;    (object offset stack-location*),
+;;; 
+;;; where Object is some valid vector-like object pointer and Offset is an
+;;; offset to be added to Object.  The result of this addition should be stored
+;;; into each Stack-Location after GC completes.  We clobber the stack
+;;; locations with Offset for no particular reason (might aid debugging.)
+;;;
+;;; There are three major steps in the algorithm:
+;;;
+;;;  1] Find all the distinct vector-like pointers on the stack, building a
+;;;     list of all the locations that each pointer is stored in.  We do this
+;;;     using two hash-tables: the one for code pointers is separate, since
+;;;     they must be special-cased.
+;;;
+;;;     Note that we do our scan downward from the current CONT, and thus don't
+;;;     scan our own frame.  We don't want to modify the frame for the running
+;;;     function, as this is apt to cause problems.  It isn't necessary to
+;;;     grovel the current frame because we return before GC happens.
+;;;
+;;;  2] Sort all of the vector-like pointers (other than code vectors), and
+;;;     scan through this list finding raw pointers based on the assumption
+;;;     that we will always see the true pointer to the vector header before
+;;;     any raw pointers into that vector.  This exploits our GC invariant that
+;;;     when an indexing temp is in use, the true object pointer must be live
+;;;     on the stack or in a register.  [By now, any register indexing temp
+;;;     will have been saved on the stack.]
+;;;
+;;;     During this scan, we also note any true vector pointers that point to a
+;;;     function object.
+;;;
+;;;     Whenever we locate a raw vector pointer, we create a fixup for the
+;;;     locations holding that pointer and then clobber the locations.
+;;;
+;;;  3] Iterate over all code pointers, clobbering the locations and
+;;;     making fixups for those pointers that point inside some function object
+;;;     that appears on the stack.  This exploits our GC invariant that a
+;;;     *valid* code pointer only appears on the stack when some containing
+;;;     function object also appears on the stack.  Note that *invalid* code
+;;;     pointers may appear in the stack garbage unaccompanied by any function
+;;;     object.  Such isolated code pointers are set to 0.  (Code pointers in
+;;;     the heap must always point to the code vector header, and are always
+;;;     considered valid.)
+;;;
+;;;     This different invariant for code pointers allows us to throw around
+;;;     raw code pointers without clearing them when they are no longer needed.
+;;;
+(defun gc-grovel-stack ()
+  (let ((vec-table (make-hash-table :test #'eq))
+	(code-table (make-hash-table :test #'eq))
+	(base (%primitive make-immediate-type 0 %control-stack-type))
+	(fixups ()))
+    ;;
+    ;; Find all vector-like objects on the stack, putting code vectors in a
+    ;; separate table. (step 1)
+    (do ((sp (%primitive pointer+ (%primitive current-cont)
+			 (- %stack-increment))
+	     (%primitive pointer+ sp (- %stack-increment))))
+	((%primitive pointer< sp base))
+      (let* ((el (%primitive read-control-stack sp))
+	     (el-type (%primitive get-type el)))
+	
+	(when (and *gc-debug* (simple-vector-p el))
+	  (let ((hdr (%primitive read-control-stack el)))
+	    (unless (and (fixnump hdr) (> hdr 0)
+			 (<= (length el) #xFFFF)
+			 (<= (%primitive get-vector-subtype el)
+			     3))
+	      (format t "Suspicious G-vector ")
+	      (print-raw-addr el)
+	      (format t "at ")
+	      (print-raw-addr sp)
+	      (terpri))))
+
+	(when (and (< (%primitive get-space el) %static-space)
+		   (<= %string-type el-type %function-type))
+	  (push sp (gethash el
+			    (if (eq el-type %code-type)
+				code-table
+				vec-table))))))
+
+    (let ((vecs ())
+	  (functions ()))
+      (maphash #'(lambda (k v)
+		   (declare (ignore v))
+		   (push k vecs))
+	       vec-table)
+
+      (setq vecs
+	    (sort vecs
+		  #'(lambda (x y)
+		      (%primitive pointer< x y))))
+
+      ;;
+      ;; Iterate over non-code vector-like pointers in order (step 2.)
+      (loop
+	(unless vecs (return))
+	(let* ((base (pop vecs))
+	       (end (vector-alloc-end base)))
+	  
+	  (when (and (= (%primitive get-type base) %function-type)
+		     (<= %function-entry-subtype
+			 (%primitive get-vector-subtype base)
+			 %function-constants-subtype))
+	    (push base functions))
+
+	  (loop
+	    (unless vecs (return))
+	    (let ((next (first vecs)))
+	      (unless (%primitive pointer< next end) (return))
+	      (pop vecs)
+	      
+	      (let ((offset (%primitive pointer- next base))
+		    (sps (gethash next vec-table)))
+		(dolist (sp sps)
+		  (%primitive write-control-stack sp offset))
+		(push (list* base offset sps) fixups))))))
+
+      ;;
+      ;; Iterate over all code pointers (step 3.)
+      (maphash #'(lambda (code-ptr sps)
+		   (dolist (fun functions
+				(dolist (sp sps)
+				  (%primitive write-control-stack sp 0)))
+		     (let* ((base (%primitive header-ref fun
+					      %function-code-slot))
+			    (end (vector-alloc-end base)))
+		       (when (and (not (%primitive pointer< code-ptr base))
+				  (%primitive pointer< code-ptr end))
+			 (let ((offset (%primitive pointer- code-ptr base)))
+			   (dolist (sp sps)
+			     (%primitive write-control-stack sp offset))
+			   (push (list* base offset sps) fixups))
+			 (return)))))
+	       code-table)
+
+      (when *gc-debug*
+	(dolist (f fixups)
+	  (terpri)
+	  (print-raw-addr (first f))
+	  (format t "~X " (second f))
+	  (dolist (sp (cddr f))
+	    (print-raw-addr sp)))
+	(terpri))
+
+      fixups)))
+
+
+;;; GC-FIXUP-STACK  --  Internal
+;;;
+;;;    Given a list of GC fixups as returned by GC-GROVEL-STACK, fix up all the
+;;; raw pointers on the stack.
+;;;
+(defun gc-fixup-stack (fixups)
+  (dolist (fixup fixups)
+    (let ((new (%primitive pointer+ (first fixup) (second fixup))))
+      (dolist (sp (cddr fixup))
+	(%primitive write-control-stack sp new)))))
+
+
+;;;; Internal GC
+
+;;; %GC  --  Internal
+;;;
+;;; %GC is the real garbage collector.  What we do:
+;;;  -- Call GC-GROVEL-STACK to locate any raw pointers on the stack.
+;;;  -- Invoke the COLLECT-GARBAGE miscop, adding the amount of garbage
+;;;     collected to *total-bytes-consed*.
+;;;  -- Invalidate & revalidate the old spaces to free up their memory.
+;;;  -- Call GC-FIXUP-STACK to restore raw pointers on the stack.
+;;;
+;;; *** Warning: the stack *including the current frame* is in a somewhat
+;;; altered state until after GC-FIXUP-STACK is called.  Don't change a single
+;;; character from the start of this function until after call to
+;;; GC-FIXUP-STACK unless you really know what you are doing.
+;;;
+;;; It is important that we not do anything that creates raw pointers between
+;;; the time we call GC-GROVEL-STACK and the time we invoke COLLECT-GARBAGE.
+;;; In particular, this means no function calls.  All raw pointers on the stack
+;;; have been trashed, so we cannot use any raw pointers until they have been
+;;; regenerated.  In particular, we cannot return from this function, since the
+;;; return PC is a raw pointer.
+;;;
+;;; We also can't expect the value of any variables allocated between the
+;;; grovel and fixup to persist after the fixup, since the value that variable
+;;; held at grovel time may have been a pointer that needed to be fixed.
+;;;
+(defun %gc ()
+  (let* ((oldspace-base (ash (%primitive newspace-bit) 25))
+	 (old-bytes (system:%primitive dynamic-space-in-use))
+	 (result nil)
+	 (fixups (gc-grovel-stack)))
+    (%primitive clear-registers)
+    (setq result (%primitive collect-garbage))
+    (let ((new-bytes (system:%primitive dynamic-space-in-use)))
+      (when *last-bytes-in-use*
+	(incf *total-bytes-consed* (- old-bytes *last-bytes-in-use*))
+	(setq *last-bytes-in-use* new-bytes)))
+    (gc-fixup-stack fixups)
+    (do* ((i %first-pointer-type (1+ i))
+	  (this-space (logior oldspace-base (ash i 27))
+		      (logior oldspace-base (ash i 27)))
+	  (losing-gr nil))
+	 ((= i (1+ %last-pointer-type))
+	  (when losing-gr
+	    (system:gr-error "While reclaiming VM" losing-gr)))
+      (let ((gr (mach:vm_deallocate *task-self* this-space
+				    (- #x2000000 8192))))
+	(unless (eql gr mach:kern-success) (setq losing-gr gr)))
+      (let ((gr (mach:vm_allocate *task-self* this-space
+				  (- #x2000000 8192) nil)))
+	(unless (eql gr mach:kern-success) (setq losing-gr gr))))
+    result))
+
+;;;
+;;; *INTERNAL-GC*
+;;;
+;;; This variables contains the function that does the real GC.  This is
+;;; for low-level GC experimentation.  Do not touch it if you do not
+;;; know what you are doing.
+;;; 
+(defvar *internal-gc* #'%gc)
+
+
+;;;; SUB-GC
+
+;;;
+;;; CAREFULLY-FUNCALL -- Internal
+;;;
+;;; Used to carefully invoke hooks.
+;;; 
+(defmacro carefully-funcall (function &rest args)
+  `(handler-case (funcall ,function ,@args)
+     (error (cond)
+       (warn "(FUNCALL ~S~{ ~S~}) lost:~%~A" ',function ',args cond)
+       nil)))
+
+;;;
+;;; SUB-GC -- Internal
+;;;
+;;; SUB-GC decides when and if to do a garbage collection.  The
+;;; VERBOSE-P flag controls whether or not the notify functions are
+;;; called.  The FORCE-P flags controls if a GC should occur even if the
+;;; dynamic usage is not greater than *GC-TRIGGER*.
+;;; 
+(defun sub-gc (verbose-p force-p)
+  (unless *already-maybe-gcing*
+    (let* ((*already-maybe-gcing* t)
+	   (pre-gc-dyn-usage (dynamic-usage)))
+      (unless (integerp *bytes-consed-between-gcs*)
+	(warn "The value of *BYTES-CONSED-BETWEEN-GCS*, ~S, is not an ~
+	integer.  Reseting it to 2000000" *bytes-consed-between-gcs*)
+	(setf *bytes-consed-between-gcs* default-bytes-consed-between-gcs))
+      (when (> *bytes-consed-between-gcs* *gc-trigger*)
+	(setf *gc-trigger* *bytes-consed-between-gcs*))
+      (when (> pre-gc-dyn-usage *gc-trigger*)
+	(setf *need-to-collect-garbage* t))
+      (when (or force-p
+		(and *need-to-collect-garbage* (not *gc-inhibit*)))
+	(setf *gc-inhibit* t) ; Set *GC-INHIBIT* to T before calling the hook
+	(when (and (not force-p)
+		   *gc-inhibit-hook*
+		   (carefully-funcall *gc-inhibit-hook* pre-gc-dyn-usage))
+	  (return-from sub-gc nil))
+	(setf *gc-inhibit* nil) ; Reset *GC-INHIBIT*
+	(multiple-value-bind
+	    (winp old-mask)
+	    (mach:unix-sigsetmask lockout-interrupts)
+	  (unwind-protect
+	      (progn
+		(unless winp (warn "Could not set sigmask!"))
+		(let ((*standard-output* *terminal-io*))
+		  (when verbose-p
+		    (carefully-funcall *gc-notify-before* pre-gc-dyn-usage))
+		  (dolist (hook *before-gc-hooks*)
+		    (carefully-funcall hook))
+		  (funcall *internal-gc*)
+		  (let* ((post-gc-dyn-usage (dynamic-usage))
+			 (bytes-freed (- pre-gc-dyn-usage post-gc-dyn-usage)))
+		    (setf *need-to-collect-garbage* nil)
+		    (setf *gc-trigger*
+			  (+ post-gc-dyn-usage *bytes-consed-between-gcs*))
+		    (dolist (hook *after-gc-hooks*)
+		      (carefully-funcall hook))
+		    (when verbose-p
+		      (carefully-funcall *gc-notify-after*
+					 post-gc-dyn-usage bytes-freed
+					 *gc-trigger*)))))
+	    (when winp
+	      (unless (values (mach:unix-sigsetmask old-mask))
+		(warn "Could not restore sigmask!"))))))))
+  nil)
+
+;;;
+;;; MAYBE-GC -- Internal
+;;; 
+;;; This routine is called by the allocation miscops to decide if a GC
+;;; should occur.  The argument, object, is the newly allocated object
+;;; which must be returned to the caller.
+;;; 
+(defun maybe-gc (object)
+  (sub-gc t nil)
+  object)
+
+;;;
+;;; GC -- Exported
+;;;
+;;; This is the user advertised garbage collection function.
+;;; 
+(defun gc (&optional (verbose-p t))
+  "Initiates a garbage collection.  The optional argument, VERBOSE-P,
+  controls wether or not GC statistics are printed."
+  (sub-gc verbose-p t)
+  nil)
+
+
+;;;; Auxiliary Functions
+
+(defun gc-on ()
+  "Enables the garbage collector."
+  (setq *gc-inhibit* nil)
+  (when *need-to-collect-garbage*
+    (sub-gc t nil))
+  nil)
+
+(defun gc-off ()
+  "Disables the garbage collector."
+  (setq *gc-inhibit* t)
+  nil)
diff --git a/code/globals.lisp b/code/globals.lisp
new file mode 100644
index 000000000..696759b87
--- /dev/null
+++ b/code/globals.lisp
@@ -0,0 +1,56 @@
+;;; -*- Package: Lisp; Log: code.log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;;    This file contains special proclamations for variables that are
+;;; referenced in the code sources before they are defined.  There is also a
+;;; function proclamation to make some common functions be known, avoiding
+;;; large amounts of work in recording the calls that are done before the
+;;; definition.
+;;;
+;;; Written by Rob MacLachlan
+;;;
+(in-package 'lisp)
+
+(proclaim '(special *keyword-package* *lisp-package* *package* *query-io*
+		    *terminal-io* *error-output* *trace-output* *debug-io*
+		    *standard-input* *standard-output* *file-input-handlers*
+		    *hemlock-version* *evalhook* *applyhook*
+		    *task-self* *command-line-switches*
+		    *command-switch-demons* ext::temporary-foreign-files
+		    *display-event-handlers* original-lisp-environment
+		    *environment-list* 
+		    *read-default-float-format* *read-suppress* *readtable*
+		    *print-base* *print-radix* *print-length* *print-level*
+		    *print-pretty* *print-escape* *print-case* *print-circle*
+		    *print-gensym* *print-array*
+		    defmacro-error-string defsetf-error-string
+		    std-lisp-readtable
+		    hi::*in-the-editor* debug::*in-the-debugger*
+		    mach::*free-trap-arg-blocks* conditions::*handler-clusters*
+		    conditions::*restart-clusters*
+		    alloctable-address ext::*c-type-names* *gc-inhibit*
+		    *need-to-collect-garbage*
+		    defmacro-error-string deftype-error-string
+		    defsetf-error-string %sp-interrupts-inhibited
+		    *software-interrupt-vector* *load-verbose*
+		    *load-print-stuff* *in-compilation-unit*
+		    *aborted-compilation-units*
+
+		    ;; hack to get these args to with-trap-arg-block to work in
+		    ;; the bootstrapping env, since the var must be known to be
+		    ;; special, in addition to being known to be an alien var.
+		    mach::timeval mach::timezone mach::int1 mach::int2
+		    mach::int3 mach::tchars mach::ltchars))
+
+
+(proclaim '(ftype (function (&rest t) *)
+		  c::%%defun c::%%defmacro c::%%defconstant c::%defstruct
+		  c::%%compiler-defstruct c::get-info-value c::set-info-value
+		  find-keyword keyword-test assert-error assert-prompt
+		  check-type-error case-body-error))
diff --git a/code/hash.lisp b/code/hash.lisp
new file mode 100644
index 000000000..7ecea07d1
--- /dev/null
+++ b/code/hash.lisp
@@ -0,0 +1,429 @@
+;;; -*- Log: code.log; Package: Lisp -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; Hashing and hash table functions for Spice Lisp.
+;;; Written by Skef Wholey.
+;;;
+(in-package 'lisp)
+(export '(hash-table hash-table-p make-hash-table
+	  gethash remhash maphash clrhash
+	  hash-table-count sxhash))
+
+;;; What a hash-table is:
+
+(defstruct (hash-table (:constructor make-hash-table-structure)
+		       (:conc-name hash-table-)
+		       (:print-function %print-hash-table))
+  "Structure used to implement hash tables."
+  (kind 'eq)
+  (size 65 :type fixnum)
+  (rehash-size 101)				; might be a float
+  (rehash-threshold 57 :type fixnum)
+  (number-entries 0 :type fixnum)
+  (table () :type simple-vector))
+
+;;; A hash-table-table is a vector of association lists.  When an
+;;; entry is made in a hash table, a pair of (key . value) is consed onto
+;;; the element in the vector arrived at by hashing.
+
+;;; How to print one:
+
+(defun %print-hash-table (structure stream depth)
+  (declare (ignore depth))
+  (format stream "#<~A Hash Table {~X}>"
+	  (symbol-name (hash-table-kind structure))
+	  (system:%primitive lisp::make-fixnum structure)))
+
+
+
+;;; Hashing functions for the three kinds of hash tables:
+
+(eval-when (compile)
+
+(defmacro eq-hash (object)
+  "Gives us a hashing of an object such that (eq a b) implies
+   (= (eq-hash a) (eq-hash b))"
+  `(%primitive make-fixnum ,object))
+
+(defmacro eql-hash (object)
+  "Gives us a hashing of an object such that (eql a b) implies
+   (= (eql-hash a) (eql-hash b))"
+  `(if (numberp ,object)
+       (logand (truncate ,object) most-positive-fixnum)
+       (%primitive make-fixnum ,object)))
+
+(defmacro equal-hash (object)
+  "Gives us a hashing of an object such that (equal a b) implies
+   (= (equal-hash a) (equal-hash b))"
+  `(sxhash ,object))
+
+)
+
+;;; Rehashing functions:
+
+(defun almost-primify (num)
+  (declare (fixnum num))
+  "Almost-Primify returns an almost prime number greater than or equal
+   to NUM."
+  (if (= (rem num 2) 0)
+      (setq num (+ 1 num)))
+  (if (= (rem num 3) 0)
+      (setq num (+ 2 num)))
+  (if (= (rem num 7) 0)
+      (setq num (+ 4 num)))
+  num)
+
+(eval-when (compile)
+
+(defmacro grow-size (table)
+  "Returns a fixnum for the next size of a growing hash-table."
+  `(let ((rehash-size (hash-table-rehash-size ,table)))
+     (if (floatp rehash-size)
+	 (ceiling (* rehash-size (hash-table-size ,table)))
+	 (+ rehash-size (hash-table-size ,table)))))
+
+(defmacro grow-rehash-threshold (table new-length)
+  "Returns the next rehash threshold for the table."
+  table
+  `,new-length
+;  `(ceiling (* (hash-table-rehash-threshold ,table)
+;	       (/ ,new-length (hash-table-size ,table))))
+  )
+
+(defmacro hash-set (vector key value length hashing-function)
+  "Used for rehashing.  Enters the value for the key into the vector
+   by hashing.  Never grows the vector.  Assumes the key is not yet
+   entered."
+  `(let ((index (rem (the fixnum (funcall ,hashing-function ,key))
+		     (the fixnum ,length))))
+     (declare (fixnum index))
+     (setf (aref (the simple-vector ,vector) index)
+	   (cons (cons ,key ,value)
+		 (aref (the simple-vector ,vector) index)))))
+
+)
+
+(defun rehash (structure hash-vector new-length)
+  (declare (simple-vector hash-vector))
+  (declare (fixnum new-length))
+  "Rehashes a hash table and replaces the TABLE entry in the structure if
+   someone hasn't done so already.  New vector is of NEW-LENGTH."
+  (do ((new-vector (make-array new-length))
+       (i 0 (1+ i))
+       (size (hash-table-size structure))
+       (hashing-function (case (hash-table-kind structure)
+			   (eq #'(lambda (x) (eq-hash x)))
+			   (eql #'(lambda (x) (eql-hash x)))
+			   (equal #'(lambda (x) (equal-hash x))))))
+      ((= i size)
+       (cond ((eq hash-vector (hash-table-table structure))
+	      (cond ((> new-length size)
+		     (setf (hash-table-table structure) new-vector)
+		     (setf (hash-table-rehash-threshold structure)
+			   (grow-rehash-threshold structure new-length))
+		     (setf (hash-table-size structure) new-length))
+		    (t
+		     (setf (hash-table-table structure) new-vector)))
+	      (if (not (eq (hash-table-kind structure) 'equal))
+		  (%primitive set-vector-subtype new-vector
+			      (+ 2 (%primitive newspace-bit)))))))
+    (declare (fixnum i size))
+    (do ((bucket (aref hash-vector i) (cdr bucket)))
+	((null bucket))
+      (hash-set new-vector (caar bucket) (cdar bucket) new-length
+		hashing-function))
+    (setf (aref hash-vector i) nil)))
+
+;;; Macros for Gethash, %Puthash, and Remhash:
+
+(eval-when (compile)
+
+;;; Hashop dispatches on the kind of hash table we've got, rehashes if
+;;; necessary, and binds Vector to the hash vector, Index to the index
+;;; into that vector that the Key points to, and Size to the size of the
+;;; hash vector.  Since Equal hash tables only need to be maybe rehashed
+;;; sometimes, one can tell it if it's one of those times with the
+;;; Equal-Needs-To-Rehash-P argument.
+
+(defmacro hashop (equal-needs-to-rehash-p eq-body eql-body equal-body)
+  `(let* ((vector (hash-table-table hash-table))
+	  (size (length vector)))
+     (declare (simple-vector vector) (fixnum size)
+	      (inline assoc))
+     (case (hash-table-kind hash-table)
+       (equal
+	,@(if equal-needs-to-rehash-p `((equal-rehash-if-needed)))
+	(let ((index (rem (the fixnum (equal-hash key)) size)))
+	  (declare (fixnum index))
+	  ,equal-body))
+       (eq
+	(without-gcing
+	  (eq-rehash-if-needed)
+	  (let ((index (rem (the fixnum (eq-hash key)) size)))
+	    (declare (fixnum index))
+	    ,eq-body)))
+       (eql
+	(without-gcing
+	  (eq-rehash-if-needed)
+	  (let ((index (rem (the fixnum (eql-hash key)) size)))
+	    (declare (fixnum index))
+	    ,eql-body))))))
+
+(defmacro eq-rehash-if-needed ()
+  `(let ((subtype (%primitive get-vector-subtype vector)))
+     (declare (fixnum subtype))
+     (cond ((or (= subtype 4)
+		(/= subtype (+ 2 (%primitive newspace-bit))))
+	    (rehash hash-table vector size)
+	    (setq vector (hash-table-table hash-table)))
+	   ((> (hash-table-number-entries hash-table)
+	       (hash-table-rehash-threshold hash-table))
+	    (rehash hash-table vector (grow-size hash-table))
+	    (setq vector (hash-table-table hash-table))
+	    (setq size (length vector))))))
+
+(defmacro equal-rehash-if-needed ()
+  `(cond ((> (hash-table-number-entries hash-table)
+	     (hash-table-rehash-threshold hash-table))
+	  (rehash hash-table vector (grow-size hash-table))
+	  (setq vector (hash-table-table hash-table))
+	  (setq size (length vector)))))
+
+(defmacro rehash-if-needed ()
+  `(let ((subtype (%primitive get-vector-subtype vector))
+	 (size (length vector)))
+     (declare (fixnum subtype size))
+     (cond ((and (not (eq (hash-table-kind hash-table) 'equal))
+		 (or (= subtype 4)
+		     (/= subtype (the fixnum (+ 2 (the fixnum (%primitive newspace-bit)))))))
+	    (rehash hash-table vector size)
+	    (setq vector (hash-table-table hash-table))
+	    (setq size (length vector)))
+	   ((> (hash-table-number-entries hash-table)
+	       (hash-table-rehash-threshold hash-table))
+	    (rehash hash-table vector (grow-size hash-table))
+	    (setq vector (hash-table-table hash-table))
+	    (setq size (length vector))))))
+
+)
+
+;;; Making hash tables:
+
+(defun make-hash-table (&key (test 'eql) (size 65) (rehash-size 101)
+			     rehash-threshold)
+  "Creates and returns a hash table.  See manual for details."
+  (declare (fixnum size))
+  (cond ((eq test #'eq) (setq test 'eq))
+	((eq test #'eql) (setq test 'eql))
+	((eq test #'equal) (setq test 'equal)))
+  (if (not (memq test '(eq eql equal)))
+      (error "~S is an illegal :Test for hash tables." test))
+  (setq size (if (<= size 37) 37 (almost-primify size)))
+  (cond ((null rehash-threshold)
+	 (setq rehash-threshold size))
+	((floatp rehash-threshold)
+	 (setq rehash-threshold (ceiling (* rehash-threshold size)))))
+  (make-hash-table-structure :size size
+			     :rehash-size rehash-size
+			     :rehash-threshold rehash-threshold
+			     :table
+			     (if (eq test 'equal)
+				 (make-array size)
+				 (%primitive set-vector-subtype
+				  (make-array size)
+				  (the fixnum (+ 2 (the fixnum (%primitive newspace-bit))))))
+			     :kind test)))
+
+;;; Manipulating hash tables:
+
+(defun gethash (key hash-table &optional default)
+  "Finds the entry in Hash-Table whose key is Key and returns the associated
+   value and T as multiple values, or returns Default and Nil if there is no
+   such entry."
+  (macrolet ((lookup (test)
+	       `(let ((cons (assoc key (aref vector index) :test #',test)))
+		  (declare (list cons))
+		  (if cons
+		      (values (cdr cons) t)
+		      (values default nil)))))
+    (hashop nil
+      (lookup eq)
+      (lookup eql)
+      (lookup equal))))
+
+(defun %puthash (key hash-table value)
+  "Create an entry in HASH-TABLE associating KEY with VALUE; if there already
+   is an entry for KEY, replace it.  Returns VALUE."
+  (macrolet ((store (test)
+	       `(let ((cons (assoc key (aref vector index) :test #',test)))
+		  (declare (list cons))
+		  (cond (cons (setf (cdr cons) value))
+			(t
+			 (push (cons key value) (aref vector index))
+			 (incf (hash-table-number-entries hash-table))
+			 value)))))
+    (hashop t
+      (store eq)
+      (store eql)
+      (store equal))))
+
+(defun remhash (key hash-table)
+  "Remove any entry for KEY in HASH-TABLE.  Returns T if such an entry
+   existed; () otherwise."
+  (hashop nil
+   (let ((bucket (aref vector index)))		; EQ case
+     (cond ((and bucket (eq (caar bucket) key))
+	    (pop (aref vector index))
+	    (decf (hash-table-number-entries hash-table))
+	    t)
+	   (t
+	    (do ((last bucket bucket)
+		 (bucket (cdr bucket) (cdr bucket)))
+		((null bucket) ())
+	      (when (eq (caar bucket) key)
+		(rplacd last (cdr bucket))
+		(decf (hash-table-number-entries hash-table))
+		(return t))))))
+   (let ((bucket (aref vector index)))		; EQL case
+     (cond ((and bucket (eql (caar bucket) key))
+	    (pop (aref vector index))
+	    (decf (hash-table-number-entries hash-table))
+	    t)
+	   (t
+	    (do ((last bucket bucket)
+		 (bucket (cdr bucket) (cdr bucket)))
+		((null bucket) ())
+	      (when (eql (caar bucket) key)
+		(rplacd last (cdr bucket))
+		(decf (hash-table-number-entries hash-table))
+		(return t))))))
+   (let ((bucket (aref vector index)))		; EQUAL case
+     (cond ((and bucket (equal (caar bucket) key))
+	    (pop (aref vector index))
+	    (decf (hash-table-number-entries hash-table))
+	    t)
+	   (t
+	    (do ((last bucket bucket)
+		 (bucket (cdr bucket) (cdr bucket)))
+		((null bucket) ())
+	      (when (equal (caar bucket) key)
+		(rplacd last (cdr bucket))
+		(decf (hash-table-number-entries hash-table))
+		(return t))))))))
+
+(defun maphash (map-function hash-table)
+  "For each entry in HASH-TABLE, calls MAP-FUNCTION on the key and value
+  of the entry; returns T."
+  (let ((vector (hash-table-table hash-table)))
+    (declare (simple-vector vector))
+    (rehash-if-needed)
+    (do ((i 0 (1+ i))
+	 (size (hash-table-size hash-table)))
+	((= i size))
+      (declare (fixnum i size))
+      (do ((bucket (aref vector i) (cdr bucket)))
+	  ((null bucket))
+	
+	(funcall map-function (caar bucket) (cdar bucket))))))
+
+(defun clrhash (hash-table)
+  "Removes all entries of HASH-TABLE and returns the hash table itself."
+  (let ((vector (hash-table-table hash-table)))
+    (declare (simple-vector vector))
+    (setf (hash-table-number-entries hash-table) 0)
+    (do ((i 0 (1+ i))
+	 (size (hash-table-size hash-table)))
+	((= i size) hash-table)
+      (declare (fixnum i size))
+      (setf (aref vector i) nil))))
+
+(defun hash-table-count (hash-table)
+  "Returns the number of entries in the given Hash-Table."
+  (hash-table-number-entries hash-table))
+
+;;; Primitive Hash Function
+
+;;; The maximum length and depth to which we hash lists.
+(defconstant sxhash-max-len 7)
+(defconstant sxhash-max-depth 3)
+
+(eval-when (compile eval)
+
+;;; We could use a rotate function here, but that isn't in ucode, so
+;;; instead we Xor the number with a lsh'ed version of itself...
+;;;
+(defmacro sxmash (x num)
+  (let ((n-x (gensym)))
+    `(let ((,n-x ,x))
+       (declare (fixnum ,n-x))
+       (abs (logxor (the fixnum (%primitive lsh ,n-x ,num)) ,n-x)))))
+
+(defmacro sxhash-simple-string (sequence)
+  `(%primitive sxhash-simple-string ,sequence))
+
+(defmacro sxhash-string (sequence)
+  (let ((data (gensym))
+	(start (gensym))
+	(end (gensym)))
+    `(with-array-data ((,data ,sequence)
+		       (,start)
+		       (,end (%primitive header-ref ,sequence
+					 %array-fill-pointer-slot)))
+       (if (zerop ,start)
+	   (%primitive sxhash-simple-substring ,data ,end)
+	   (sxhash-simple-string (coerce (the string ,sequence)
+					 'simple-string))))))
+
+(defmacro sxhash-list (sequence depth)
+  `(if (= ,depth sxhash-max-depth)
+       0
+       (do ((sequence ,sequence (cdr (the list sequence)))
+	    (index 0 (1+ index))
+	    (hash 2))
+	   ((or (atom sequence) (= index sxhash-max-len)) hash)
+	 (declare (fixnum hash index))
+	 (setq hash
+	       (sxmash
+		(logxor
+		 hash
+		 (internal-sxhash (car sequence) (1+ ,depth)))
+		7)))))
+
+); eval-when (compile eval)
+
+
+;;; This multi-level type dispatch is faster, since typecase doesn't
+;;; turn into a real dispatch.
+;;;
+(defun sxhash (s-expr)
+  "Computes a hash code for S-EXPR and returns it as an integer."
+  (internal-sxhash s-expr 0))
+
+(defun internal-sxhash (s-expr depth)
+  (typecase s-expr
+    (array
+     (typecase s-expr
+       (simple-string (sxhash-simple-string s-expr))
+       (string (sxhash-string s-expr))
+       (t (array-rank s-expr))))
+    (symbol (sxhash-simple-string (symbol-name s-expr)))
+    (list (sxhash-list s-expr depth))
+    (number
+     (etypecase s-expr
+       (integer (ldb (byte 23 0) s-expr))
+       (float (multiple-value-bind (significand exponent)
+				   (integer-decode-float s-expr)
+		(logxor (the fixnum (ldb (byte 23 0) significand))
+			(the fixnum (ldb (byte 23 0) exponent)))))
+       (ratio (the fixnum (+ (internal-sxhash (numerator s-expr) 0)
+			     (internal-sxhash (denominator s-expr) 0))))
+       (complex (the fixnum (+ (internal-sxhash (realpart s-expr) 0)
+			       (internal-sxhash (imagpart s-expr) 0))))))
+    (compiled-function (%primitive header-length s-expr))
+    (t (%primitive make-fixnum s-expr))))
diff --git a/code/lispinit.lisp b/code/lispinit.lisp
new file mode 100644
index 000000000..a531eb996
--- /dev/null
+++ b/code/lispinit.lisp
@@ -0,0 +1,1212 @@
+;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; Initialization and low-level interrupt support for the Spice Lisp system.
+;;; Written by Skef Wholey and Rob MacLachlan.
+;;;
+(in-package "LISP" :use '("SYSTEM" "DEBUG"))
+
+(in-package "XLIB")
+
+(in-package "LISP")
+
+(export '(most-positive-fixnum most-negative-fixnum sleep
+			       ++ +++ ** *** // ///))
+
+
+(in-package "SYSTEM")
+(export '(add-port-death-handler remove-port-death-handler sap-int
+	  int-sap sap-ref-8 sap-ref-16 sap-ref-32 without-gcing
+	  *in-the-compiler* compiler-version *pornography-of-death*
+	  *port-receive-rights-handlers* *port-ownership-rights-handlers*
+	  without-interrupts with-reply-port map-port add-port-object
+	  remove-port-object make-object-set object-set-operation
+	  server-message *xwindow-table* map-xwindow add-xwindow-object
+	  remove-xwindow-object server-event coerce-to-key-event
+	  coerce-to-motion-event coerce-to-expose-event
+	  coerece-to-exposecopy-event coerce-to-focuschange-event server
+	  *nameserverport* *usertypescript* *userwindow* *typescriptport*
+	  *task-self* *task-data* *task-notify* *file-input-handlers*
+	  with-interrupts with-enabled-interrupts enable-interrupt
+	  ignore-interrupt default-interrupt serve-all))
+
+(in-package "EXTENSIONS")
+(export '(quit *prompt* print-herald save-lisp gc-on gc-off
+	       *before-save-initializations* *after-save-initializations*
+	       *editor-lisp-p* *clx-server-displays* *display-event-handlers*))
+
+(in-package "LISP")
+
+;;; These go here so that we can refer to them in top-level forms.
+
+(defvar *before-save-initializations* ()
+  "This is a list of functions which are called before creating a saved core
+  image.  These functions are executed in the child process which has no ports,
+  so they cannot do anything that tries to talk to the outside world.")
+
+(defvar *after-save-initializations* ()
+  "This is a list of functions which are called when a saved core image starts
+  up.  The system itself should be initialized at this point, but applications
+  might not be.")
+
+;;; Make the error system enable interrupts.
+
+(defconstant most-positive-fixnum 134217727
+  "The fixnum closest in value to positive infinity.")
+
+(defconstant most-negative-fixnum -134217728
+  "The fixnum closest in value to negative infinity.")
+
+
+(defvar *prompt* "* " "The string with which Lisp prompts you.")
+
+
+;;; Random information:
+
+(defvar compiler-version "???")
+(defvar *lisp-implementation-version* "2.7(?)")
+
+(defvar *in-the-compiler* ()
+  "Bound to T while running code inside the compiler.  Macros may test this to
+  see where they are being expanded.")
+
+(defparameter %fasl-code-format 6)
+
+
+;;;; Global ports:
+ 
+(defvar *task-self* 1
+  "Port that refers to the current task.")
+
+(defvar *task-data* 2
+  "Port used to receive data for the current task.")
+
+(defvar *nameserverport* ()
+  "Port to the name server.")
+
+
+;;; GC stuff.
+
+(defvar *gc-inhibit* nil)	; Inhibits GC's.
+
+(defvar *already-maybe-gcing* nil) ; Inhibits recursive GC's.
+
+(defvar *need-to-collect-garbage* nil
+  "*Need-to-collect-garbage* is set to T when GC is disabled, but the system
+  needs to do a GC.  When GC is enabled again, the GC is done then.")
+
+
+;;; Software interrupt stuff.
+
+(defvar *in-server* NIL
+  "*In-server* is set to T when the SIGMSG interrupt has been enabled
+  in Server.")
+
+(defvar server-unique-object (cons 1 2))
+
+(defconstant lockout-interrupts (logior (mach:sigmask mach:sigint)
+					(mach:sigmask mach:sigquit)
+					(mach:sigmask mach:sigfpe)
+					(mach:sigmask mach:sigsys)
+					(mach:sigmask mach:sigpipe)
+					(mach:sigmask mach:sigalrm)
+					(mach:sigmask mach:sigurg)
+					(mach:sigmask mach:sigstop)
+					(mach:sigmask mach:sigtstp)
+					(mach:sigmask mach:sigcont)
+					(mach:sigmask mach:sigchld)
+					(mach:sigmask mach:sigttin)
+					(mach:sigmask mach:sigttou)
+					(mach:sigmask mach:sigio)
+					(mach:sigmask mach:sigxcpu)
+					(mach:sigmask mach:sigxfsz)
+					(mach:sigmask mach:sigvtalrm)
+					(mach:sigmask mach:sigprof)
+					(mach:sigmask mach:sigwinch)
+					(mach:sigmask mach:sigmsg)
+					(mach:sigmask mach:sigemsg)))
+
+(defconstant interrupt-stack-size 4096
+  "Size of stack for Unix interrupts.")
+
+(defvar software-interrupt-stack NIL
+  "Address of the stack used by Mach to send signals to Lisp.")
+
+(defvar %sp-interrupts-inhibited nil
+  "True if emergency message interrupts should be inhibited, false otherwise.")
+
+(defvar *software-interrupt-vector*
+  (make-array mach::maximum-interrupts)
+  "A vector that associates Lisp functions with Unix interrupts.")
+
+(defun enable-interrupt (interrupt function &optional character)
+  "Enable one Unix interrupt and associate a Lisp function with it.
+  Interrupt should be the number of the interrupt to enable.  Function
+  should be a funcallable object that will be called with three
+  arguments: the signal code, a subcode, and the context of the
+  interrupt.  The optional character should be an ascii character or
+  an integer that causes the interrupt from the keyboard.  This argument
+  is only used for SIGINT, SIGQUIT, and SIGTSTP interrupts and is ignored
+  for any others.  Returns the old function associated with the interrupt
+  and the character that generates it if the interrupt is one of SIGINT,
+  SIGQUIT, SIGTSTP and character was specified."
+  (unless (< 0 interrupt mach::maximum-interrupts)
+    (error "Interrupt number ~D is not between 1 and ~D."
+	   mach::maximum-interrupts))
+  (let ((old-fun (svref *software-interrupt-vector* interrupt))
+	(old-char ()))
+    (when (and character
+	       (or (eq interrupt mach:sigint)
+		   (eq interrupt mach:sigquit)
+		   (eq interrupt mach:sigtstp)))
+      (when (characterp character)
+	(setq character (char-code character)))
+      (when (mach:unix-isatty 0)
+	(if (or (eq interrupt mach:sigint)
+		(eq interrupt mach:sigquit))
+	    (mach:with-trap-arg-block mach:tchars tc
+	      (multiple-value-bind
+		  (val err)
+		  (mach:unix-ioctl 0 mach:TIOCGETC
+				   (alien-value-sap mach:tchars))
+		(if (null val)
+		    (error "Failed to get tchars information, unix error ~S."
+			   (mach:get-unix-error-msg err))))
+	      (cond ((eq interrupt mach:sigint)
+		     (setq old-char
+			   (alien-access (mach::tchars-intrc (alien-value tc))))
+		     (setf (alien-access (mach::tchars-intrc (alien-value tc)))
+			   character))
+		    (T
+		     (setq old-char
+			   (alien-access (mach::tchars-quitc (alien-value tc))))
+		     (setf (alien-access (mach::tchars-quitc (alien-value tc)))
+			   character)))
+	      (multiple-value-bind
+		  (val err)
+		  (mach:unix-ioctl 0 mach:tiocsetc
+				   (alien-value-sap mach:tchars))
+		(if (null val)
+		    (error "Failed to set tchars information, unix error ~S."
+			   (mach:get-unix-error-msg err)))))
+	    (mach:with-trap-arg-block mach:ltchars tc
+	      (multiple-value-bind
+		  (val err)
+		  (mach:unix-ioctl 0 mach:TIOCGLTC
+				   (alien-value-sap mach:ltchars))
+		(if (null val)
+		    (error "Failed to get ltchars information, unix error ~S."
+			   (mach:get-unix-error-msg err))))
+	      (setq old-char
+		    (alien-access (mach::ltchars-suspc (alien-value tc))))
+	      (setf (alien-access (mach::ltchars-suspc (alien-value tc)))
+		    character)
+	      (multiple-value-bind
+		  (val err)
+		  (mach:unix-ioctl 0 mach:TIOCSLTC
+				   (alien-value-sap mach:ltchars))
+		(if (null val)
+		    (error "Failed to set ltchars information, unix error ~S."
+			   (mach:get-unix-error-msg err))))))))
+    (setf (svref *software-interrupt-vector* interrupt) function)
+    (if (null function)
+	(mach:unix-sigvec interrupt mach:sig_dfl 0 0)
+	(let ((diha (+ (ash clc::romp-data-base 16)
+		       clc::software-interrupt-offset)))
+	  (mach:unix-sigvec interrupt diha lockout-interrupts 1)))
+    (if old-char
+	(values old-fun old-char)
+	old-fun)))
+
+(defun ignore-interrupt (interrupt)
+  "The Unix interrupt handling mechanism is set up so that interrupt is
+  ignored."
+  (unless (< 0 interrupt mach::maximum-interrupts)
+    (error "Interrupt number ~D is not between 1 and 31."))
+  (let ((old-fun (svref *software-interrupt-vector* interrupt)))
+    (mach:unix-sigvec interrupt mach:sig_ign 0 0)
+    (setf (svref *software-interrupt-vector* interrupt) NIL)
+    old-fun))
+
+(defun default-interrupt (interrupt)
+  "The Unix interrupt handling mechanism is set up to do the default action
+  under mach.  Lisp will not get control of the interrupt."
+  (unless (< 0 interrupt mach::maximum-interrupts)
+    (error "Interrupt number ~D is not between 1 and 31."))
+  (let ((old-fun (svref *software-interrupt-vector* interrupt)))
+    (mach:unix-sigvec interrupt mach:sig_dfl 0 0)
+    (setf (svref *software-interrupt-vector* interrupt) NIL)
+    old-fun))
+
+
+;;; %SP-Software-Interrupt-Handler is called by the miscops when a Unix
+;;; signal arrives.  The three arguments correspond to the information
+;;; passed to a normal Unix signal handler, i.e.:
+;;;	signal -- the Unix signal number.
+;;;	code -- a code for those signals which can be caused by more
+;;;		than one kind of event.  This code specifies the sub-event.
+;;;	scp -- a pointer to the context of the signal.
+
+;;; Because of the way %sp-software-interrupt-handler returns, it doesn't
+;;; unwind the binding stack properly.  The only variable affected by this
+;;; is software-interrupt-stack, so it must be handled specially.
+
+(defun %sp-software-interrupt-handler (signal code scp stack)
+  (declare (optimize (speed 3) (safety 0)))
+  (if (and %sp-interrupts-inhibited
+	   (not (memq signal '(#.mach:sigill #.mach:sigbus #.mach:sigsegv))))
+      (progn
+	(let ((iin %sp-interrupts-inhibited))
+	  (setq %sp-interrupts-inhibited
+		(nconc (if (consp iin) iin)
+		       (list `(,signal ,code ,scp))))
+	  (mach:unix-sigsetmask 0)))
+      (let* ((old-stack software-interrupt-stack)
+	     (new-stack ())
+	     (%sp-interrupts-inhibited T))
+	(unwind-protect
+	    (progn
+	      (when *in-server*
+		(mach:unix-sigvec mach:sigmsg mach::sig_dfl 0 0))
+	      (multiple-value-bind (gr addr)
+				   (mach:vm_allocate *task-self* 0
+						     interrupt-stack-size t)
+		(gr-error 'mach:vm_allocate gr '%sp-software-interrupt-handler)
+		(setq software-interrupt-stack
+		      (int-sap (+ addr interrupt-stack-size))))
+	      (setq new-stack software-interrupt-stack)
+	      (mach:unix-sigstack new-stack 0)
+	      (mach:unix-sigsetmask 0)
+	      (funcall (svref *software-interrupt-vector* signal)
+		       signal code scp)
+	      (mach:unix-sigsetmask lockout-interrupts))
+	  (mach:vm_deallocate *task-self*
+			      (- (sap-int new-stack)
+				 interrupt-stack-size)
+			      interrupt-stack-size)
+	  (setq software-interrupt-stack old-stack)
+	  (mach:unix-sigstack old-stack 0)
+	  (when *in-server*
+	    (let ((diha (+ (ash clc::romp-data-base 16)
+			   clc::software-interrupt-offset)))
+	      (mach:unix-sigvec mach:sigmsg diha lockout-interrupts 1)))
+	  (mach:unix-sigsetmask 0))))
+  (%primitive break-return stack))
+
+
+(defun ih-sigint (signal code scp)
+  (declare (ignore signal code scp))
+  (without-hemlock
+   (with-interrupts
+    (break "Software Interrupt" t))))
+
+(defun ih-sigquit (signal code scp)
+  (declare (ignore signal code scp))
+  (throw 'top-level-catcher nil))
+
+(defun ih-sigtstp (signal code scp)
+  (declare (ignore signal code scp))
+  (without-hemlock
+;   (reset-keyboard 0)
+   (mach:unix-kill (mach:unix-getpid) mach:sigstop)))
+
+(defun ih-sigill (signal code scp)
+  (declare (ignore signal code))
+  (alien-bind ((context (make-alien-value scp 0 (record-size 'mach:sigcontext)
+					  'mach:sigcontext)
+			mach:sigcontext T))
+    (error "Illegal instruction encountered at IAR ~X."
+	   (alien-access (mach::sigcontext-iar (alien-value context))))))
+
+(defun ih-sigbus (signal code scp)
+  (declare (ignore signal code))
+  (alien-bind ((context (make-alien-value scp 0 (record-size 'mach:sigcontext)
+					  'mach:sigcontext)
+			mach:sigcontext T))
+    (with-interrupts
+     (error "Bus error encountered at IAR ~X."
+	    (alien-access (mach::sigcontext-iar (alien-value context)))))))
+
+(defun ih-sigsegv (signal code scp)
+  (declare (ignore signal code))
+  (alien-bind ((context (make-alien-value scp 0 (record-size 'mach:sigcontext)
+					  'mach:sigcontext)
+			mach:sigcontext T))
+    (with-interrupts
+     (error "Segment violation encountered at IAR ~X."
+	    (alien-access (mach::sigcontext-iar (alien-value context)))))))
+
+(defun ih-sigfpe (signal code scp)
+  (declare (ignore signal code))
+  (alien-bind ((context (make-alien-value scp 0 (record-size 'mach:sigcontext)
+					  'mach:sigcontext)
+			mach:sigcontext T))
+    (with-interrupts
+     (error "Floating point exception encountered at IAR ~X."
+	    (alien-access (mach::sigcontext-iar (alien-value context)))))))
+
+;;; When we're in server then throw back to server.  If we're not
+;;; in server then just ignore the sigmsg interrupt.  We can't handle
+;;; it and we should never get it anyway.  But of course we do -- it's
+;;; dealing with interrupts and there funny at best.
+(defun ih-sigmsg (signal code scp)
+  (declare (ignore signal code scp))
+  (mach:unix-sigsetmask (mach:sigmask mach:sigmsg))
+  (default-interrupt mach:sigmsg)
+  (when *in-server*
+    (setq *in-server* nil)
+    (throw 'server-catch server-unique-object)))
+
+(defun ih-sigemsg (signal code scp)
+  (declare (ignore signal code scp))
+  (service-emergency-message-interrupt))
+
+(defun init-mach-signals ()
+  (declare (optimize (speed 3) (safety 0)))
+  (multiple-value-bind (gr addr)
+		       (mach:vm_allocate *task-self* 0 interrupt-stack-size t)
+    (gr-error 'mach:vm_allocate gr 'enable-interrupt)
+    (setq software-interrupt-stack
+	  (int-sap (+ addr interrupt-stack-size))))
+  (let ((iha (get 'clc::interrupt-handler '%loaded-address))
+	(diha (+ (ash clc::romp-data-base 16) clc::software-interrupt-offset)))
+    (%primitive pointer-system-set diha 0 iha))
+  (mach:unix-sigstack software-interrupt-stack 0)
+  (enable-interrupt mach:sigint #'ih-sigint)
+  (enable-interrupt mach:sigquit #'ih-sigquit)
+  (enable-interrupt mach:sigtstp #'ih-sigtstp)
+  (enable-interrupt mach:sigill #'ih-sigill)
+  (enable-interrupt mach:sigbus #'ih-sigbus)
+  (enable-interrupt mach:sigsegv #'ih-sigsegv)
+  (enable-interrupt mach:sigemsg #'ih-sigemsg)
+  (enable-interrupt mach:sigfpe #'ih-sigfpe)
+;  (reset-keyboard 0)
+  )
+
+
+;;;; Reply port allocation.
+;;;
+;;;    We maintain a global stack of reply ports which is shared among
+;;; all matchmaker interfaces, and could be used by other people as well.
+;;;
+;;;    The stack is represented by a vector, and a pointer to the first
+;;; free port.  The stack grows upward.  There is always at least one
+;;; NIL entry in the stack after the last allocated port.
+;;;
+(defvar *reply-port-stack* (make-array 16)) ; Vector of reply ports.
+(defvar *reply-port-pointer* 0)	; Index of first free port.
+(defvar *reply-port-depth* 0)	; Dynamic depth in With-Reply-Port forms.
+
+;;; We use this as the reply port when allocating or deallocating reply
+;;; ports to get around potentially nasty interactions.  Interrupts
+;;; are always off when we are doing this, so we don't have to have
+;;; more than one of these, or worry about unwinding.
+(defvar *allocate-reply-port* (mach:mach-task_data))
+
+;;; Reset-Reply-Port-Stack  --  Internal
+;;;
+;;;    This is a before-save initialization which Nil's out the reply
+;;; port stack and sets *allocate-reply-port* back to DataPort so that
+;;; things initialize right at OS-Init time.
+;;;
+(defun reset-reply-port-stack ()
+  (setq *reply-port-pointer* 0  *reply-port-depth* 0)
+  (fill (the simple-vector *reply-port-stack*) nil)
+  (setq *allocate-reply-port* (mach:mach-task_data)))
+(pushnew 'reset-reply-port-stack *before-save-initializations*)
+
+;;; Allocate-New-Reply-Ports  --  Internal
+;;;
+;;;    If we run out of reply ports, we allocate another one, possibly
+;;; growing the stack.
+;;;
+(defun allocate-new-reply-ports ()
+  (let* ((stack *reply-port-stack*)
+	 (pointer *reply-port-pointer*)
+	 (len (length stack)))
+    (declare (simple-vector stack) (fixnum len))
+    (when (eql pointer (1- len))
+      (let ((new (make-array (* len 2))))
+	(replace new stack :end1 len :end2 len)
+	(setq stack new  *reply-port-stack* new)))
+    (setf (svref stack pointer) *allocate-reply-port*)
+    (let ((port (gr-call* mach:port_allocate (mach:mach-task_self))))
+      (gr-call mach:port_disable (mach:mach-task_self) port)
+      ;;
+      ;; Nil out the allocate reply port so it isn't used for mundane purposes.
+      (setf (svref stack pointer) nil)
+      (setf (svref stack (1- pointer)) port)
+      port)))
+
+;;; Reallocate-Reply-Ports  --  Internal
+;;;
+;;;    This function is called when With-Reply-Port finds the stack pointer
+;;; to be other than what it expected when it finishes.  Reallocates all
+;;; of the ports on the stack from Start to *reply-port-pointer*.  We
+;;; stick the *allocate-reply-port* out at *reply-port-pointer*, and
+;;; bind *reply-port-depth*, so that the allocation functions are happy.
+;;;
+(defun reallocate-reply-ports (start)
+  (let* ((pointer *reply-port-pointer*)
+	 (*reply-port-depth* pointer)
+	 (stack *reply-port-stack*)
+	 (save-port (svref stack pointer)))
+    (when (> start pointer)
+      (error "More ports in use than allocated???"))
+    (setf (svref stack pointer) *allocate-reply-port*)
+    (do ((i start (1+ i)))
+	((= i pointer)
+	 (setf (svref stack pointer) save-port))
+      (let ((port (svref stack i)))
+	(gr-call mach:port_deallocate *task-self* port)
+	(setf (svref stack i)
+	      (gr-call* mach:port_allocate *task-self*))))))
+
+
+;;;; Server stuff:
+;;;
+;;;    There is a fair amount of stuff to support Matchmaker RPC servers
+;;; and asynchonous message service.  RPC message service needs to be
+;;; centralized since a server must receive on all ports, and there is
+;;; no way for a particular server to know about all other servers
+;;; in the same lisp.
+;;;
+;;;    The idea is that you receive the message, and then dispatch off
+;;; of the port received on and the message ID received.  Ports correspond
+;;; to objects that the server manages.  Message ID's correspond to the
+;;; operations on the objects.  Objects are grouped into object sets, which
+;;; are sets of objects having the same operations defined.
+;;; 
+;;;    The same mechanism is used for handling asynchronous messages.
+;;;
+
+;;;    The current implementation uses standard eq[l] hashtables for both
+;;; levels of dispatching.  Special purpose data structures would be more
+;;; efficient, but the ~1ms overhead will probably be lost in the noise.
+
+;;;
+;;;    Hashtable from ports to objects.  Each entry is a cons (object . set).
+;;;
+(defvar *port-table* (make-hash-table :test #'eql))
+
+;;; Hashtable from windows to objects.  Each entry is a cons (object . set).
+;;;
+(defvar *xwindow-table* (make-hash-table :test #'eql))
+
+
+(defstruct (object-set
+	    (:constructor make-object-set
+			  (name &optional
+				(default-handler #'default-default-handler)))
+	    (:print-function
+	     (lambda (s stream d)
+	       (declare (ignore d))
+	       (format stream "#<Object Set ~S>" (object-set-name s)))))
+  name					; Name, for descriptive purposes.
+  (table (make-hash-table :test #'eq))  ; Message-ID or xevent-type --> handler fun.
+  default-handler)
+
+(setf (documentation 'make-object-set 'function)
+      "Make an object set for use by a RPC/xevent server.  Name is for
+      descriptive purposes only.")
+
+
+;;; MAP-XWINDOW and MAP-PORT return as multiple values the object and
+;;; object set mapped to by a xwindow or port in *xwindow-table* or
+;;; *port-table*.
+;;; 
+(macrolet ((defmapper (name table)
+	      `(defun ,(intern (concatenate 'simple-string
+					    "MAP-" (symbol-name name)))
+		      (,name)
+		 ,(format nil "Return as multiple values the object and ~
+		               object-set mapped to by ~A."
+			  (string-downcase (symbol-name name)))
+		 (let ((temp (gethash ,name ,table)))
+		   (if temp
+		       (values (car temp) (cdr temp))
+		       (values nil nil))))))
+  (defmapper port *port-table*)
+  (defmapper xwindow *xwindow-table*))
+
+
+;;; ADD-PORT-OBJECT and ADD-XWINDOW-OBJECT store an object/object-set pair
+;;; mapped to by a port or xwindow in either *port-table* or *xwindow-table*.
+;;; 
+(macrolet ((def-add-object (name table)
+	      `(defun ,(intern (concatenate 'simple-string
+					    "ADD-" (symbol-name name)
+					    "-OBJECT"))
+		      (,name object object-set)
+		 ,(format nil "Add a new ~A/object/object-set association."
+			  (string-downcase (symbol-name name)))
+		 (check-type object-set object-set)
+		 (setf (gethash ,name ,table) (cons object object-set))
+		 object)))
+  (def-add-object port *port-table*)
+  (def-add-object xwindow *xwindow-table*))
+
+
+;;; REMOVE-PORT-OBJECT and REMOVE-XWINDOW-OBJECT remove a port or xwindow and
+;;; its associated object/object-set pair from *port-table* or *xwindow-table*.
+;;; 
+(macrolet ((def-remove-object (name table)
+	      `(defun ,(intern (concatenate 'simple-string
+					    "REMOVE-" (symbol-name name)
+					    "-OBJECT"))
+		      (,name)
+		 ,(format nil
+			  "Remove ~A and its associated object/object-set pair."
+			  (string-downcase (symbol-name name)))
+		 (remhash ,name ,table))))
+  (def-remove-object port *port-table*)
+  (def-remove-object xwindow *xwindow-table*))
+
+
+;;; Object-Set-Operation  --  Public
+;;;
+;;;    Look up the handler function for a given message ID.
+;;;
+(defun object-set-operation (object-set message-id)
+  "Return the handler function in Object-Set for the operation specified by
+  Message-ID, if none, NIL is returned.  The handler function is passed
+  the object.  The received message is in server-Message."
+  (check-type object-set object-set)
+  (check-type message-id fixnum)
+  (values (gethash message-id (object-set-table object-set))))
+
+;;; %Set-Object-Set-Operation  --  Internal
+;;;
+;;;    The setf inverse for Object-Set-Operation.
+;;;
+(defun %set-object-set-operation (object-set message-id new-value)
+  (check-type object-set object-set)
+  (check-type message-id fixnum)
+  (setf (gethash message-id (object-set-table object-set)) new-value))
+;;;
+(defsetf object-set-operation %set-object-set-operation
+  "Sets the handler function for an object set operation.")
+
+;;;; Server function:
+;;;
+;;; SERVER makes use of a defined alien, server-event, that lives at address 0.
+;;; This is a bogus alien used just as a dynamic variable that is declared
+;;; appropriately for the compiler.  This alien variable is bound to stuff in
+;;; an alien stack by the same name, server-event, which contains elements much
+;;; bigger than necessary to accommodate whatever will come back in the future
+;;; from waiting across ports, sockets, file descriptors, etc.  The defined
+;;; alien operators allow easy access to server-event as different types of
+;;; event by declaring the necessary type for the compiler when the operator
+;;; is used.
+
+
+;;;    Currently the server message is 4k bytes, thus serving larger requests
+;;; is impossible.  If anyone is bothered by this, the size can be increased.
+;;; X events are only 24 bytes.
+;;; 
+
+(defconstant server-message-size 4096)
+(defalien server-message server-message (bytes server-message-size) 0)
+
+(define-alien-stack server-message server-message (bytes server-message-size))
+
+(defrecord server-message
+  (msg mach:msg #.(record-size 'mach:msg)))
+
+(defvar *file-input-handlers* ()
+  "Is an association list of file descriptors and functions to call when
+  input is available on the particular file descriptor.")
+
+(defvar *clx-server-displays* ()
+  "Is a list of CLX displays that may have some activity on them.")
+
+(defvar *display-event-handlers* nil
+  "This is an alist mapping displays to user functions to be called when
+   SYSTEM:SERVER notices input on a display connection.  Do not modify this
+   directly; use EXT:ENABLE-CLX-EVENT-HANDLING.  A given display should be
+   represented here only once.")
+
+
+;;; Default-Default-Handler  --  Internal
+;;;
+;;;    If no such operation defined, signal an error.
+;;;
+(defun default-default-handler (object)
+  (alien-bind ((msg (server-message-msg server-message)))
+    (error "No operation for ID ~D on ~S in ~S."
+	   (alien-access (mach:msg-id (alien-value msg))) object
+	   (car (gethash (alien-access (mach:msg-localport (alien-value msg)))
+			 *port-table*)))))
+
+
+;;; Server  --  Public
+;;;
+(defun server (&optional (timeout 0 todef))
+  "Receive on all ports and Xevents and dispatch to the appropriate handler
+  function.  If timeout is specified, server will wait the specified time
+  and then return, otherwise it will wait until something happens.  Server
+  returns T if something happened and NIL otherwise."
+  (cond ((dolist (d/h ext::*display-event-handlers* nil)
+	   (let ((d (car d/h)))
+	     (when (xlib::event-listen d)
+	       (handler-bind ((error #'(lambda (condx)
+					 (declare (ignore condx))
+					 (flush-display-events d))))
+		 (funcall (cdr d/h) d))
+	       (return t))))
+	 T)
+	(T
+	 (let* ((to (if todef (round (* timeout 1000000))))
+		(fd-mask 0)
+		(omask 0)
+		(value (catch 'server-catch
+			 (unwind-protect
+			     (progn
+			       (setq omask (mach:unix-sigsetmask
+					    (mach:sigmask mach:sigmsg)))
+			       (unless (grab-message-loop)
+				 (let ((*in-server* T))
+				   (enable-interrupt mach:sigmsg #'ih-sigmsg)
+				   (multiple-value-bind
+				       (to1 to2)
+				       (if todef (truncate to 1000000))
+				     (multiple-value-bind
+					 (nfd fdm)
+					 (get-fd-info)
+				       (mach:unix-sigsetmask 0)
+				       (multiple-value-bind
+					   (nfnd rfdm)
+					   (mach:unix-select nfd fdm 0 0
+							     to1 to2)
+					 (mach:unix-sigsetmask
+					  (mach:sigmask mach:sigmsg))
+					 (default-interrupt mach:sigmsg)
+					 (setq fd-mask rfdm)
+					 nfnd))))))
+			   (default-interrupt mach:sigmsg)
+			   (mach:unix-sigsetmask omask)))))
+	   (cond ((or (null value) (and todef (eq value 0))) NIL)
+		 ((eq value server-unique-object)
+		  (grab-message-loop)
+		  T)
+		 ((file-descriptor-ready fd-mask) T))))))
+
+;;; Get-fd-info turns the association list in *file-input-handlers*
+;;; into information that unix-select can be called with.
+(defun Get-fd-info ()
+  (do* ((fdl *file-input-handlers* (cdr fdl)) ; 
+	(FD (caar fdl) (caar fdl))
+	(mfd 0)
+	(fdm 0))
+       ((null fdl)
+	(values (1+ mfd) fdm))
+    (setq mfd (max mfd fd))
+    (setq fdm (logior fdm (ash 1 fd)))))
+
+;;; File-descriptor-ready is called when server determines that a file
+;;; descriptor has input ready on one ore more of them.  It calls the
+;;; appropriate handler with the file-descriptor as its argument.
+;;; It checks for an xevent first, so they are handled as quickly as
+;;; possible.
+(defun file-descriptor-ready (rfdm)
+  (do ((fd 0 (1+ fd))
+       (ms rfdm (ash ms -1)))
+      ((eq ms 0))
+    (when (/= (the fixnum (logand ms 1)) 0)
+      (let ((info (assoc fd *file-input-handlers* :test #'eq)))
+	(when info
+	  (funcall (cdr info) fd)))))
+  T)
+
+;;; Grab-message-loop calls the appropiate handler for an IPC message.
+(defun grab-message-loop ()
+  (do* ((gr (server-grab-message) (server-grab-message))
+	(flag (/= gr mach:rcv-timed-out)
+	      (if (/= gr mach:rcv-timed-out) t flag)))
+       ((= gr mach:rcv-timed-out) flag)))
+
+(defun server-grab-message ()
+  (with-stack-alien (sm server-message)
+    (alien-bind ((msg (server-message-msg (alien-value sm))))
+      (setf (alien-access (mach:msg-msgsize (alien-value msg)))
+	    server-message-size)
+      (setf (alien-access (mach:msg-localport (alien-value msg)))
+	    mach::port-enabled)
+      (let ((gr (mach:msg-receive (alien-value sm) mach::rcv-timeout 0)))
+	(when (eql gr mach:rcv-timed-out)
+	  (return-from server-grab-message gr))
+	(unless (eql gr mach:rcv-success)
+	  (gr-error 'mach:msg-receive gr))
+	(let* ((server-message (alien-value sm))
+	       (port (alien-access (mach:msg-localport (alien-value msg))))
+	       (id (alien-access (mach:msg-id (alien-value msg))))
+	       (x (gethash port *port-table*))
+	       (set (cdr x)))
+	  (unless x
+	    (error "~D is not known to server (operation: ~D)." port id))
+	  (let ((gr (funcall (gethash id (object-set-table set)
+				      (object-set-default-handler set))
+			     (car x))))
+	    (unless (eql gr mach:kern-success)
+	      (gr-error 'server gr)))))))
+  mach:kern-success)
+
+(defun serve-all (&optional (timeout 0))
+  "Serve-all calls server with the specified timeout.  If server does
+  something (returns T) it loops over server with timeout 0 until all
+  events have been served.  Serve-all returns T if server did something
+  and other NIL."
+  (do ((res NIL)
+       (sval (server timeout) (server 0)))
+      ((null sval) res)
+    (setq res T)))
+
+
+;;;; Emergency Message Handling:
+;;;
+;;; We use the same mechanism for asynchronous messages as is used for
+;;; normal server messages.   The only tricky part is that we don't want
+;;; some random server function being called when we really want to
+;;; receive an emergency message, so we can't receive on all ports.
+;;; Instead, we use MessagesWaiting to find the ports with emergency
+;;; messages.
+
+(defalien waiting-ports nil (long-words 128))
+
+;;; Service-Emergency-Message-Interrupt  --  Internal
+;;;
+;;;    This is a lot like the server function, but we only receive on
+;;; ports with one emergency message.  We only receive one message because
+;;; the handler function might have caused any other messages to be received.
+;;; When we re-enable interrupts, if any emergency messages are left, we
+;;; should be interrupted again.
+;;;
+(defun service-emergency-message-interrupt ()
+  (grab-message-loop))
+
+;;;
+;;; This object set is used for DataPort, which is the port various magical
+;;; message from the kernel are received on...
+(defvar *kernel-messages* (make-object-set "Kernel Messages"))
+
+(compiler-let ((*alien-eval-when* '(compile eval)))
+(defrecord port-death-msg
+  (msg mach:msg #.(record-size 'mach:msg))
+  (ex-port-tt pad (long-words 1))
+  (ex-port (signed-byte 32) (long-words 1)))
+
+(defoperator (server-message-port-death-msg port-death-msg)
+	     ((msg server-message))
+  `(alien-index (alien-value ,msg) 0 (record-size 'port-death-msg)))
+); Compiler-Let
+
+
+;;; *Port-Death-Handlers* is an EQ hash table of lists of functions that are
+;;; called upon port death.  If a port dies that is not in the table, we print
+;;; out a message on *Trace-Output* describing its death.  If
+;;; *Pornography-Of-Death* is true, we don't even print that message.
+
+(defvar *port-death-handlers* (make-hash-table :test #'eql)
+  "Don't use this --- use Add-Port-Death-Handler instead.")
+
+;;; Add-Port-Death-Handler, Remove-Port-Death-Handler  --  Public
+;;;
+(defun add-port-death-handler (port function)
+  "Make Function a handler for port death on Port.  When the port dies,
+  Function is called with the port and an argument.  See also
+  Remove-Port-Death-Handler."
+  (pushnew function (gethash port *port-death-handlers*))
+  nil)
+;;;
+(defun remove-port-death-handler (port function)
+  "Undoes the effect of Add-Port-Death-Handler."
+  (setf (gethash port *port-death-handlers*)
+	(delete function (gethash port *port-death-handlers*)))
+  nil)
+
+(setf (object-set-operation *kernel-messages* mach:notify-port-deleted)
+      #'(lambda (obj)
+	  (declare (ignore obj))
+	  (let* ((ex-port (alien-access
+			   (port-death-msg-ex-port
+			    (server-message-port-death-msg server-message))))
+		 (handlers (gethash ex-port *port-death-handlers*)))
+	    (remhash ex-port *port-table*)
+	    (remhash ex-port *port-death-handlers*)
+	    (if (null handlers)
+		(handle-unclaimed-port-death ex-port)
+		(dolist (fun handlers) (funcall fun ex-port))))
+	  mach:kern-success))
+
+(defvar *pornography-of-death* t
+  "If true, nothing is said about port deaths.")
+
+(defun handle-unclaimed-port-death (port)
+  (unless *pornography-of-death*
+    (format *trace-output* "~&[Port ~S just bit the dust.]~%" port)))
+
+;;; Port receive and ownership rights messages are handled simlarly, but
+;;; by default we deallocate the port to make sure it's really dead.  This
+;;; gets around problems with ports being exhausted because some servers
+;;; don't really nuke the port when the deallocate the object.
+;;;
+
+(defvar *port-receive-rights-handlers* (make-hash-table :test #'eql)
+  "This is a hashtable from ports to functions.  The function is called with
+  the port as its argument when a port receive rights message for that port
+  is received from the kernel.")
+
+(defvar *port-ownership-rights-handlers* (make-hash-table :test #'eql)
+  "This is a hashtable from ports to functions.  The function is called with
+  the port as its argument when a port ownership rights message for that port
+  is received from the kernel.")
+
+(setf (object-set-operation *kernel-messages* mach:notify-receive-rights)
+      #'(lambda (obj)
+	  (declare (ignore obj))
+	  (let ((ex-port (alien-access
+			  (port-death-msg-ex-port
+			   (server-message-port-death-msg server-message)))))
+	    (funcall (gethash ex-port *port-receive-rights-handlers*
+			      #'handle-unclaimed-port-rights)
+		     ex-port))
+	  mach:kern-success))
+
+(setf (object-set-operation *kernel-messages* mach:notify-ownership-rights)
+      #'(lambda (obj)
+	  (declare (ignore obj))
+	  (let ((ex-port (alien-access
+			  (port-death-msg-ex-port
+			   (server-message-port-death-msg server-message)))))
+	    (funcall (gethash ex-port *port-ownership-rights-handlers*
+			      #'handle-unclaimed-port-rights)
+		     ex-port))
+	  mach:kern-success))
+
+(defun handle-unclaimed-port-rights (port)
+  (unless *pornography-of-death*
+    (format *trace-output* "~&[Rights received for port ~D, deallocating it.]~%"
+	    port))
+  (mach:port_deallocate *task-self* port)
+  (remhash port *port-receive-rights-handlers*)
+  (remhash port *port-ownership-rights-handlers*)
+  (remhash port *port-table*))
+
+(add-port-object *task-data* nil *kernel-messages*)
+
+;;; Clear-Port-Tables  --  Internal
+;;;
+;;;    A before-save initialization which clears all of the port hashtables.
+;;;
+(defun clear-port-tables ()
+  (clrhash *port-table*)
+  (clrhash *port-death-handlers*)
+  (clrhash *port-receive-rights-handlers*)
+  (clrhash *port-ownership-rights-handlers*))
+
+(pushnew 'clear-port-tables *before-save-initializations*)
+
+
+;;; %Initial-Function is called when a cold system starts up.  First we zoom
+;;; down the *Lisp-Initialization-Functions* doing things that wanted to happen
+;;; at "load time."  Then we initialize the various subsystems and call the
+;;; read-eval-print loop.  The top-level Read-Eval-Print loop is executed until
+;;; someone (most likely the Quit function) throws to the tag
+;;; %End-Of-The-World.  We quit this way so that all outstanding cleanup forms
+;;; in Unwind-Protects will get executed.
+
+(proclaim '(special *lisp-initialization-functions*))
+
+(eval-when (compile)
+  (defmacro print-and-call (name)
+    `(progn
+       (%primitive print ',name)
+       (,name))))
+
+(defun %initial-function ()
+  "Gives the world a shove and hopes it spins."
+  (setq *already-maybe-gcing* t)
+  (setf *gc-inhibit* nil)
+  (setf *need-to-collect-garbage* nil)
+  (%primitive print "In initial-function, and running.")
+
+  ;; Many top-level forms call INFO, (SETF INFO).
+  (print-and-call c::globaldb-init)
+
+  ;; Some of the random top-level forms call Make-Array, which calls Subtypep...
+  (print-and-call subtypep-init)
+
+  (setq *lisp-initialization-functions*
+	(nreverse *lisp-initialization-functions*))
+  (%primitive print "Calling top-level forms.")
+  (dolist (fun *lisp-initialization-functions*)
+    (funcall fun))
+  (makunbound '*lisp-initialization-functions*)	; So it gets GC'ed.
+
+  (print-and-call os-init)
+  (print-and-call filesys-init)
+  (print-and-call conditions::error-init)
+
+  (print-and-call reader-init)
+  (print-and-call backq-init)
+  (print-and-call sharp-init)
+  ;; After the various reader subsystems have done their thing to the standard
+  ;; readtable, copy it to *readtable*.
+  (setq *readtable* (copy-readtable std-lisp-readtable))
+
+  (print-and-call stream-init)
+  (print-and-call random-init)
+  (print-and-call format-init)
+  (print-and-call package-init)
+  (print-and-call pprint-init)
+
+  (setq *already-maybe-gcing* nil)
+  (terpri)
+  (princ "CMU Common Lisp kernel core image ")
+  (princ (lisp-implementation-version))
+  (princ ".")
+  (terpri)
+  (princ "[You are in the LISP package.]")
+  (terpri)
+  (catch '%end-of-the-world
+    (loop
+     (%top-level)
+     (write-line "You're certainly a clever child.")))
+  (mach:unix-exit 0))
+
+
+;;;; Initialization functions:
+
+;;; Reinit is called to reinitialize the world when a saved core image
+;;; is resumed.
+(defvar *task-notify* NIL)
+
+(defun reinit ()
+  (without-interrupts
+   (setq *already-maybe-gcing* t)
+   (os-init)
+   (stream-reinit)
+   (setq *already-maybe-gcing* nil))
+  (setq *task-notify* (mach:mach-task_notify))
+  (mach:port_enable (mach:mach-task_self) *task-notify*)
+  (add-port-object *task-notify* nil *kernel-messages*)
+  (init-mach-signals))
+
+
+;;; OS-Init initializes our operating-system interface.  It sets the values
+;;; of the global port variables to what they should be and calls the functions
+;;; that set up the argument blocks for the server interfaces.
+
+(defun os-init ()
+  (setq *task-self* (mach:mach-task_self))
+  (setq *task-data* (mach:mach-task_data)))
+
+
+;;; Setup-path-search-list returns a list of the directories that are
+;;; in the unix path environment variable.  This is so that run-program
+;;; can be smarter about where to find a program to run.
+(defun setup-path-search-list ()
+  (let ((path (cdr (assoc :path ext::*environment-list*))))
+    (when path
+      (do* ((i 0 (1+ p))
+	    (p (position #\: path :start i)
+	       (position #\: path :start i))
+	    (pl ()))
+	   ((null p)
+	    (let ((s (subseq path i)))
+	      (if (string= s "")
+		  (push "default:" pl)
+		  (push (concatenate 'simple-string s "/") pl)))
+	    (nreverse pl))
+	(let ((s (subseq path i p)))
+	  (if (string= s "")
+	      (push "default:" pl)
+	      (push (concatenate 'simple-string s "/") pl)))))))
+
+
+;;;; Miscellaneous external functions:
+
+(defun print-herald ()
+  (write-string "CMU Common Lisp ")
+  (write-line (lisp-implementation-version))
+  (write-string "Hemlock ") (write-string *hemlock-version*)
+  (write-string ", Compiler ") (write-line compiler-version)
+  (write-line "Send bug reports and questions to Gripe.")
+  (values))
+
+(defvar *editor-lisp-p* nil
+  "This is true if and only if the lisp was started with the -edit switch.")
+
+(defun save-lisp (core-file-name &key
+				 (purify t)
+				 (root-structures ())
+				 (init-function
+				  #'(lambda ()
+				      (throw 'top-level-catcher nil)))
+				 (load-init-file t)
+				 (print-herald t)
+				 (process-command-line t))
+  "Saves a Spice Lisp core image in the file of the specified name.  The
+  following keywords are defined:
+  
+  :purify
+      If true, do a purifying GC which moves all dynamically allocated
+  objects into static space so that they stay pure.  This takes somewhat
+  longer than the normal GC which is otherwise done, but GC's will done
+  less often and take less time in the resulting core file.
+
+  :root-structures
+      This should be a list of the main entry points in any newly loaded
+  systems.  This need not be supplied, but locality will be better if it
+  is.  This is meaningless if :purify is Nil.
+  
+  :init-function
+      This is a function which is called when the created core file is
+  resumed.  The default function simply aborts to the top level
+  read-eval-print loop.  If the function returns it will be the value
+  of Save-Lisp.
+  
+  :load-init-file
+      If true, then look for an init.lisp or init.fasl file when the core
+  file is resumed.
+  
+  :print-herald
+      If true, print out the lisp system herald when starting."
+  
+  (if purify
+      (purify :root-structures root-structures)
+      (gc))
+  (unless (save core-file-name)
+    (setf (search-list "default:") (list (default-directory)))
+    (setf (search-list "path:") (setup-path-search-list))
+    (when process-command-line (ext::process-command-strings))
+    (setf *editor-lisp-p* nil)
+    (macrolet ((find-switch (name)
+		 `(find ,name *command-line-switches*
+			:key #'cmd-switch-name
+			:test #'(lambda (x y)
+				  (declare (simple-string x y))
+				  (string-equal x y)))))
+      (when (and process-command-line (find-switch "edit"))
+	(setf *editor-lisp-p* t))
+      (when (and load-init-file
+		 (not (and process-command-line (find-switch "noinit"))))
+	(let* ((cl-switch (find-switch "init"))
+	       (name (or (and cl-switch
+			      (or (cmd-switch-value cl-switch)
+				  (car (cmd-switch-words cl-switch))
+				  "init"))
+			 "init")))
+	  (load (merge-pathnames name (user-homedir-pathname))
+		:if-does-not-exist nil))))
+    (when print-herald
+      (print-herald))
+    (when process-command-line
+      (ext::invoke-switch-demons *command-line-switches*
+				 *command-switch-demons*))
+    (funcall init-function)))
+
+
+;;; Quit gets us out, one way or another.
+
+(defun quit (&optional recklessly-p)
+  "Terminates the current Lisp.  Things are cleaned up unless Recklessly-P is
+  non-Nil."
+;  (reset-keyboard 0)
+  (dolist (x (if (boundp 'extensions::temporary-foreign-files)
+		 extensions::temporary-foreign-files))
+    (mach:unix-unlink x))
+  (if recklessly-p
+      (mach:unix-exit 0)
+      (throw '%end-of-the-world nil)))
+
+
+
+(defalien sleep-msg mach:msg (record-size 'mach:msg))
+(setf (alien-access (mach:msg-simplemsg sleep-msg)) T)
+(setf (alien-access (mach:msg-msgtype sleep-msg)) 0)
+(setf (alien-access (mach:msg-msgsize sleep-msg))
+      (/ (record-size 'mach:msg) 8))
+
+;;; Currently there is a bug in the Mach timeout code that if the timeout
+;;; period is too short the receive never returns.
+
+(defun sleep (n)
+  "This function causes execution to be suspended for N seconds.  N may
+  be any non-negative, non-complex number."
+  (with-reply-port (sleep-port)
+    (let ((m (round (* 1000 n))))
+      (cond ((minusp m)
+	     (error "Argument to Sleep, ~S, is a negative number." n))
+	    ((zerop m))
+	    (t
+	     (setf (alien-access (mach:msg-localport sleep-msg)) sleep-port)
+	     (let ((gr (mach:msg-receive sleep-msg mach:rcv-timeout m)))
+	       (unless (eql gr mach:rcv-timed-out)
+		 (gr-error 'mach:receive gr)))))))
+  nil)
+
+
+;;;; TOP-LEVEL loop.
+
+(defvar / nil
+  "Holds a list of all the values returned by the most recent top-level EVAL.")
+(defvar // nil "Gets the previous value of / when a new value is computed.")
+(defvar /// nil "Gets the previous value of // when a new value is computed.")
+(defvar * nil "Holds the value of the most recent top-level EVAL.")
+(defvar ** nil "Gets the previous value of * when a new value is computed.")
+(defvar *** nil "Gets the previous value of ** when a new value is computed.")
+(defvar + nil "Holds the value of the most recent top-level READ.")
+(defvar ++ nil "Gets the previous value of + when a new value is read.")
+(defvar +++ nil "Gets the previous value of ++ when a new value is read.")
+(defvar - nil "Holds the form curently being evaluated.")
+(defvar *prompt* nil "The top-level prompt string.")
+(defvar %temp% nil "Random temporary, clobbered by top level loop.")
+(defvar *in-top-level-catcher* nil
+  "True if we are within the Top-Level-Catcher.  This is used by interrupt
+  handlers to see whether it is o.k. to throw.")
+
+(defun %top-level ()
+  "Top-level READ-EVAL-PRINT loop.  Do not call this."
+  (let  ((this-eval nil) (* nil) (** nil) (*** nil)
+	 (- nil) (+ nil) (++ nil) (+++ nil)
+	 (/// nil) (// nil) (/ nil) (%temp% nil))
+    (loop
+     (with-simple-restart (abort "Return to Top-Level.")
+       (catch 'top-level-catcher
+	 ;;
+	 ;; Prevent the user from irrevocably wedging the hooks.
+	 (setq *evalhook* nil)
+	 (setq *applyhook* nil)
+	 (let ((*in-top-level-catcher* t))
+	   (loop
+	    (fresh-line)
+	    (princ *prompt*)
+	    (setq +++ ++ ++ + + - - (read))
+	    (setq this-eval (multiple-value-list (eval -)))
+	    (dolist (x this-eval)
+	      (fresh-line)
+	      (prin1 x))
+	    (setq /// // // / / this-eval)
+	    (setq %temp% (car this-eval))
+	    ;;
+	    ;; Make sure nobody passes back an unbound marker.
+	    (unless (boundp '%temp%)
+	      (setq %temp% nil)
+	      (cerror "Go on, but set * to NIL."
+		      "Eval returned an unbound marker."))
+	    (setq *** ** ** * * %temp%))))))))
+
+
+;;; %Halt  --  Interface
+;;;
+;;;    A convenient way to get into the assembly level debugger.
+;;;
+(defun %halt ()
+  (%primitive halt))
diff --git a/code/list.lisp b/code/list.lisp
new file mode 100644
index 000000000..d182b726f
--- /dev/null
+++ b/code/list.lisp
@@ -0,0 +1,869 @@
+;;; -*- Log: code.log; Package: Lisp -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; Functions to implement lists for Spice Lisp.
+;;; Written by Joe Ginder and Carl Ebeling.
+;;; Rewritten and currently maintained by Skef Wholey.
+;;; 
+;;; Nsublis, things at the beginning broken.
+;;;
+;;; The list functions are part of the standard Spice Lisp environment.
+;;;
+;;; **********************************************************************
+;;;
+(in-package 'lisp)
+
+(export '(car cdr caar
+	  cadr cdar cddr caaar caadr cadar caddr cdaar cdadr
+	  cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr
+	  caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr
+	  cdddar cddddr cons tree-equal endp list-length nth first
+	  second third fourth fifth sixth seventh eighth
+	  ninth tenth rest nthcdr last list list* make-list
+	  append copy-list copy-alist copy-tree revappend nconc
+	  nreconc butlast nbutlast ldiff rplaca rplacd subst
+	  subst-if subst-if-not nsubst nsubst-if nsubst-if-not sublis nsublis
+	  member member-if member-if-not tailp adjoin union
+	  nunion intersection nintersection set-difference
+	  nset-difference set-exclusive-or nset-exclusive-or subsetp
+	  acons pairlis
+	  assoc assoc-if assoc-if-not
+	  rassoc rassoc-if rassoc-if-not))
+
+(proclaim '(maybe-inline
+	    tree-equal list-length nth %setnth nthcdr last make-list append
+	    copy-list copy-alist copy-tree revappend nconc nreconc butlast
+	    nbutlast ldiff member member-if member-if-not tailp adjoin union
+	    nunion intersection nintersection set-difference nset-difference
+	    set-exclusive-or nset-exclusive-or subsetp acons pairlis assoc
+	    assoc-if assoc-if-not rassoc rassoc-if rassoc-if-not subst subst-if
+	    subst-if-not nsubst nsubst-if nsubst-if-not sublis nsublis))
+
+
+(in-package "EXTENSIONS")
+(export '(assq memq delq))
+;; Assq & memq are just interpreter stubs.
+(proclaim '(maybe-inline delq))
+(in-package 'lisp)
+
+
+;;; These functions perform basic list operations:
+
+(defun car (list) "Returns the 1st object in a list." (car list))
+(defun cdr (list) "Returns all but the first object." (cdr list))
+(defun cadr (list) "Returns the 2nd object in a list." (cadr list))
+(defun cdar (list) "Returns the cdr of the 1st sublist." (cdar list))
+(defun caar (list) "Returns the car of the 1st sublist." (caar list))
+(defun cddr (list) "Returns all but the 1st two objects of a list." (cddr list))
+(defun caddr (list) "Returns the 1st object in the cddr of a list." (caddr list))
+(defun caadr (list) "Returns the 1st object in the cadr of a list." (caadr list))
+(defun caaar (list) "Returns the 1st object in the caar of a list." (caaar list))
+(defun cdaar (list) "Returns the cdr of the caar of a list." (cdaar list))
+(defun cddar (list) "Returns the cdr of the cdar of a list." (cddar list))
+(defun cdddr (list) "Returns the cdr of the cddr of a list." (cdddr list))
+(defun cadar (list) "Returns the car of the cdar of a list." (cadar list))
+(defun cdadr (list) "Returns the cdr of the cadr of a list." (cdadr list))
+(defun caaaar (list) "Returns the car of the caaar of a list." (caaaar list))
+(defun caaadr (list) "Returns the car of the caadr of a list." (caaadr list))
+(defun caaddr (list) "Returns the car of the caddr of a list." (caaddr list))
+(defun cadddr (list) "Returns the car of the cdddr of a list." (cadddr list))
+(defun cddddr (list) "Returns the cdr of the cdddr of a list." (cddddr list))
+(defun cdaaar (list) "Returns the cdr of the caaar of a list." (cdaaar list))
+(defun cddaar (list) "Returns the cdr of the cdaar of a list." (cddaar list))
+(defun cdddar (list) "Returns the cdr of the cddar of a list." (cdddar list))
+(defun caadar (list) "Returns the car of the cadar of a list." (caadar list))
+(defun cadaar (list) "Returns the car of the cdaar of a list." (cadaar list))
+(defun cadadr (list) "Returns the car of the cdadr of a list." (cadadr list))
+(defun caddar (list) "Returns the car of the cddar of a list." (caddar list))
+(defun cdaadr (list) "Returns the cdr of the caadr of a list." (cdaadr list))
+(defun cdadar (list) "Returns the cdr of the cadar of a list." (cdadar list))
+(defun cdaddr (list) "Returns the cdr of the caddr of a list." (cdaddr list))
+(defun cddadr (list) "Returns the cdr of the cdadr of a list." (cddadr list))
+(defun cons (se1 se2) "Returns a list with se1 as the car and se2 as the cdr."
+                      (cons se1 se2))
+
+
+(proclaim '(maybe-inline tree-equal-test tree-equal-test-not))
+
+(defun tree-equal-test-not (x y test-not)
+  (cond ((not (funcall test-not x y)) t)
+	((consp x)
+	 (and (consp y)
+	      (tree-equal-test-not (car x) (car y) test-not)
+	      (tree-equal-test-not (cdr x) (cdr y) test-not)))
+	(t ())))
+
+(defun tree-equal-test (x y test)
+  (cond ((funcall test x y) t)
+	((consp x)
+	 (and (consp y)
+	      (tree-equal-test (car x) (car y) test)
+	      (tree-equal-test (cdr x) (cdr y) test)))
+	(t ())))
+
+(defun tree-equal (x y &key (test #'eql) test-not)
+  "Returns T if X and Y are isomorphic trees with identical leaves."
+  (if test-not
+      (tree-equal-test-not x y test-not)
+      (tree-equal-test x y test)))
+
+
+(defun endp (object)
+  "The recommended way to test for the end of a list.  True if Object is nil,
+   false if Object is a cons, and an error for any other types of arguments."
+  (endp object))
+
+(defun list-length (list)
+  "Returns the length of the given List, or Nil if the List is circular."
+  (do ((n 0 (+ n 2))
+       (y list (cddr y))
+       (z list (cdr z)))
+      (())
+    (when (endp y) (return n))
+    (when (endp (cdr y)) (return (+ n 1)))
+    (when (and (eq y z) (> n 0)) (return nil))))
+
+(defun nth (n list)
+  "Returns the nth object in a list where the car is the zero-th element."
+  (car (%primitive nthcdr n list)))
+
+(defun first (list)
+  "Returns the 1st object in a list or NIL if the list is empty."
+  (car list))
+(defun second (list)
+  "Returns the 2nd object in a list or NIL if there is no 2nd object."
+  (cadr list))
+(defun third (list)
+  "Returns the 3rd object in a list or NIL if there is no 3rd object."
+  (caddr list))
+(defun fourth (list)
+  "Returns the 4th object in a list or NIL if there is no 4th object."
+  (cadddr list))
+(defun fifth (list)
+  "Returns the 5th object in a list or NIL if there is no 5th object."
+  (car (cddddr list)))
+(defun sixth (list)
+  "Returns the 6th object in a list or NIL if there is no 6th object."
+  (cadr (cddddr list)))
+(defun seventh (list)
+  "Returns the 7th object in a list or NIL if there is no 7th object."
+  (caddr (cddddr list)))
+(defun eighth (list)
+  "Returns the 8th object in a list or NIL if there is no 8th object."
+  (cadddr (cddddr list)))
+(defun ninth (list)
+  "Returns the 9th object in a list or NIL if there is no 9th object."
+  (car (cddddr (cddddr list))))
+(defun tenth (list)
+  "Returns the 10th object in a list or NIL if there is no 10th object."
+  (cadr (cddddr (cddddr list))))
+(defun rest (list)
+  "Means the same as the cdr of a list."
+  (cdr list))
+
+(defun nthcdr (n list)
+  "Performs the cdr function n times on a list."
+  (%primitive nthcdr n list))
+
+(defun last (list)
+  "Returns the last cons (not the last element!) of a list."
+  (%primitive last list))
+
+(defun list (&rest args)
+  "Returns constructs and returns a list of its arguments."
+  args)
+
+;;; List* is done the same as list, except that the last cons is made a
+;;; dotted pair
+
+(defun list* (arg &rest others)
+  "Returns a list of the arguments with last cons a dotted pair"
+  (cond ((atom others) arg)
+	((atom (cdr others)) (cons arg (car others)))
+	(t (do ((x others (cdr x)))
+	       ((null (cddr x)) (rplacd x (cadr x))))
+	   (cons arg others))))
+
+(defun make-list (size &key initial-element)
+  (declare (fixnum size))
+  "Constructs a list with size elements each set to value"
+  (if (< size 0) (error "~S is an illegal size for MAKE-LIST." size)
+      (do ((count size (1- count))
+	   (result '() (cons initial-element result)))
+	  ((zerop count) result)
+	(declare (fixnum count)))))
+
+;;; The outer loop finds the first non-null list and the result is started.
+;;; The remaining lists in the arguments are tacked to the end of the result
+;;; using splice which cdr's down the end of the new list
+
+(defun append (&rest lists)
+  "Construct a new list by concatenating the list arguments"
+  (do ((top lists (cdr top)))	 ;;Cdr to first non-null list.
+      ((atom top) '())
+    (cond ((null (car top)))				; Nil -> Keep looping
+	  ((not (consp (car top)))			; Non cons
+	   (if (cdr top)
+	       (error "~S is not a list." (car top))
+	       (return (car top))))
+	  (t						; Start appending
+	   (return
+	     (if (atom (cdr top))
+		 (car top)    ;;Special case.
+		 (let* ((result (cons (caar top) '())) 
+			(splice result))
+		   (do ((x (cdar top) (cdr x)))  ;;Copy first list
+		       ((atom x))
+		     (setq splice
+			   (cdr (rplacd splice (cons (car x) ()) ))) )
+		   (do ((y (cdr top) (cdr y)))	 ;;Copy rest of lists.
+		       ((atom (cdr y))
+			(setq splice (rplacd splice (car y)))
+			result)
+		     (if (listp (car y))
+			 (do ((x (car y) (cdr x)))   ;;Inner copy loop.
+			     ((atom x))
+			   (setq
+			    splice
+			    (cdr (rplacd splice (cons (car x) ())))))
+			 (error "~S is not a list." (car y)))))))))))
+  
+
+;;; List Copying Functions
+
+
+;;; The list is copied correctly even if the list is not terminated by ()
+;;; The new list is built by cdr'ing splice which is always at the tail
+;;; of the new list
+
+(defun copy-list (list)
+  "Returns a new list EQUAL but not EQ to list"
+  (if (atom list)
+      (if list
+	  (error "~S is not a list." list))
+      (let ((result (cons (car list) '()) ))
+	(do ((x (cdr list) (cdr x))
+	     (splice result
+		     (cdr (rplacd splice (cons (car x) '() ))) ))
+	    ((atom x) (unless (null x)
+			      (rplacd splice x))
+		      result)))))
+
+(defun copy-alist (alist)
+  "Returns a new association list equal to alist, constructed in space"
+  (if (atom alist)
+      (if alist
+	  (error "~S is not a list." alist))
+      (let ((result
+	     (cons (if (atom (car alist))
+		       (car alist)
+		       (cons (caar alist) (cdar alist)) )
+		   '() )))	      
+	(do ((x (cdr alist) (cdr x))
+	     (splice result
+		     (cdr (rplacd splice
+				  (cons
+				   (if (atom (car x)) 
+				       (car x)
+				       (cons (caar x) (cdar x)))
+				   '() ))) ))
+;;; Non-null terminated alist done here.
+	    ((atom x) (unless (null x)
+			      (rplacd splice x))
+		      result)))))
+
+(defun copy-tree (object)
+  "Copy-Tree recursively copys trees of conses."
+  (cond ((not (consp object)) object)
+	(T (cons (copy-tree (car object)) (copy-tree (cdr object)))) ))
+
+;;; More Commonly-used List Functions
+
+(defun revappend (x y)
+  "Returns (append (reverse x) y)"
+  (do ((top x (cdr top))
+       (result y (cons (car top) result)))
+      ((endp top) result)))
+
+;;; NCONC finds the first non-null list, so it can make splice point
+;;; to a cons.  After finding the first cons element, it holds it in
+;;; a result variable while running down successive elements tacking
+;;; them together.  While tacking lists together, if we encounter a
+;;; null list, we set the previous list's last cdr to nil just in case
+;;; it wasn't already nil, and it could have been dotted while the null
+;;; list was the last argument to NCONC.  The manipulation of splice (that
+;;; is starting it out on a first cons, setting LAST of splice, and
+;;; setting splice to ele) inherently handles (nconc x x), and it avoids
+;;; running down the last argument to NCONC which allows the last argument
+;;; to be circular.
+;;; 
+(defun nconc (&rest lists)
+  "Concatenates the lists given as arguments (by changing them)"
+  (do ((top lists (cdr top)))
+      ((null top) nil)
+    (typecase (car top)
+      (cons
+       (let* ((result (car top))
+	      (splice result))
+	 (dolist (ele (cdr top))
+	   (typecase ele
+	     (cons (rplacd (last splice) ele)
+		   (setf splice ele))
+	     (null (rplacd (last splice) nil))
+	     (t (error "Argument is not a list -- ~S." ele))))
+	 (return result)))
+      (null)
+      (t (error "Argument is not a list -- ~S." (car top))))))
+
+(defun nreconc (x y)
+  "Returns (nconc (nreverse x) y)"
+  (do ((1st (cdr x) (if (atom 1st) 1st (cdr 1st)))
+       (2nd x 1st)		;2nd follows first down the list.
+       (3rd y 2nd))		;3rd follows 2nd down the list.
+      ((atom 2nd) 3rd)
+    (rplacd 2nd 3rd)))
+
+(defun butlast (list &optional (n 1))
+  "Returns a new list the same as List without the N last elements."
+  (unless (integerp n)
+    (error "Wrong type argument, ~S, should have been of type INTEGER."))
+  (if (< n 0) (setq n 0))
+  (let ((length (1- (length (the list list)))))
+    (declare (fixnum length))
+    (if (< length n)
+	()
+	(do* ((top (cdr list) (cdr top))
+	      (result (list (car list)))
+	      (splice result)
+	      (count length (1- count)))
+	     ((= count n) result)
+	  (setq splice (cdr (rplacd splice (list (car top)))))))))
+
+(defun nbutlast (list &optional (n 1))
+  "Modifies List to remove the last N elements."
+  (unless (integerp n)
+    (error "Wrong type argument, ~S, should have been of type INTEGER."))
+  (if (< n 0) (setq n 0))
+  (let ((length (1- (length (the list list)))))
+    (declare (fixnum length))
+    (if (< length n) ()
+	(do ((1st (cdr list) (cdr 1st))
+	     (2nd list 1st)
+	     (count length (1- count)))
+	    ((= count n)
+	     (rplacd 2nd ())
+	     list)))))
+
+(defun ldiff (list sublist)
+  "Returns a new list, whose elements are those of List that appear before
+   Sublist.  If Sublist is not a tail of List, a copy of List is returned."
+  (do* ((list list (cdr list))
+	(result (list ()))
+	(splice result))
+       ((or (null list) (eq list sublist)) (cdr result))
+    (setq splice (cdr (rplacd splice (list (car list)))))))
+
+;;; Functions to alter list structure
+
+(defun rplaca (x y)
+  "Changes the car of x to y and returns the new x."
+  (rplaca x y))
+
+(defun rplacd (x y)
+  "Changes the cdr of x to y and returns the new x."
+  (rplacd x y))
+
+;;; The following are for use by SETF.
+
+(defun %rplaca (x val) (rplaca x val) val)
+
+(defun %rplacd (x val) (rplacd x val) val)
+
+(defun %setnth (n list newval)
+  (declare (fixnum n))
+  "Sets the Nth element of List (zero based) to Newval."
+  (if (< n 0)
+      (error "~S is an illegal N for SETF of NTH." n)
+      (do ((count n (1- count)))
+	  ((zerop count) (rplaca list newval) newval)
+	(declare (fixnum count))
+	(if (endp (cdr list))
+	    (error "~S is too large an index for SETF of NTH." n)
+	    (setq list (cdr list))))))
+
+;;;; Macros for (&key (key #'identity) (test #'eql testp) (test-not nil notp)).
+;;; Use these with the following keyword args:
+;;;
+(defmacro with-set-keys (funcall)
+  `(cond ((and testp notp) (error "Test and test-not both supplied."))
+	 (notp ,(append funcall '(:key key :test-not test-not)))
+	 (t ,(append funcall '(:key key :test test)))))
+
+(defmacro satisfies-the-test (item elt)
+  `(cond (testp
+	  (funcall test ,item (funcall key ,elt)))
+	 (notp
+	  (not (funcall test-not ,item (funcall key ,elt))))
+	 (t (funcall test ,item (funcall key ,elt)))))
+
+
+;;; Substitution of expressions
+
+
+
+(defun subst (new old tree &key (key #'identity)
+		  (test #'eql testp) (test-not nil notp))
+  "Substitutes new for subtrees matching old."
+  (labels ((s (subtree)
+	      (cond ((satisfies-the-test old subtree) new)
+		    ((atom subtree) subtree)
+		    (t (let ((car (s (car subtree)))
+			     (cdr (s (cdr subtree))))
+			 (if (and (eq car (car subtree))
+				  (eq cdr (cdr subtree)))
+			     subtree
+			     (cons car cdr)))))))
+    (s tree)))
+
+(defun subst-if (new test tree &key (key #'identity))
+  "Substitutes new for subtrees for which test is true."
+  (labels ((s (subtree)
+	      (cond ((funcall test (funcall key subtree)) new)
+		    ((atom subtree) subtree)
+		    (t (let ((car (s (car subtree)))
+			     (cdr (s (cdr subtree))))
+			 (if (and (eq car (car subtree))
+				  (eq cdr (cdr subtree)))
+			     subtree
+			     (cons car cdr)))))))
+    (s tree)))
+
+(defun subst-if-not (new test tree &key (key #'identity))
+  "Substitutes new for subtrees for which test is false."
+  (labels ((s (subtree)
+	      (cond ((not (funcall test (funcall key subtree))) new)
+		    ((atom subtree) subtree)
+		    (t (let ((car (s (car subtree)))
+			     (cdr (s (cdr subtree))))
+			 (if (and (eq car (car subtree))
+				  (eq cdr (cdr subtree)))
+			     subtree
+			     (cons car cdr)))))))
+    (s tree)))
+
+(defun nsubst (new old tree &key (key #'identity)
+		  (test #'eql testp) (test-not nil notp))
+  "Substitutes new for subtrees matching old."
+  (labels ((s (subtree)
+	      (cond ((satisfies-the-test old subtree) new)
+		    ((atom subtree) subtree)
+		    (t (do* ((last nil subtree)
+			     (subtree subtree (Cdr subtree)))
+			    ((atom subtree)
+			     (if (satisfies-the-test old subtree)
+				 (setf (cdr last) new)))
+			 (if (satisfies-the-test old subtree)
+			     (return (setf (cdr last) new))
+			     (setf (car subtree) (s (car subtree)))))
+		       subtree))))
+    (s tree)))
+
+(defun nsubst-if (new test tree &key (key #'identity))
+  "Substitutes new for subtrees of tree for which test is true."
+  (labels ((s (subtree)
+	      (cond ((funcall test (funcall key subtree)) new)
+		    ((atom subtree) subtree)
+		    (t (do* ((last nil subtree)
+			     (subtree subtree (Cdr subtree)))
+			    ((atom subtree)
+			     (if (funcall test (funcall key subtree))
+				 (setf (cdr last) new)))
+			 (if (funcall test (funcall key subtree))
+			     (return (setf (cdr last) new))
+			     (setf (car subtree) (s (car subtree)))))
+		       subtree))))
+    (s tree)))
+
+(defun nsubst-if-not (new test tree &key (key #'identity))
+  "Substitutes new for subtrees of tree for which test is false."
+  (labels ((s (subtree)
+	      (cond ((not (funcall test (funcall key subtree))) new)
+		    ((atom subtree) subtree)
+		    (t (do* ((last nil subtree)
+			     (subtree subtree (Cdr subtree)))
+			    ((atom subtree)
+			     (if (not (funcall test (funcall key subtree)))
+				 (setf (cdr last) new)))
+			 (if (not (funcall test (funcall key subtree)))
+			     (return (setf (cdr last) new))
+			     (setf (car subtree) (s (car subtree)))))
+		       subtree))))
+    (s tree)))
+
+
+
+
+(defun sublis (alist tree &key (key #'identity)
+		     (test #'eql) (test-not nil notp))
+  "Substitutes from alist into tree nondestructively."
+  (labels ((s (subtree)
+	      (let ((assoc
+		     (if notp
+			 (assoc (funcall key subtree) alist :test-not test-not)
+			 (assoc (funcall key subtree) alist :test test))))
+		(cond (assoc (cdr assoc))
+		      ((atom subtree) subtree)
+		      (t (let ((car (s (car subtree)))
+			       (cdr (s (cdr subtree))))
+			   (if (and (eq car (car subtreE))
+				    (eq cdr (cdr subtree)))
+			       subtree
+			       (cons car cdr))))))))
+    (s tree)))
+
+;;; In run-time env, since can be referenced in line expansions.
+(defmacro nsublis-macro ()
+  '(if notp
+       (assoc (funcall key subtree) alist :test-not test-not)
+       (assoc (funcall key subtree) alist :test test)))
+
+(defun nsublis (alist tree &key (key #'identity)
+		  (test #'eql) (test-not nil notp))
+  "Substitutes new for subtrees matching old."
+  (let (temp)
+    (labels ((s (subtree)
+		(cond ((Setq temp (nsublis-macro))
+		       (cdr temp))
+		      ((atom subtree) subtree)
+		      (t (do* ((last nil subtree)
+			       (subtree subtree (Cdr subtree)))
+			      ((atom subtree)
+			       (if (setq temp (nsublis-macro))
+				   (setf (cdr last) (cdr temp))))
+			   (if (setq temp (nsublis-macro))
+			       (return (setf (Cdr last) (Cdr temp)))
+			       (setf (car subtree) (s (car subtree)))))
+			 subtree))))
+      (s tree))))
+
+
+;;; Functions for using lists as sets
+
+(defun member (item list &key (key #'identity) (test #'eql testp)
+		    (test-not nil notp))
+  "Returns tail of list beginning with first element satisfying EQLity,
+   :test, or :test-not with a given item."
+  (do ((list list (cdr list)))
+      ((null list) nil)
+    (let ((car (car list)))
+      (if (satisfies-the-test item car)
+	  (return list)))))
+
+(defun member-if (test list &key (key #'identity))
+  "Returns tail of list beginning with first element satisfying test(element)"
+  (unless (listp list)
+    (error "~S is not a list." list))
+  (do ((list list (Cdr list)))
+      ((endp list) nil)
+    (if (funcall test (funcall key (car list)))
+	(return list))))
+
+(defun member-if-not (test list &key (key #'identity))
+  "Returns tail of list beginning with first element not satisfying test(el)"
+  (unless (listp list)
+    (error "~S is not a list." list))
+  (do ((list list (cdr list)))
+      ((endp list) ())
+    (if (not (funcall test (funcall key (car list))))
+	(return list)))))
+
+(defun tailp (sublist list)
+  "Returns T if sublist is one of the cons'es in list"
+  (do ((x list (cdr x)))
+      ((endp x) '())
+    (if (eq x sublist) (return T))))
+
+(defun adjoin (item list &key (key #'identity) (test #'eql) (test-not nil notp))
+  "Add item to list unless it is already a member"
+  (if (if notp (member (funcall key item) list :test-not test-not :key key)
+	  (member (funcall key item) list :test test :key key))
+      list
+      (cons item list)))
+
+(defun union (list1 list2  &key (key #'identity)
+			       (test #'eql testp) (test-not nil notp))
+  "Returns the union of list1 and list2."
+  (if (and testp notp)
+      (error "Test and test-not both supplied."))
+  (let ((res list1))
+    (dolist (elt list2)
+      (if (not (with-set-keys (member (funcall key elt) list1)))
+	  (push elt res)))
+    res))
+
+;;; Destination and source are setf-able and many-evaluable.
+;;; Sets the source to the cdr, and "conses" the 1st elt of source to destination.
+(defmacro steve-splice (source destination)
+  `(let ((temp ,source))
+     (setf ,source (Cdr ,source)
+	   (cdr temp) ,destination
+	   ,destination temp)))
+
+(Defun nunion (list1 list2 &key (key #'identity)
+		     (test #'eql testp) (test-not nil notp))
+  "Destructively returns the union list1 and list2."
+  (if (and testp notp)
+      (error "Test and test-not both supplied."))
+  (let ((res list1))
+    (do () ((endp list2))
+      (if (not (with-set-keys (member (funcall key (car list2)) list1)))
+	  (steve-splice list2 res)
+	  (Setq list2 (cdr list2))))
+    res))
+  
+
+
+
+(defun intersection (list1 list2  &key (key #'identity)
+			       (test #'eql testp) (test-not nil notp))
+  "Returns the intersection of list1 and list2."
+  (if (and testp notp)
+      (error "Test and test-not both supplied."))
+  (let ((res nil))
+    (dolist (elt list1)
+      (if (with-set-keys (member (funcall key elt) list2))
+	  (push elt res)))
+    res))
+
+(Defun nintersection (list1 list2 &key (key #'identity)
+		     (test #'eql testp) (test-not nil notp))
+  "Destructively returns the intersection of list1 and list2."
+  (if (and testp notp)
+      (error "Test and test-not both supplied."))
+  (let ((res nil))
+    (do () ((endp list1))
+      (if (with-set-keys (member (funcall key (car list1)) list2))
+	  (steve-splice list1 res)
+	  (setq list1 (Cdr list1))))
+    res))
+
+(Defun set-difference (list1 list2 &key (key #'identity)
+			     (test #'eql testp) (test-not nil notp))
+  "Returns the elements of list1 which are not in list2."
+  (if (and testp notp)
+      (error "Test and test-not both supplied."))
+  (if (null list2)
+      list1
+      (let ((res nil))
+	(dolist (elt list1)
+	  (if (not (with-set-keys (member (funcall key elt) list2)))
+	      (push elt res)))
+	res)))
+
+
+(Defun nset-difference (list1 list2 &key (key #'identity)
+			      (test #'eql testp) (test-not nil notp))
+  "Destructively returns the elements of list1 which are not in list2."
+  (if (and testp notp)
+      (error "Test and test-not both supplied."))
+  (let ((res nil))
+    (do () ((endp list1))
+      (if (not (with-set-keys (member (funcall key (car list1)) list2)))
+	  (steve-splice list1 res)
+	  (setq list1 (cdr list1))))
+    res))
+
+
+(defun set-exclusive-or (list1 list2 &key (key #'identity)
+			       (test #'eql testp) (test-not nil notp))
+  "Returns new list of elements appearing exactly once in list1 and list2."
+  (let ((result nil))
+    (dolist (elt list1)
+      (unless (with-set-keys (member (funcall key elt) list2))
+	(setq result (cons elt result))))
+    (dolist (elt list2)
+      (unless (with-set-keys (member (funcall key elt) list1))
+	(setq result (cons elt result))))
+    result))
+
+
+;;; The outer loop examines list1 while the inner loop examines list2. If an
+;;; element is found in list2 "equal" to the element in list1, both are
+;;; spliced out. When the end of list1 is reached, what is left of list2 is
+;;; tacked onto what is left of list1.  The splicing operation ensures that
+;;; the correct operation is performed depending on whether splice is at the
+;;; top of the list or not
+
+(defun nset-exclusive-or (list1 list2 &key (test #'eql) (test-not nil notp)
+				(key #'identity))
+  "Destructively return a list with elements which appear but once in list1
+   and list2."
+  (do ((x list1 (cdr x))
+       (splicex ()))
+      ((endp x)
+       (if (null splicex)
+	   (setq list1 list2)
+	   (rplacd splicex list2))
+       list1)
+    (do ((y list2 (cdr y))
+	 (splicey ()))
+	((endp y) (setq splicex x))
+      (cond ((if notp
+		 (not (funcall test-not (funcall key (car x))
+			       (funcall key (Car y))))
+		 (funcall test (funcall key (car x)) (funcall key (Car y))))
+	     (if (null splicex)
+		 (setq list1 (cdr x))
+		 (rplacd splicex (cdr x)))
+	     (if (null splicey) 
+		 (setq list2 (cdr y))
+		 (rplacd splicey (cdr y)))
+	     (return ()))			; assume lists are really sets
+	    (t (setq splicey y)))))))
+
+(defun subsetp (list1 list2 &key (key #'identity)
+		      (test #'eql testp) (test-not nil notp))
+  "Returns T if every element in list1 is also in list2."
+  (dolist (elt list1)
+    (unless (with-set-keys (member (funcall key elt) list2))
+      (return-from subsetp nil)))
+  T)
+
+
+;;; Functions that operate on association lists
+
+(defun acons (key datum alist)
+  "Construct a new alist by adding the pair (key . datum) to alist"
+  (cons (cons key datum) alist))
+
+(defun pairlis (keys data &optional (alist '()))
+  "Construct an association list from keys and data (adding to alist)"
+  (do ((x keys (cdr x))
+       (y data (cdr y)))
+      ((and (endp x) (endp y)) alist)
+    (if (or (endp x) (endp y)) 
+	(error "The lists of keys and data are of unequal length."))
+    (setq alist (acons (car x) (car y) alist))))
+
+
+;;; In run-time environment, since these guys can be inline expanded.
+(defmacro assoc-guts (test-guy)
+  `(do ((alist alist (cdr alist)))
+       ((endp alist))
+     (if (car alist)
+	 (if ,test-guy (return (car alist))))))
+
+
+(defun assoc (item alist &key (key #'identity) test test-not)
+  "Returns the cons in alist whose car is equal (by a given test or EQL) to
+   the Item."
+  (cond (test (assoc-guts (funcall test item (funcall key (caar alist)))))
+	(test-not (assoc-guts (not (funcall test-not item (funcall key (caar alist))))))
+	(t (assoc-guts (eql item (funcall key (caar alist)))))))
+
+(defun assoc-if (predicate alist)
+  "Returns the first cons in alist whose car satisfies the Predicate."
+  (assoc-guts (funcall predicate (caar alist))))
+
+(defun assoc-if-not (predicate alist)
+  "Returns the first cons in alist whose car does not satisfy the Predicate."
+  (assoc-guts (not (funcall predicate (caar alist)))))
+
+
+(defun rassoc (item alist &key (key #'identity) test test-not)
+  (declare (list alist))
+  "Returns the cons in alist whose cdr is equal (by a given test or EQL) to
+   the Item."
+  (cond (test (assoc-guts (funcall test item (funcall key (cdar alist)))))
+	(test-not (assoc-guts (not (funcall test-not item (funcall key (cdar alist))))))
+	(t (assoc-guts (eql item (funcall key (cdar alist)))))))
+
+(defun rassoc-if (predicate alist)
+  "Returns the cons in alist whose cdr satisfies the Predicate."
+  (assoc-guts (funcall predicate (cdar alist))))
+
+(defun rassoc-if-not (predicate alist)
+  "Returns the first cons in alist whose cdr does not satisfy the Predicate."
+  (assoc-guts (not (funcall predicate (cdar alist)))))
+
+(defun map1 (function original-arglists accumulate take-car)
+  "This function is called by mapc, mapcar, mapcan, mapl, maplist, and mapcon.
+  It Maps function over the arglists in the appropriate way. It is done when any
+  of the arglists runs out.  Until then, it CDRs down the arglists calling the
+  function and accumulating results as desired."
+
+  (let* ((arglists (copy-list original-arglists))
+	 (ret-list (list nil)) 
+	 (temp ret-list))
+    (do ((res nil)
+	 (args '() '()))
+	((dolist (x arglists nil) (if (null x) (return t)))
+	 (if accumulate
+	     (cdr ret-list)
+	     (car original-arglists)))
+      (do ((l arglists (cdr l)))
+	  ((null l))
+	(push (if take-car (caar l) (car l)) args)
+	(setf (car l) (cdar l)))
+      (setq res (apply function (nreverse args)))
+      (case accumulate
+	(:nconc (setq temp (last (nconc temp res))))
+	(:list (rplacd temp (list res))
+	       (setq temp (cdr temp)))))))
+
+
+(defun mapc (function list &rest more-lists)
+  "Applies fn to successive elements of lists, returns its second argument."
+  (map1 function (cons list more-lists) nil t))
+
+(defun mapcar (function list &rest more-lists)
+  "Applies fn to successive elements of list, returns list of results."
+  (map1 function (cons list more-lists) :list t))
+
+(defun mapcan (function list &rest more-lists)
+  "Applies fn to successive elements of list, returns NCONC of results."
+  (map1 function (cons list more-lists) :nconc t))
+
+(defun mapl (function list &rest more-lists)
+  "Applies fn to successive CDRs of list, returns ()."
+  (map1 function (cons list more-lists) nil nil))
+
+(defun maplist (function list &rest more-lists)
+  "Applies fn to successive CDRs of list, returns list of results."
+  (map1 function (cons list more-lists) :list nil))
+
+(defun mapcon (function list &rest more-lists)
+  "Applies fn to successive CDRs of lists, returns NCONC of results."
+  (map1 function (cons list more-lists) :nconc nil))
+
+
+;;; Functions for compatibility sake:
+
+(defun memq (item list)
+  "Returns tail of list beginning with first element eq to item"
+  (memq item list))
+
+(defun assq (item alist)
+  "Return the first pair of alist where item EQ the key of pair"
+  (assq item alist))
+
+(defun delq (item list &optional (n 0 np))
+  (declare (fixnum n))
+  "Returns list with all (up to n) elements with all elements EQ to ITEM
+   deleted"
+  (do ((x list (cdr x))
+       (splice '()))
+      ((or (endp x)
+	   (and np (zerop n))) list)
+    (cond ((eq item (car x))
+	   (setq n (1- n))
+	   (if (null splice) 
+	       (setq list (cdr x))
+	       (rplacd splice (cdr x))))
+	  (T (setq splice x)))))	; move splice along to include element
diff --git a/code/load.lisp b/code/load.lisp
new file mode 100644
index 000000000..2144e68dd
--- /dev/null
+++ b/code/load.lisp
@@ -0,0 +1,1022 @@
+;;; -*- Log: code.log; Package: Lisp -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; Loader for Spice Lisp.
+;;; Written by Skef Wholey and Rob MacLachlan.
+;;;
+(in-package "LISP")
+(export '(load *load-verbose*))
+
+(in-package "SYSTEM")
+(export 'resolve-loaded-assembler-references)
+
+(in-package "EXTENSIONS")
+(export '*load-if-source-newer*)
+
+(in-package "LISP")
+
+
+;;;; Random state variables:
+
+(defvar *load-verbose* ()
+  "The default for the :Verbose argument to Load.")
+(defvar *load-print-stuff* ()
+  "True if we're gonna mumble about what we're loading.")
+(defvar *fasl-file* () "The fasl file we're reading from.")
+(defvar *current-code-format* "The code format that we think we are loading.")
+
+(defvar *in-cold-load* nil)	; True if we are in the cold loader.
+
+(defvar *load-if-source-newer* :load-object
+  "The value of *load-if-source-newer* determines what happens when the
+  source file is newer than the object file.  The possible values are:
+  :load-object - load object file (default), :load-source - load the source
+  file, :compile - compile the source and then load the object file, or
+  :query - ask the user if he wants to load the source or object file.")
+
+(proclaim '(special cold-fop-functions))
+
+;;;; The Fop-Table:
+;;;
+;;;    The table is implemented as a simple-vector indexed by the table
+;;; offset.  We may need to have several, since load can be called recursively.
+
+(defvar *free-fop-tables* (list (make-array 1000))
+  "List of free fop tables for the fasloader.")
+
+(defvar *current-fop-table* ()
+  "The current fop table.")
+
+(defvar *current-fop-table-size* ()
+  "The length of the current fop table.")
+
+(defvar *current-fop-table-index* ()
+  "Index in the fop-table of the next entry to be used.")
+
+(defun grow-fop-table ()
+  (let* ((new-size (* *current-fop-table-size* 2))
+	 (new-table (make-array new-size)))
+    (declare (fixnum new-size) (simple-vector new-table))
+    (replace new-table (the simple-vector *current-fop-table*))
+    (setq *current-fop-table* new-table)
+    (setq *current-fop-table-size* new-size)))
+
+(defmacro push-table (thing)
+  (let ((n-index (gensym)))
+    `(let ((,n-index *current-fop-table-index*))
+       (declare (fixnum ,n-index))
+       (when (= ,n-index (the fixnum *current-fop-table-size*))
+	 (grow-fop-table))
+       (setq *current-fop-table-index* (1+ ,n-index))
+       (setf (svref *current-fop-table* ,n-index) ,thing))))
+
+;;;; The Fop-Stack:
+;;;
+;;;  The is also in a simple-vector, but it grows down, since it is somewhat 
+;;; cheaper to test for overflow that way.
+;;;
+(defvar *fop-stack* (make-array 100)
+  "The fop stack (we only need one!).")
+
+(defvar *fop-stack-pointer* 100
+  "The index of the most recently pushed item on the fop-stack.")
+
+(defvar *fop-stack-pointer-on-entry* ()
+  "The current index into the fop stack when we last recursively entered LOAD.")
+
+
+(defun grow-fop-stack ()
+  (let* ((size (length (the simple-vector *fop-stack*)))
+	 (new-size (* size 2))
+	 (new-stack (make-array new-size)))
+    (declare (fixnum size new-size) (simple-vector new-stack))
+    (replace new-stack (the simple-vector *fop-stack*) :start1 size)
+    (incf *fop-stack-pointer-on-entry* size)
+    (setq *fop-stack-pointer* size)
+    (setq *fop-stack* new-stack)))
+
+;;; With-Fop-Stack  --  Internal
+;;;
+;;;    Cache information about the fop-stack in local variables.  Define
+;;; a local macro to pop from the stack.  Push the result of evaluation if
+;;; specified.
+;;;
+(defmacro with-fop-stack (pushp &body forms)
+  (let ((n-stack (gensym))
+	(n-index (gensym))
+	(n-res (gensym)))
+    `(let ((,n-stack *fop-stack*)
+	   (,n-index *fop-stack-pointer*))
+       (declare (simple-vector ,n-stack) (fixnum ,n-index))
+       (macrolet ((pop-stack ()
+		    `(prog1
+		      (svref ,',n-stack ,',n-index)
+		      (setq ,',n-index (1+ ,',n-index))))
+		  (call-with-popped-things (fun n)
+		    (let ((n-start (gensym)))
+		      `(let ((,n-start (+ ,',n-index ,n)))
+			 (setq ,',n-index ,n-start)
+			 (,fun ,@(make-list n :initial-element
+					    `(svref ,',n-stack
+						    (decf ,n-start))))))))
+	 ,(if pushp
+	      `(let ((,n-res (progn ,@forms)))
+		 (when (zerop ,n-index)
+		   (grow-fop-stack)
+		   (setq ,n-index *fop-stack-pointer*
+			 ,n-stack *fop-stack*))
+		 (decf ,n-index)
+		 (setq *fop-stack-pointer* ,n-index)
+		 (setf (svref ,n-stack ,n-index) ,n-res))
+	      `(prog1
+		(progn ,@forms)
+		(setq *fop-stack-pointer* ,n-index)))))))
+
+;;; FOP database:
+
+(defvar fop-codes (make-array 256)
+  "Vector indexed by a FaslOP that yields the FOP's name.")
+
+(defvar fop-functions
+  (make-array 256 :initial-element #'(lambda () (error "Losing FOP!")))
+  "Vector indexed by a FaslOP that yields a function of 0 arguments which
+  will perform the operation.")
+
+
+;;; Define-FOP  --  Internal
+;;;
+;;;    Defines Name as a fasl operation, with op-code op.  If pushp is :nope,
+;;; the the body neither pushes or pops the fop stack.  If it is nil, then
+;;; the body may pop, but the result is ignored.  If it is true, the the result
+;;; is pushed on the stack.
+;;;
+(defmacro define-fop ((name op &optional (pushp t)) &rest forms)
+  `(progn
+    (defun ,name ()
+      ,(if (eq pushp :nope)
+	   `(progn ,@forms)
+	   `(with-fop-stack ,pushp ,@forms)))
+    (setf (svref fop-codes ,op) ',name)
+    (setf (get ',name 'fop-code) ,op)
+    (setf (svref fop-functions ,op) #',name)))
+
+;;; Clone-Fop  --  Internal
+;;;
+;;;    Defines a pair of fops which are identical except in that one reads
+;;; a four byte argument and the other reads a one byte argument.  The
+;;; argument can be accessed by using the Clone-Arg macro.
+;;;
+(defmacro clone-fop ((name op &optional (pushp t))
+		      (small-name small-op) &rest forms)
+  `(progn
+    (macrolet ((clone-arg () '(read-arg 4)))
+      (define-fop (,name ,op ,pushp) ,@forms))
+    (macrolet ((clone-arg () '(read-arg 1)))
+      (define-fop (,small-name ,small-op ,pushp) ,@forms))))
+
+;;;; Utilities for reading from the fasl file.
+
+(proclaim '(inline read-byte))
+
+;;; Fast-Read-U-Integer  --  Internal
+;;;
+;;;    Expands into code to read an N-byte unsigned integer using
+;;; fast-read-byte.
+;;;
+(defmacro fast-read-u-integer (n)
+  (do ((res '(fast-read-byte)
+	    `(logior (fast-read-byte)
+		     (ash ,res 8)))
+       (cnt 1 (1+ cnt)))
+      ((>= cnt n) res)))
+
+;;; Fast-Read-Variable-U-Integer  --  Internal
+;;;
+;;;    Like Fast-Read-U-Integer, but the size may be determined at run time.
+;;;
+(defmacro fast-read-variable-u-integer (n)
+  (let ((n-pos (gensym))
+	(n-res (gensym))
+	(n-cnt (gensym)))
+    `(do ((,n-pos 8 (+ ,n-pos 8))
+	  (,n-cnt (1- ,n) (1- ,n-cnt))
+	  (,n-res
+	   (fast-read-byte)
+	   (dpb (fast-read-byte) (byte 8 ,n-pos) ,n-res)))
+	 ((zerop ,n-cnt) ,n-res))))
+
+;;; Fast-Read-S-Integer  --  Internal
+;;;
+;;;    Read a signed integer.
+;;;
+(defmacro fast-read-s-integer (n)
+  (let ((n-last (gensym)))
+    (do ((res `(let ((,n-last (fast-read-byte)))
+		 (if (zerop (logand ,n-last #x80))
+		     ,n-last
+		     (logior ,n-last #x-100)))
+	      `(logior (fast-read-byte)
+		       (ash ,res 8)))
+	 (cnt 1 (1+ cnt)))
+	((>= cnt n) res))))
+
+;;; Read-Arg  --  Internal
+;;;
+;;;    Read an N-byte unsigned integer from the *fasl-file*
+;;;
+(defmacro read-arg (n)
+  (if (= n 1)
+      `(read-byte *fasl-file*)
+      `(prepare-for-fast-read-byte *fasl-file*
+	 (prog1
+	  (fast-read-u-integer ,n)
+	  (done-with-fast-read-byte)))))
+
+;;; Fasload:
+
+(defun fasload (stream)
+  (when *load-verbose*
+    (format t "~&; Loading stuff from ~S.~%" stream))
+  (let* ((*fasl-file* stream)
+	 (*current-fop-table* (pop *free-fop-tables*))
+	 (*current-fop-table-size* ())
+	 (*current-fop-table-index* 0)
+	 (*fop-stack-pointer-on-entry* *fop-stack-pointer*))
+    (if (null *current-fop-table*)
+	(setq *current-fop-table* (make-array 1000)))
+    (setq *current-fop-table-size*
+	  (length (the simple-vector *current-fop-table*)))
+    (unwind-protect 
+      (do ((loaded-group (load-group stream) (load-group stream)))
+	  ((not loaded-group)))
+      (setq *fop-stack-pointer* *fop-stack-pointer-on-entry*)
+      ;;
+      ;; Nil out the table, so we don't hold onto garbage.
+      (let ((tab *current-fop-table*))
+	(dotimes (i *current-fop-table-index*)
+	  (declare (fixnum i))
+	  (setf (svref tab i) nil))
+	(push tab *free-fop-tables*))
+      ;;
+      ;; Ditto for the stack...
+      (dotimes (i *fop-stack-pointer-on-entry*)
+	(declare (fixnum i))
+	(setf (svref *fop-stack* i) nil))))
+  t)
+
+#|
+
+(defvar *fop-counts* (make-array 256 :initial-element 0))
+(defvar *fop-times* (make-array 256 :initial-element 0))
+(defvar *print-fops* nil)
+
+(defun clear-counts ()
+  (fill (the simple-vector *fop-counts*) 0)
+  (fill (the simple-vector *fop-times*) 0)
+  t)
+
+(defun analyze-counts ()
+  (let ((counts ())
+	(total-count 0)
+	(times ())
+	(total-time 0))
+    (macrolet ((breakdown (lvar tvar vec)
+		 `(progn
+		   (dotimes (i 255)
+		     (declare (fixnum i))
+		     (let ((n (svref ,vec i)))
+		       (push (cons (svref fop-codes i) n) ,lvar)
+		       (incf ,tvar n)))
+		   (setq ,lvar (subseq (sort ,lvar #'(lambda (x y)
+						       (> (cdr x) (cdr y))))
+				       0 10)))))
+		 
+      (breakdown counts total-count *fop-counts*)
+      (breakdown times total-time *fop-times*)
+      (format t "Total fop count is ~D~%" total-count)
+      (dolist (c counts)
+	(format t "~30S: ~4D~%" (car c) (cdr c)))
+      (format t "~%Total fop time is ~D~%" (/ (float total-time) 60.0))
+      (dolist (m times)
+	(format t "~30S: ~6,2F~%" (car m) (/ (float (cdr m)) 60.0))))))
+|#
+
+;;; Load-Group  --  Internal
+;;;
+;;; Load-Group returns t if it successfully loads a group from the file,
+;;; or () if EOF was encountered while trying to read from the file.
+;;; Dispatch to the right function for each fop.  Special-case fop-byte-push
+;;; since it is real common.
+;;;
+(defun load-group (file)
+  (when (check-header file)
+    (catch 'group-end
+      (let ((*current-code-format* 'uninitialized-code-format))
+	(loop
+	 (let ((byte (read-byte file)))
+	   (if (eql byte 3)
+	       (let ((index *fop-stack-pointer*))
+		 (when (zerop index)
+		   (grow-fop-stack)
+		   (setq index *fop-stack-pointer*))
+		 (decf index)
+		 (setq *fop-stack-pointer* index)
+		 (setf (svref *fop-stack* index)
+		       (svref *current-fop-table* (read-byte file))))
+	       (funcall (svref fop-functions byte)))))))))
+
+;;; Check-Header returns t if t succesfully read a header from the file,
+;;; or () if EOF was hit before anything was read.  An error is signaled
+;;; if garbage is encountered.
+
+(defun check-header (file)
+  (let ((byte (read-byte file NIL '*eof*)))
+    (cond ((eq byte '*eof*) ())
+	  ((eq byte (char-int #\F))
+	   (do ((byte (read-byte file) (read-byte file))
+		(count 1 (1+ count)))
+	       ((= byte 255) t)
+	     (declare (fixnum byte))
+	     (if (and (< count 9)
+		      (not (eql byte (char-int (schar "FASL FILE" count)))))
+		 (error "Bad FASL file format."))))
+	  (t (error "Bad FASL file format.")))))
+
+
+;;; Load-S-Integer loads a signed integer Length bytes long from the File.
+
+(defun load-s-integer (length)  
+  (declare (fixnum length))
+  (do* ((index length (1- index))
+	(byte 0 (read-byte *fasl-file*))
+	(result 0 (+ result (ash byte bits)))
+	(bits 0 (+ bits 8)))
+       ((= index 0)
+	(if (logbitp 7 byte)	; look at sign bit
+	    (- result (ash 1 bits))
+	    result))
+    (declare (fixnum index byte bits))))
+
+;;; Sloload:
+
+;;; Something not EQ to anything read from a file:
+
+(defconstant load-eof-value '(()))
+
+;;; Sloload loads a text file into the given Load-Package.
+
+(defun sloload (stream)
+  (when *load-verbose*
+    (format t "~&; Loading stuff from ~S.~%" stream))
+  (do ((sexpr (read stream nil load-eof-value)
+	      (read stream nil load-eof-value)))
+      ((eq sexpr load-eof-value))
+    (if *load-print-stuff*
+	(format t "~&; ~S~%" (eval sexpr))
+	(eval sexpr))))))
+
+;;; Load:
+
+(defun load (filename &key ((:verbose *load-verbose*) *load-verbose*)
+		      ((:print *load-print-stuff*) *load-print-stuff*)
+		      (if-does-not-exist :error))
+  "Loads the file named by Filename into the Lisp environment.  See manual
+   for details."
+  (let ((*package* *package*))
+    (if (streamp filename)
+	(if (equal (stream-element-type filename) '(unsigned-byte 8))
+	    (fasload filename)
+	    (sloload filename))
+	(let* ((pn (merge-pathnames (pathname filename)
+				    *default-pathname-defaults*))
+	       (tn (probe-file pn)))
+	  (cond
+	   (tn
+	    (if (string-equal (pathname-type tn) "nfasl")
+		(with-open-file (file tn
+				      :direction :input
+				      :element-type '(unsigned-byte 8))
+		  (fasload file))
+		(with-open-file (file tn :direction :input)
+		  (sloload file)))
+	    t)
+	   ((pathname-type pn)
+	    (let ((stream (open pn :direction :input
+				:if-does-not-exist if-does-not-exist)))
+	      (when stream
+		(sloload stream)
+		(close stream)
+		t)))
+	   (t
+	    (let* ((srcn (make-pathname :type "lisp" :defaults pn))
+		   (src (probe-file srcn))
+		   (objn (make-pathname :type "nfasl" :defaults pn))
+		   (obj (probe-file objn)))
+	      (cond
+	       (obj
+		(cond ((and src (> (file-write-date src)
+				   (file-write-date obj)))
+		       (case *load-if-source-newer*
+			 (:load-object
+			  (warn "Loading object file ~A, which is~%  ~
+			         older than the presumed source, ~A."
+				(namestring obj)
+				(namestring src))
+			  (load obj))
+			 (:load-source
+			  (warn "Loading source file ~A, which is~%  ~
+			         newer than the presumed object file, ~A."
+				(namestring src)
+				(namestring obj))
+			  (load src))
+			 (:compile
+			  (compile-file (namestring src))
+			  (load obj))
+			 (:query
+			  (if (y-or-n-p "Load source file ~A which is newer~%  ~
+					 than presumed object file ~A? "
+					(namestring src)
+					(namestring obj))
+			      (load src)
+			      (load obj)))
+			 (T (error "*Load-if-source-newer* contains ~A which is not one of:~%  ~
+			            :load-object, :load-source, :compile, or :query."
+				   *load-if-source-newer*))))
+		      (T (load obj))))
+	       (t
+		(load srcn :if-does-not-exist if-does-not-exist))))))))))
+
+
+;;;; Actual FOP definitions:
+
+(define-fop (fop-nop 0 :nope))
+(define-fop (fop-pop 1 nil) (push-table (pop-stack)))
+(define-fop (fop-pop-for-effect 65 nil) (pop-stack))
+(define-fop (fop-push 2) (svref *current-fop-table* (read-arg 4)))
+(define-fop (fop-byte-push 3) (svref *current-fop-table* (read-arg 1)))
+
+(define-fop (fop-empty-list 4) ())
+(define-fop (fop-truth 5) t)
+(define-fop (fop-misc-trap 66)
+	    (%primitive make-immediate-type 0 lisp::%trap-type))
+
+(define-fop (fop-character 68)
+  (int-char (read-arg 3)))
+(define-fop (fop-short-character 69)
+  (code-char (read-arg 1)))
+
+(define-fop (fop-structure 79)
+  (%primitive set-vector-subtype (pop-stack) 1))
+
+(define-fop (fop-end-group 64 :nope) (throw 'group-end t))
+(define-fop (fop-end-header 255)
+  (error "Fop-End-Header was executed???"))
+
+(define-fop (fop-normal-load 81 :nope))
+(define-fop (fop-maybe-cold-load 82 :nope)
+  (when *in-cold-load*
+    (setq fop-functions cold-fop-functions)))
+
+(define-fop (fop-static-heap 60 :nope))
+(define-fop (fop-dynamic-heap 61 :nope))
+(define-fop (fop-read-only-heap 67 :nope))
+
+(define-fop (fop-verify-table-size 62 :nope)
+  (if (/= *current-fop-table-index* (read-arg 4))
+      (error "Fasl table of improper size.  Bug!")))
+(define-fop (fop-verify-empty-stack 63 :nope)
+  (if (/= *fop-stack-pointer* *fop-stack-pointer-on-entry*)
+      (error "Fasl stack not empty.  Bug!")))
+
+;;;; Loading symbols:
+
+(defvar *load-symbol-buffer* (make-string 100))
+(defvar *load-symbol-buffer-size* 100)
+   
+(macrolet ((frob (name code name-size package)
+	     (let ((n-package (gensym))
+		   (n-size (gensym))
+		   (n-buffer (gensym)))
+	       `(define-fop (,name ,code)
+		  (prepare-for-fast-read-byte *fasl-file*
+		    (let ((,n-package ,package)
+			  (,n-size (fast-read-u-integer ,name-size)))
+		      (when (> ,n-size *load-symbol-buffer-size*)
+			(setq *load-symbol-buffer*
+			      (make-string (setq *load-symbol-buffer-size*
+						 (* ,n-size 2)))))
+		      (done-with-fast-read-byte)
+		      (let ((,n-buffer *load-symbol-buffer*))
+			(read-n-bytes *fasl-file* ,n-buffer 0 ,n-size)
+			(push-table (intern* ,n-buffer ,n-size ,n-package)))))))))
+  (frob fop-symbol-save 6 4 *package*)
+  (frob fop-small-symbol-save 7 1 *package*)
+  (frob fop-lisp-symbol-save 75 4 *lisp-package*)
+  (frob fop-lisp-small-symbol-save 76 1 *lisp-package*)
+  (frob fop-keyword-symbol-save 77 4 *keyword-package*)
+  (frob fop-keyword-small-symbol-save 78 1 *keyword-package*)
+
+  (frob fop-symbol-in-package-save 8 4
+    (svref *current-fop-table* (fast-read-u-integer 4)))
+  (frob fop-small-symbol-in-package-save 9 1
+    (svref *current-fop-table* (fast-read-u-integer 4)))
+  (frob fop-symbol-in-byte-package-save 10 4
+    (svref *current-fop-table* (fast-read-u-integer 1)))
+  (frob fop-small-symbol-in-byte-package-save 11 1
+    (svref *current-fop-table* (fast-read-u-integer 1))))
+
+(clone-fop (fop-uninterned-symbol-save 12)
+	   (fop-uninterned-small-symbol-save 13)
+  (let* ((arg (clone-arg))
+	 (res (make-string arg)))
+    (read-n-bytes *fasl-file* res 0 arg)
+    (push-table (make-symbol res))))
+
+(define-fop (fop-package 14)
+  (let ((name (pop-stack)))
+    (or (find-package name)
+	(error "The package ~S does not exist." name))))
+
+;;;; Loading numbers:
+
+(clone-fop (fop-integer 33)
+	   (fop-small-integer 34)
+  (load-s-integer (clone-arg)))
+
+(define-fop (fop-word-integer 35)
+  (prepare-for-fast-read-byte *fasl-file*
+    (prog1
+     (fast-read-s-integer 4)
+     (done-with-fast-read-byte))))
+(define-fop (fop-byte-integer 36)
+  (prepare-for-fast-read-byte *fasl-file*
+    (prog1
+     (fast-read-s-integer 1)
+     (done-with-fast-read-byte))))
+
+(define-fop (fop-ratio 70)
+  (let ((den (pop-stack)))
+    (%primitive make-ratio (pop-stack) den)))
+
+(define-fop (fop-complex 71)
+  (let ((im (pop-stack)))
+    (%primitive make-complex (pop-stack) im)))
+
+(define-fop (fop-float 45)
+  (let* ((n (read-arg 1))
+	 (exponent (load-s-integer (ceiling n 8)))
+	 (m (read-arg 1))
+	 (mantissa (load-s-integer (ceiling m 8)))
+	 (number (cond ((or (> n 9) (> m 32))
+			(coerce mantissa 'long-float))
+		       ((> m 21)
+			(coerce mantissa 'single-float))
+		       (T (coerce mantissa 'short-float)))))
+    (multiple-value-bind (f ex s) (decode-float number)
+      (declare (ignore ex))
+      (* s (scale-float f exponent)))))
+
+;;;; Loading lists:
+
+(define-fop (fop-list 15)
+  (do ((res () (cons (pop-stack) res))
+       (n (read-arg 1) (1- n)))
+      ((zerop n) res)))
+
+(define-fop (fop-list* 16)
+  (do ((res (pop-stack) (cons (pop-stack) res))
+       (n (read-arg 1) (1- n)))
+      ((zerop n) res)))
+
+(macrolet ((frob (name op fun n)
+	     `(define-fop (,name ,op)
+		(call-with-popped-things ,fun ,n))))
+
+  (frob fop-list-1 17 list 1)
+  (frob fop-list-2 18 list 2)
+  (frob fop-list-3 19 list 3)
+  (frob fop-list-4 20 list 4)
+  (frob fop-list-5 21 list 5)
+  (frob fop-list-6 22 list 6)
+  (frob fop-list-7 23 list 7)
+  (frob fop-list-8 24 list 8)
+
+  (frob fop-list*-1 25 list* 2)
+  (frob fop-list*-2 26 list* 3)
+  (frob fop-list*-3 27 list* 4)
+  (frob fop-list*-4 28 list* 5)
+  (frob fop-list*-5 29 list* 6)
+  (frob fop-list*-6 30 list* 7)
+  (frob fop-list*-7 31 list* 8)
+  (frob fop-list*-8 32 list* 9))
+
+
+;;;; Loading arrays:
+;;;
+
+(clone-fop (fop-string 37)
+	   (fop-small-string 38)
+  (let* ((arg (clone-arg))
+	 (res (make-string arg)))
+    (read-n-bytes *fasl-file* res 0 arg)
+    res))
+
+(clone-fop (fop-vector 39)
+	   (fop-small-vector 40)
+  (let* ((size (clone-arg))
+	 (res (make-array size)))
+    (declare (fixnum size))
+    (do ((n (1- size) (1- n)))
+	((minusp n))
+      (setf (svref res n) (pop-stack)))
+    res))
+
+(clone-fop (fop-uniform-vector 41)
+	   (fop-small-uniform-vector 42)
+  (make-array (clone-arg) :initial-element (pop-stack)))
+
+(define-fop (fop-array 83)
+  (let* ((rank (read-arg 4))
+	 (vec (pop-stack))
+	 (size (+ rank %array-first-dim-slot))
+	 (length (length vec))
+	 (res (%primitive alloc-array rank)))
+    (declare (simple-array vec))
+    (set-array-header res vec length length 0
+		      (do ((i (1- size) (1- i))
+			   (dimensions () (cons (pop-stack) dimensions)))
+			  ((< i %array-first-dim-slot) dimensions))
+		      nil)
+    res))
+
+
+;;; Fop-Int-Vector  --  Internal
+;;;
+;;;    Load an I-Vector using the Guy Steele memorial faslop.  If there
+;;; is no space at the end of a group, then we can read it using
+;;; Read-N-Bytes.  All vectors dumped by our compiler should be loadable
+;;; in this way.  If the other cases don't work, we may never know...
+;;;
+(define-fop (fop-int-vector 43)
+  (prepare-for-fast-read-byte *fasl-file*
+    (let* ((n (fast-read-u-integer 4))
+	   (size (fast-read-byte))
+	   (count (fast-read-byte))
+	   (res (make-array n :element-type `(unsigned-byte ,size))))
+      (multiple-value-bind (ints-per-entry extra)
+			   (truncate (* count 8) size)
+	(cond ((and (zerop extra) (<= size 16))
+	       (done-with-fast-read-byte)
+	       (read-n-bytes *fasl-file* res 0
+			     (* count (ceiling n ints-per-entry))))
+	      ((= ints-per-entry 1)
+	       (dotimes (i n)
+		 (setf (aref res i) (fast-read-variable-u-integer count)))
+	       (done-with-fast-read-byte))
+	      (t
+	       (let ((i 0))
+		 (loop
+		   (when (= i n) (return))
+		   (let ((byte (fast-read-byte)))
+		     (dotimes (j ints-per-entry)
+		       (setf (aref res i) (ldb (byte size (* size j)) byte))
+		       (incf i)
+		       (when (= i n) (return))))))
+	       (done-with-fast-read-byte))))
+      res)))
+
+(define-fop (fop-uniform-int-vector 44)
+  (prepare-for-fast-read-byte *fasl-file*
+    (let* ((n (fast-read-u-integer 4))
+	   (size (fast-read-byte))
+	   (value (fast-read-variable-u-integer (ceiling size 8))))
+      (done-with-fast-read-byte)
+      (make-array n :element-type `(unsigned-byte ,size)
+		  :initial-element value))))
+
+(define-fop (fop-alter 52 nil)
+  (let ((index (read-arg 1))
+	(newval (pop-stack))
+	(object (pop-stack)))
+    (declare (fixnum index))
+    (typecase object
+      (list (case index
+	      (0 (rplaca object newval))
+	      (1 (rplacd object newval))
+	      (t (error "~S: Bad index for FaslOP Alter.  Bug!"))))
+      (symbol (case index
+		(0 (set object newval))
+		(1 (setf (symbol-function object) newval))
+		(2 (setf (symbol-plist object) newval))
+		(t (error "~S: Bad index for FaslOP Alter.  Bug!"))))
+      (array (setf (aref object index) newval))
+      (t (error "~S: Bad object for FaslOP Alter.  Bug!")))))
+
+(define-fop (fop-eval 53)
+  (let ((result (eval (pop-stack))))
+    (when *load-print-stuff*
+      (format t "~&; ~S~%" result))
+    result))
+
+(define-fop (fop-eval-for-effect 54 nil)
+  (let ((result (eval (pop-stack))))
+    (when *load-print-stuff*
+      (format t "~&; ~S~%" result))))
+
+(define-fop (fop-funcall 55)
+  (let ((arg (read-arg 1)))
+    (if (zerop arg)
+	(funcall (pop-stack))
+	(do ((args () (cons (pop-stack) args))
+	     (n arg (1- n)))
+	    ((zerop n) (apply (pop-stack) args))))))
+
+(define-fop (fop-funcall-for-effect 56 nil)
+  (let ((arg (read-arg 1)))
+    (if (zerop arg)
+	(funcall (pop-stack))
+	(do ((args () (cons (pop-stack) args))
+	     (n arg (1- n)))
+	    ((zerop n) (apply (pop-stack) args))))))
+
+;;;; Fixing up circularities.
+(define-fop (fop-rplaca 200 nil)
+  (let ((obj (svref *current-fop-table* (read-arg 4)))
+	(idx (read-arg 4))
+	(val (pop-stack)))
+    (setf (car (nthcdr idx obj)) val)))
+
+
+(define-fop (fop-rplacd 201 nil)
+  (let ((obj (svref *current-fop-table* (read-arg 4)))
+	(idx (read-arg 4))
+	(val (pop-stack)))
+    (setf (cdr (nthcdr idx obj)) val)))
+
+(define-fop (fop-svset 202 nil)
+  (let* ((obi (read-arg 4))
+	 (obj (svref *current-fop-table* obi))
+	 (idx (read-arg 4))
+	 (val (pop-stack)))
+    (setf (svref obj idx) val)))
+
+(define-fop (fop-nthcdr 203 t)
+  (nthcdr (read-arg 4) (pop-stack)))
+
+;;;; Loading functions:
+
+(define-fop (fop-code-format 57 :nope)
+  (setq *current-code-format* (read-arg 1)))
+
+
+;;; Load-Code loads a code object.  NItems objects are popped off the stack for
+;;; the boxed storage section, then Size bytes of code are read in.  This must
+;;; be done WITHOUT-GCING, since GC only recognizes code object references that
+;;; appear in a function object.  If a GC happened before we stored the code
+;;; object, the code would disappear.
+;;;
+(defmacro load-code (nitems size)
+  `(without-gcing
+     (let ((box-num ,nitems)
+	   (code-length ,size))
+       (declare (fixnum box-num code-length))
+       (let ((function (%primitive alloc-function box-num)))
+	 (%primitive set-vector-subtype function %function-constants-subtype)
+	 (do ((index (1- box-num) (1- index)))
+	     ((minusp index))
+	   (declare (fixnum index))
+	   (%primitive header-set function index (pop-stack)))
+	 (let ((code (%primitive alloc-code code-length)))
+	   (read-n-bytes *fasl-file* code 0 code-length)
+	   (%primitive header-set function %function-code-slot code))
+	 (when *load-print-stuff*
+	   (format t "~&; ~S~%" function))
+	 function))))
+
+(define-fop (fop-code 58)
+  (if (eql *current-code-format* %fasl-code-format)
+      (load-code (read-arg 4) (read-arg 4))
+      (error "~A has an incompatible fasl file format.~@
+               You must recompile the source code."
+	     *fasl-file*)))
+
+
+(define-fop (fop-small-code 59)
+  (if (eql *current-code-format* %fasl-code-format)
+      (load-code (read-arg 1) (read-arg 2))
+      (error "~A has an incompatible fasl file format.~@
+               You must recompile the source code."
+	     *fasl-file*)))
+
+
+;;; Now a NOOP except in cold load... 
+(define-fop (fop-fset 74 nil)
+  (pop-stack)
+  (pop-stack))
+
+
+;;; Modify a slot in a Constants object.
+;;;
+(clone-fop (fop-alter-code 140 nil) (fop-byte-alter-code 141)
+  (let ((value (pop-stack))
+	(code (pop-stack))
+	(index (clone-arg)))
+    (%primitive header-set code index value)))
+
+
+;;; Kind of like Load-Code, except that we set the Code and Constants
+;;; slots from the Constants object that is our first stack argument.  The
+;;; subtype is set to the second stack argument.
+;;;
+(define-fop (fop-function-entry 142)
+  (let* ((box-num (read-arg 1))
+	 (function (%primitive alloc-function box-num)))
+    ;;
+    ;; Pop boxed things, storing them in the allocated entry object.
+    (do ((index (1- box-num) (1- index)))
+	((minusp index))
+      (%primitive header-set function index (pop-stack)))
+    ;;
+    ;; Set the subtype of the entry object.
+    (%primitive set-vector-subtype function (pop-stack))
+    ;;
+    ;; Set code and constants slots in the entry.
+    (let* ((constants (pop-stack))
+	   (code (%primitive header-ref constants %function-code-slot)))
+      (%primitive header-set function %function-code-slot code)
+      (%primitive header-set function %function-entry-constants-slot
+		  constants))
+
+    function))
+
+
+
+(define-fop (fop-user-miscop-fixup 134)
+  (let* ((miscop-name (pop-stack))
+	 (function-object (pop-stack))
+	 (code (%primitive header-ref function-object %function-code-slot))
+	 (offset (read-arg 4))
+	 (loaded-addr (get miscop-name '%loaded-address)))
+    (unless loaded-addr
+      (error "Miscop ~A is undefined." miscop-name))
+    
+    (let ((hi-addr (logior (ash clc::type-assembler-code
+				clc::type-shift-16)
+			   (logand (ash loaded-addr -16) #xFFFF))))
+      (setf (aref code (+ offset 1)) (logand hi-addr #xFF))
+      (setf (aref code (+ offset 2))
+	    (logand (ash loaded-addr -8) #xFF))
+      (setf (aref code (+ offset 3))
+	    (logand loaded-addr #xFF)))
+
+    function-object))
+
+
+;;;; Loading assembler routines:
+;;;
+
+;;; Allocate-Assembler-Code  --  Internal
+;;;
+;;;    Allocate some stuff out of assembler code space.
+;;;
+(defun allocate-assembler-code (bytes)
+  (let* ((idx (ash %assembler-code-type %alloc-ref-type-shift))
+	 (free (alloc-ref idx))
+	 (new (+ free bytes)))
+    (prog1
+      (%primitive make-immediate-type free %assembler-code-type)
+      (%primitive 16bit-system-set alloctable-address idx (ash new -16))
+      (%primitive 16bit-system-set alloctable-address (1+ idx)
+		  (logand new #xFFFF)))))
+
+(define-fop (fop-assembler-routine 130)
+  (let* ((code-length (read-arg 4))
+	 (buffer (make-array code-length :element-type '(unsigned-byte 8)))
+	 (code (allocate-assembler-code code-length)))
+    (declare (fixnum code-length))
+    (read-n-bytes *fasl-file* buffer 0 code-length)
+    (%primitive byte-blt buffer 0 code 0 code-length)
+    code))
+
+;;; A list of the miscop definitions which have been loaded but not
+;;; resolved.  Each element is a cons (name . code-ptr).
+;;;
+(defvar *miscop-definitions* ())
+
+
+;;; Recall that the format of a reference is (How Label Location),
+;;; where How is one of JI, BI, BA, or L, Label is the label's name, and
+;;; Location is the location of the reference.  These things are stored on
+;;; the list *external-references* as (Name . References), where Name is
+;;; the name of the referencing routine, and References is a list of references
+;;; in the above format.
+;;;
+(defvar *external-references* ())
+(defvar *user-defined-miscops* ())
+
+(define-fop (fop-fixup-miscop-routine 131 nil)
+  (let* ((external-references (pop-stack))
+	 (external-labels (pop-stack))
+	 (name (pop-stack))
+	 (code (pop-stack))
+	 (start (%primitive make-immediate-type code %+-fixnum-type)))
+    (dolist (lab external-labels)
+      (setf (get (car lab) '%loaded-address) (+ (ash (cdr lab) 1) start)))
+    (push (cons name external-references) *external-references*)
+    (push (cons name code) *miscop-definitions*)))
+
+(define-fop (fop-fixup-user-miscop-routine 133 nil)
+  (let* ((external-references (pop-stack))
+	 (external-labels (pop-stack))
+	 (name (pop-stack))
+	 (code (pop-stack))
+	 (start (%primitive make-immediate-type code %+-fixnum-type)))
+    (dolist (lab external-labels)
+      (setf (get (car lab) '%loaded-address) (+ (ash (cdr lab) 1) start)))
+    (push (cons name external-references) *external-references*)
+    (pushnew name *user-defined-miscops*)
+    (setf (get name 'user-miscop) t)))
+
+(define-fop (fop-fixup-assembler-routine 132 nil)
+  (let* ((external-references (pop-stack))
+	 (external-labels (pop-stack))
+	 (name (pop-stack))
+	 (code (pop-stack))
+	 (start (%primitive make-immediate-type code %+-fixnum-type)))
+    (dolist (lab external-labels)
+      (setf (get (car lab) '%loaded-address) (+ (ash (cdr lab) 1) start)))
+    (push (cons name external-references) *external-references*)))
+
+;;; Resolving all the assembler routines' references.
+
+;;; Patch-Instruction  --  Internal
+;;;
+;;;    Used to patch an assembler code object.  Hi-var and lo-var are
+;;; bound to the values of the high and low halfwords in the instruction.
+;;; The values may by changed by setting the variables.
+;;;
+(defmacro patch-instruction ((hi-var lo-var code offset) &body body)
+  `(let ((,hi-var (%primitive 16bit-system-ref ,code ,offset))
+	 (,lo-var (%primitive 16bit-system-ref ,code (1+ ,offset))))
+     (multiple-value-prog1
+      (progn ,@body)
+      (%primitive 16bit-system-set ,code ,offset ,hi-var)
+      (%primitive 16bit-system-set ,code (1+ ,offset) ,lo-var))))
+
+;;; Resolve-Loaded-Assembler-References  --  Public
+;;;
+;;;    Fix up the recorded external references and define the miscops.
+;;;
+(defun resolve-loaded-assembler-references ()
+  "This function resolves external label references in loaded assembler
+  routines.  It should be called after assembler files have been loaded.
+  Miscop definitions do not take effect until this function is called."
+  (dolist (reflist *external-references*)
+    (let* ((code-byte-offset (get (car reflist) '%loaded-address))
+	   (code-halfword-offset (ash code-byte-offset -1))
+	   (address (%primitive make-immediate-type code-byte-offset
+				%assembler-code-type)))
+      (dolist (refs (cdr reflist))
+	(let ((how (car refs))
+	      (label (get (cadr refs) '%loaded-address))
+	      (location (caddr refs)))
+	  (unless label
+	    (error "~A references ~A, which has not been defined.~%"
+		   (car reflist) (cadr refs)))
+	  (let ((offset (- (- (ash label -1) code-halfword-offset) location)))
+	    (ecase how
+	      (clc::ji
+	       (unless (<= #x-80 offset #x7F)
+		 (error "Offset #X~X out of JI range for ~A to reference ~A.~%"
+			offset (car reflist) (cadr refs)))
+	       (patch-instruction (hi lo address location)
+		 (setf (ldb (byte 8 0) hi) offset)))
+	      (clc::bi
+	       (unless (<= #x-80000 offset #x7FFFF)
+		 (error "Offset #X~X out of BI range for ~A to reference ~A.~%"
+			offset (car reflist) (cadr refs)))
+	       (patch-instruction (hi lo address location)
+		 (setf (ldb (byte 4 0) hi) (ash offset -16))
+		 (setq lo (logand offset #xFFFF))))
+	      (clc::ba (error "I can't resolve a BA reference yet.~%"))
+	      (clc::l (error "I can't resolve an L reference yet.~%"))))))))
+  (setq *external-references* ())
+
+  (dolist (mo *miscop-definitions*)
+    (let* ((name (intern (symbol-name (car mo)) (find-package "COMPILER")))
+	   (index (get name 'clc::transfer-vector-index)))
+      (if index
+	  (%primitive write-control-stack
+		      (%primitive make-immediate-type (ash index 2)
+				  %assembler-code-type)
+		      (cdr mo))
+	  (pushnew name *user-defined-miscops*))))
+  (setq *miscop-definitions* ()))
+
+(proclaim '(notinline read-byte))
diff --git a/code/machdef.lisp b/code/machdef.lisp
new file mode 100644
index 000000000..0dce05382
--- /dev/null
+++ b/code/machdef.lisp
@@ -0,0 +1,106 @@
+;;; -*- Log: code.log; Package: Mach -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; Record definitions needed for the interface to Mach.
+;;;
+(in-package 'mach)
+(export '(msg-simplemsg msg-msgsize msg-msgtype msg-localport msg-remoteport
+			msg-id sigmask with-trap-arg-block))
+
+(defrecord Msg
+  (Reserved1 (unsigned-byte 8) 8)
+  (Reserved2 (unsigned-byte 8) 8)
+  (Reserved3 (unsigned-byte 8) 8)
+  (Reserved4 (unsigned-byte 7) 7)
+  (SimpleMsg boolean 1)
+  (MsgSize (signed-byte 32) 32)
+  (MsgType (signed-byte 32) 32)
+  (LocalPort port 32)
+  (RemotePort port 32)
+  (ID (signed-byte 32) 32))
+
+(defrecord timeval
+  (seconds (unsigned-byte 32) (long-words 1))
+  (useconds (signed-byte 32) (long-words 1)))
+
+(defalien timeval timeval (record-size 'timeval))
+
+(defrecord timezone
+  (minuteswest (signed-byte 32) (long-words 1))
+  (dsttime (signed-byte 32) (long-words 1)))
+
+(defalien timezone timezone (record-size 'timezone))
+
+(eval-when (compile load eval)
+(defrecord int1
+  (int (signed-byte 32) (long-words 1)))
+
+(defalien int1 int1 (record-size 'int1))
+
+(defrecord int2
+  (int (signed-byte 32) (long-words 1)))
+
+(defalien int2 int2 (record-size 'int2))
+
+(defrecord int3
+  (int (signed-byte 32) (long-words 1)))
+
+(defalien int3 int3 (record-size 'int3))
+
+(defrecord sigcontext
+  (onstack (unsigned-byte 32) (long-words 1))
+  (mask (unsigned-byte 32) (long-words 1))
+  (sctx-fpa (unsgined-byte 32) (long-words 1))
+  (sp (unsigned-byte 32) (long-words 1))
+  (fp (unsigned-byte 32) (long-words 1))
+  (ap (unsigned-byte 32) (long-words 1))
+  (iar (unsigned-byte 32) (long-words 1))
+  (icscs (unsigned-byte 32) (long-words 1)))
+(defalien sigcontext sigcontext (record-size 'sigcontext))
+
+
+(defrecord tchars
+  (intrc (signed-byte 8) (bytes 1))
+  (quitc (signed-byte 8) (bytes 1))
+  (startc (signed-byte 8) (bytes 1))
+  (stopc (signed-byte 8) (bytes 1))
+  (eofc (signed-byte 8) (bytes 1))
+  (brkc (signed-byte 8) (bytes 1)))
+(defalien tchars tchars (record-size 'tchars))
+
+(defrecord ltchars
+  (suspc (signed-byte 8) (bytes 1))
+  (dsuspc (signed-byte 8) (bytes 1))
+  (rprntc (signed-byte 8) (bytes 1))
+  (flushc (signed-byte 8) (bytes 1))
+  (werasc (signed-byte 8) (bytes 1))
+  (lnextc (signed-byte 8) (bytes 1)))
+(defalien ltchars ltchars (record-size 'ltchars))
+
+); eval-when (compile load eval)
+
+
+#-new-compiler
+(eval-when (compile)
+  (setq lisp::*bootstrap-defmacro* t))
+
+(defmacro sigmask (signal)
+  "Returns a mask given a signal." 
+  `(ash 1 (1- ,signal)))
+
+
+(defmacro with-trap-arg-block (arg-var alien-var &body forms)
+  `(progn (unless *free-trap-arg-blocks* (alloc-trap-arg-block))
+	  (let ((*free-trap-arg-blocks* (cdr *free-trap-arg-blocks*))
+		(,arg-var (car *free-trap-arg-blocks*)))
+	    (alien-bind ((,alien-var ,arg-var ,arg-var T))
+			,@forms))))
+#-new-compiler
+(eval-when (compile)
+  (setq lisp::*bootstrap-defmacro* nil))
diff --git a/code/macros.lisp b/code/macros.lisp
new file mode 100644
index 000000000..efe5ed697
--- /dev/null
+++ b/code/macros.lisp
@@ -0,0 +1,1532 @@
+;;; -*- Log: code.log; Package: Lisp -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; This file contains the macros that are part of the standard
+;;; Spice Lisp environment.
+;;;
+;;; Written by Scott Fahlman and Rob MacLachlan.
+;;; Modified by Bill Chiles to adhere to
+;;;
+(in-package 'lisp)
+(export '(defvar defparameter defconstant when unless loop setf
+	  defsetf define-setf-method psetf shiftf rotatef push pushnew pop
+	  incf decf remf case typecase with-open-file
+	  with-open-stream with-input-from-string with-output-to-string
+	  locally etypecase ctypecase ecase ccase
+	  get-setf-method get-setf-method-multiple-value
+          define-modify-macro
+          otherwise)) ; Sacred to CASE and related macros.
+
+(in-package "EXTENSIONS")
+(export '(do-anonymous collect iterate))
+
+(in-package "LISP")
+
+
+;;; Parse-Body  --  Public
+;;;
+;;;    Parse out declarations and doc strings, *not* expanding macros.
+;;; Eventually the environment arg should be flushed, since macros can't expand
+;;; into declarations anymore.
+;;;
+(defun parse-body (body environment &optional (doc-string-allowed t))
+  "This function is to parse the declarations and doc-string out of the body of
+  a defun-like form.  Body is the list of stuff which is to be parsed.
+  Environment is ignored.  If Doc-String-Allowed is true, then a doc string
+  will be parsed out of the body and returned.  If it is false then a string
+  will terminate the search for declarations.  Three values are returned: the
+  tail of Body after the declarations and doc strings, a list of declare forms,
+  and the doc-string, or NIL if none."
+  (declare (ignore environment))
+  (let ((decls ())
+	(doc nil))
+    (do ((tail body (cdr tail)))
+	((endp tail)
+	 (values tail (nreverse decls) doc))
+      (let ((form (car tail)))
+	(cond ((and (stringp form) (cdr tail))
+	       (if doc-string-allowed
+		   (setq doc form)
+		   (return (values tail (nreverse decls) doc))))
+	      ((not (and (consp form) (symbolp (car form))))
+	       (return (values tail (nreverse decls) doc)))
+	      ((eq (car form) 'declare)
+	       (push form decls))
+	      (t
+	       (return (values tail (nreverse decls) doc))))))))
+
+
+;;;; DEFMACRO:
+
+#-new-compiler
+(proclaim '(special *in-compilation-unit*))
+
+(defparameter defmacro-error-string "Macro ~S cannot be called with ~S args.")
+
+;;; Defmacro  --  Public
+;;;
+;;;    Parse the definition and make an expander function.  The actual
+;;; definition is done by %defmacro which we expand into.
+;;;
+(defmacro defmacro (name lambda-list &body body)
+  (let ((whole (gensym)) (environment (gensym)))
+    (multiple-value-bind
+	(body local-decs doc)
+	(parse-defmacro lambda-list whole body name
+			:environment environment
+			:error-string 'defmacro-error-string)
+      (let ((def `(lambda (,whole ,environment)
+		    ,@local-decs
+		    (block ,name
+		      ,body))))
+	;;
+	;; ### Bootstrap hack...
+	;; When in old compiler, call %%defmacro with #'(lambda ...) so that
+	;; the function gets compiled.  When in old interpreter (neither in old
+	;; or new compiler), just setf the macro-function so that we can have
+	;; interpreted macros.
+	(cond #-new-compiler
+	      (system:*in-the-compiler*
+	       `(c::%%defmacro ',name #',def ,doc))
+	      #-new-compiler
+	      ((not *in-compilation-unit*)
+	       `(setf (symbol-function ',name)
+		      (cons 'macro #',def)))
+	      (t
+	       `(c::%defmacro ',name
+			      #+new-compiler #',def
+			      #-new-compiler ',def
+			      ',lambda-list ,doc)))))))
+
+
+(eval-when (compile load eval)
+
+;;; %Defmacro, %%Defmacro  --  Internal
+;;;
+;;;    Defmacro expands into %Defmacro which is a function that is treated
+;;; magically the compiler.  After the compiler has gotten the information it
+;;; wants out of macro definition, it compiles a call to %%Defmacro which
+;;; happens at load time.  We have a %Defmacro function which just calls
+;;; %%Defmacro in order to keep the interpreter happy.
+;;;
+;;;    Eventually %%Defmacro should deal with clearing old compiler information
+;;; for the functional value.
+;;;
+(defun c::%defmacro (name definition lambda-list doc)
+  #+new-compiler
+  ;; ### bootstrap hack...
+  ;; This WHEN only necessary to make cross-compiling of this file work.
+  ;; Necessary because the EVAL-WHEN COMPILE goes into the bootstrap
+  ;; environment, but is read with the NEW-COMPILER feature.
+  (when (fboundp 'eval:interpreted-function-p)
+    (assert (eval:interpreted-function-p definition))
+    (setf (eval:interpreted-function-name definition) name)
+    (setf (eval:interpreted-function-arglist definition) lambda-list))
+  (c::%%defmacro name definition doc))
+;;;
+(defun c::%%defmacro (name definition doc)
+  (clear-info function where-from name)
+  (setf (info function macro-function name) definition)
+  (setf (info function kind name) :macro)
+  (setf (documentation name 'function) doc)
+  name)
+
+); Eval-When
+
+;;; ### Bootstrap hack...
+;;;
+;;; Redefine the top-level defmacro handler to do nothing special when
+;;; *bootstrap-defmacro* is true so that our defmacro gets called.
+;;;
+#-new-compiler
+(eval-when (compile load eval)
+  (defvar *old-pdm* #'clc::process-defmacro)
+  (defvar *bootstrap-defmacro* nil)
+  (defun clc::process-defmacro (form)
+    (ecase *bootstrap-defmacro*
+      ((t)
+       (clc::process-random (macroexpand form) nil))
+      ((nil)
+       (funcall *old-pdm* form))
+      (:both
+       (clc::process-random (macroexpand form) nil)
+       (funcall *old-pdm* form))))))
+
+;;; ### Bootstrap hack...
+;;; At load time, get defmacro from the old place and store it in the new
+;;; place.
+#-new-compiler
+(c::%%defmacro 'defmacro (macro-function 'defmacro) nil)
+
+
+;;; ### Bootstrap hack...
+;;; Install macro definitions in this file only into the new compiler's
+;;; environment.
+(eval-when (compile)
+  (setq *bootstrap-defmacro* t))
+
+
+;;; DEFTYPE is a lot like DEFMACRO.
+
+(defparameter deftype-error-string "Type ~S cannot be used with ~S args.")
+
+(defmacro deftype (name arglist &body body)
+  "Syntax like DEFMACRO, but defines a new type."
+  (unless (symbolp name)
+    (error "~S -- Type name not a symbol." name))
+  
+  (let ((whole (gensym)))
+    (multiple-value-bind (body local-decs doc)
+			 (parse-defmacro arglist whole body name
+					 :default-default ''*
+					 :error-string 'deftype-error-string
+					 )
+      `(eval-when (compile load eval)
+	 (setf (get ',name 'deftype-expander)
+	       #'(lambda (,whole) ,@local-decs (block ,name ,body)))
+	 ,@(when doc
+	     `((setf (documentation ',name 'type) ,doc)))
+	 ',name))))
+
+;;; And so is DEFINE-SETF-METHOD.
+
+(defparameter defsetf-error-string "Setf expander for ~S cannot be called with ~S args.")
+
+(compiler-let ((*bootstrap-defmacro* :both))
+
+(defmacro define-setf-method (access-fn lambda-list &body body)
+  "Syntax like DEFMACRO, but creates a Setf-Method generator.  The body
+  must be a form that returns the five magical values."
+  (unless (symbolp access-fn)
+    (error "~S -- Access-function name not a symbol in DEFINE-SETF-METHOD."
+	   access-fn))
+
+  (let ((whole (gensym)) (environment (gensym)))
+    (multiple-value-bind (body local-decs doc)
+			 (parse-defmacro lambda-list whole body access-fn
+					 :environment environment
+					 :error-string 'defsetf-error-string)
+      `(eval-when (load compile eval)
+	 (setf (info setf inverse ',access-fn) nil)
+	 (setf (info setf expander ',access-fn)
+	       #'(lambda (,whole ,environment)
+		   ,@local-decs
+		   (block ,access-fn ,body)))
+	 ,@(when doc
+	     `((setf (documentation ',access-fn 'setf) ,doc)))
+	 ',access-fn))))
+
+); compiler-let
+
+
+;;;; Defun, Defvar, Defparameter, Defconstant:
+
+;;; Defun  --  Public
+;;;
+;;;    Very similar to Defmacro, but simpler.  We don't have to parse the
+;;; lambda-list.
+;;;
+(defmacro defun (name lambda-list &body (body decls doc) &whole source)
+  (let ((def `(lambda ,lambda-list
+		,@decls
+		(block ,(if (and (consp name) (eq (car name) 'setf))
+			    (cadr name)
+			    name)
+		  ,@body))))
+    `(c::%defun ',name #',def ,doc ',source)))
+
+
+;;; %Defun, %%Defun  --  Internal
+;;;
+;;;    Similar to %Defmacro, ...
+;;;
+(defun c::%%defun (name def doc &optional inline-expansion)
+  (setf (fdefinition name) def)
+  (when doc
+    (if (and (consp name) (eq (first name) 'setf))
+	(setf (documentation (second name) 'setf) doc)
+	(setf (documentation name 'function) doc)))
+
+  (unless (eq (info function kind name) :function)
+    (setf (info function kind name) :function))
+
+  (when (info function accessor-for name)
+    (setf (info function accessor-for name) nil))
+    
+  (when (or inline-expansion
+	    (info function inline-expansion name))
+    (setf (info function inline-expansion name) inline-expansion))
+  name)
+;;;
+(defun c::%defun (name def doc source)
+  (declare (ignore source))
+  (c::%%defun name def doc))
+
+
+;;; DEFCONSTANT  --  Public
+;;;
+(defmacro defconstant (var val &optional doc)
+  "For defining global constants at top level.  The DEFCONSTANT says that the
+  value is constant and may be compiled into code.  If the variable already has
+  a value, and this is not equal to the init, an error is signalled.  The third
+  argument is an optional documentation string for the variable."
+  `(c::%defconstant ',var ,val ',doc))
+
+;;; %Defconstant, %%Defconstant  --  Internal
+;;;
+;;;    Like the other %mumbles except that we currently actually do something
+;;; interesting at load time, namely checking if the constant is being
+;;; redefined.
+;;;
+(defun c::%defconstant (name value doc)
+  (c::%%defconstant name value doc))
+;;;
+(defun c::%%defconstant (name value doc)
+  (when doc
+    (setf (documentation name 'variable) doc))
+  (when (boundp name)
+    (unless (equalp (symbol-value name) value)
+      (cerror "Go ahead and change the value."
+	      "Constant ~S being redefined." name)))
+  (setf (symbol-value name) value)
+  (setf (info variable kind name) :constant)
+  (clear-info variable constant-value name)
+  name)
+
+
+(defmacro defvar (var &optional (val nil valp) (doc nil docp))
+  "For defining global variables at top level.  Declares the variable
+  SPECIAL and, optionally, initializes it.  If the variable already has a
+  value, the old value is not clobbered.  The third argument is an optional
+  documentation string for the variable."
+  `(progn
+    (proclaim '(special ,var))
+     ,@(when valp
+	 `((unless (boundp ',var)
+	     (setq ,var ,val))))
+    ,@(when docp
+	`((setf (documentation ',var 'variable) ',doc)))
+    ',var))
+
+(defmacro defparameter (var val &optional (doc nil docp))
+  "Defines a parameter that is not normally changed by the program,
+  but that may be changed without causing an error.  Declares the
+  variable special and sets its value to VAL.  The third argument is
+  an optional documentation string for the parameter."
+  `(progn
+    (proclaim '(special ,var))
+    (setq ,var ,val)
+    ,@(when docp
+	`((setf (documentation ',var 'variable) ',doc)))
+    ',var))
+
+
+;;;; ASSORTED CONTROL STRUCTURES
+
+
+(defmacro when (test &body forms)
+  "First arg is a predicate.  If it is non-null, the rest of the forms are
+  evaluated as a PROGN."
+  `(cond (,test nil ,@forms)))
+
+(defmacro unless (test &rest forms)
+  "First arg is a predicate.  If it is null, the rest of the forms are
+  evaluated as a PROGN."
+  `(cond ((not ,test) nil ,@forms)))
+
+
+(defmacro return (&optional (value nil))
+  `(return-from nil ,value))
+
+(defmacro prog (varlist &body (body decls))
+  `(block nil
+     (let ,varlist
+       ,@decls
+       (tagbody ,@body))))
+
+(defmacro prog* (varlist &body (body decls))
+  `(block nil
+     (let* ,varlist
+       ,@decls
+       (tagbody ,@body))))
+
+
+;;; Prog1, Prog2  --  Public
+;;;
+;;;    These just turn into a Let.
+;;;
+(defmacro prog1 (result &rest body)
+  (let ((n-result (gensym)))
+    `(let ((,n-result ,result))
+       ,@body
+       ,n-result)))
+;;;
+(defmacro prog2 (form1 result &rest body)
+  `(prog1 (progn ,form1 ,result) ,@body))
+
+
+;;; And, Or  --  Public
+;;;
+;;;    AND and OR are defined in terms of IF.
+;;;
+(defmacro and (&rest forms)
+  (cond ((endp forms) t)
+	((endp (rest forms)) (first forms))
+	(t
+	 `(if ,(first forms)
+	      (and ,@(rest forms))
+	      nil))))
+;;;
+(defmacro or (&rest forms)
+  (cond ((endp forms) nil)
+	((endp (rest forms)) (first forms))
+	(t
+	 (let ((n-result (gensym)))
+	   `(let ((,n-result ,(first forms)))
+	      (if ,n-result
+		  ,n-result
+		  (or ,@(rest forms))))))))
+
+
+;;; Cond  --  Public
+;;;
+;;;    COND also turns into IF.
+;;;
+(defmacro cond (&rest clauses)
+  (if (endp clauses)
+      nil
+      (let ((clause (first clauses)))
+	(when (atom clause)
+	  (error "Cond clause is not a list: ~S." clause))
+	(let ((test (first clause))
+	      (forms (rest clause)))
+	  (if (endp forms)
+	      (let ((n-result (gensym)))
+		`(let ((,n-result ,test))
+		   (if ,n-result
+		       ,n-result
+		       (cond ,@(rest clauses)))))
+	      `(if ,test
+		   (progn ,@forms)
+		   (cond ,@(rest clauses))))))))
+
+
+;;;; Multiple value macros:
+
+;;; Multiple-Value-XXX  --  Public
+;;;
+;;;    All the multiple-value receiving forms are defined in terms of
+;;; Multiple-Value-Call.
+;;;
+(defmacro multiple-value-setq (varlist value-form)
+  (unless (and (listp varlist) (every #'symbolp varlist))
+    (error "Varlist is not a list of symbols: ~S." varlist))
+  (let ((temps (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) varlist)))
+    `(multiple-value-bind ,temps ,value-form
+       ,@(mapcar #'(lambda (var temp)
+		     `(setq ,var ,temp))
+		 varlist temps)
+       ,(car temps))))
+;;;
+(defmacro multiple-value-bind (varlist value-form &body body)
+  (unless (and (listp varlist) (every #'symbolp varlist))
+    (error "Varlist is not a list of symbols: ~S." varlist))
+  (if (= (length varlist) 1)
+      `(let ((,(car varlist) ,value-form))
+	 ,@body)
+      (let ((ignore (gensym)))
+	`(multiple-value-call #'(lambda (&optional ,@varlist &rest ,ignore)
+				  (declare (ignore ,ignore))
+				  ,@body)
+	   ,value-form))))
+;;;
+(defmacro multiple-value-list (value-form)
+  `(multiple-value-call #'list ,value-form))
+
+
+;;;; SETF and friends.
+
+;;; Note: The expansions for SETF and friends sometimes create needless
+;;; LET-bindings of argument values.  The compiler will remove most of
+;;; these spurious bindings, so SETF doesn't worry too much about creating
+;;; them. 
+
+;;; The inverse for a generalized-variable reference function is stored in
+;;; one of two ways:
+;;;
+;;; A SETF-INVERSE property corresponds to the short form of DEFSETF.  It is
+;;; the name of a function takes the same args as the reference form, plus a
+;;; new-value arg at the end.
+;;;
+;;; A SETF-METHOD-EXPANDER property is created by the long form of DEFSETF or
+;;; by DEFINE-SETF-METHOD.  It is a function that is called on the reference
+;;; form and that produces five values: a list of temporary variables, a list
+;;; of value forms, a list of the single store-value form, a storing function,
+;;; and an accessing function.
+
+(eval-when (compile load eval)
+
+;;; ### bootstrap hack...
+;;; Rename get-setf-method so that we don't blow away setf in the bootstrap
+;;; lisp.  All references in this file are to the renamed function, and should
+;;; eventually be renamed back.
+;;;
+#+new-compiler
+(defun get-setf-method (form &optional environment)
+  (foo-get-setf-method form environment))
+;;;
+(defun foo-get-setf-method (form &optional environment)
+  "Returns five values needed by the SETF machinery: a list of temporary
+  variables, a list of values with which to fill them, the temporary for the
+  new value in a list, the setting function, and the accessing function."
+  (let (temp)
+    (cond ((symbolp form)
+	   (let ((new-var (gensym)))
+	     (values nil nil (list new-var) `(setq ,form ,new-var) form)))
+	  ((atom form)
+	   (error "~S illegal atomic form for GET-SETF-METHOD." form))
+	  ;;
+	  ;; ### Bootstrap hack...
+	  ;; Ignore any DEFSETF info for structure accessors.
+	  ((info function accessor-for (car form))
+	   (get-setf-method-inverse form `(funcall #'(setf ,(car form)))))
+	  ((setq temp (info setf inverse (car form)))
+	   (get-setf-method-inverse form `(,temp)))
+	  ((setq temp (info setf expander (car form)))
+	   (funcall temp form environment))
+	  (t
+	   (multiple-value-bind (res win)
+				(macroexpand-1 form environment)
+	     (if win
+		 (foo-get-setf-method res environment)
+		 (get-setf-method-inverse
+		  form
+		  `(funcall #'(setf ,(car form))))))))))
+
+(defun get-setf-method-inverse (form inverse)
+  (let ((new-var (gensym))
+	(vars nil)
+	(vals nil))
+    (dolist (x (cdr form))
+      (push (gensym) vars)
+      (push x vals))
+    (setq vals (nreverse vals))
+    (values vars vals (list new-var)
+	    `(,@inverse ,@vars ,new-var)
+	    `(,(car form) ,@vars))))
+
+
+(defun get-setf-method-multiple-value (form &optional environment)
+  "Like Get-Setf-Method, but may return multiple new-value variables."
+  (get-setf-method form environment))
+
+(defun defsetter (fn rest env)
+  (let* ((arglist (car rest))
+	 (new-var (car (cadr rest)))
+	 (%arg-count 0)
+	 (%min-args 0)
+	 (%restp nil)
+	 (%let-list nil)
+	 (%keyword-tests nil))
+    (declare (special %arg-count %min-args %restp %let-list %keyword-tests))
+    (multiple-value-bind (body local-decs doc)
+			 (parse-body (cddr rest) env)
+      ;; Analyze the defmacro argument list.
+      (analyze1 arglist '(cdr %access-arglist) fn '%access-arglist)
+      ;; Now build the body of the transform.
+      (values 
+       `(lambda (%access-arglist ,new-var)
+	  ,@(when (null arglist)
+	      '((declare (ignore %access-arglist))))
+	  (let* ,(nreverse %let-list)
+	    ,@ local-decs
+	    ,@ %keyword-tests
+	    ,@ body))
+       doc))))
+
+) ; End of Eval-When.
+
+
+(compiler-let ((*bootstrap-defmacro* :both))
+
+(defmacro defsetf (access-fn &rest rest &environment env)
+  "Associates a SETF update function or macro with the specified access
+  function or macro.  The format is complex.  See the manual for
+  details."
+  (cond ((not (listp (car rest)))
+	 `(eval-when (load compile eval)
+	    (setf (info setf inverse ',access-fn) ',(car rest))
+	    ;;
+	    ;; ### Bootstrap hack...
+	    ;; In bootstrap env, also install inverse in old place so that we
+	    ;; can still compile defstructs.
+	    #-new-compiler
+	    (setf (get ',access-fn 'setf-inverse) ',(car rest))
+	    (setf (info setf expander ',access-fn) nil)
+	    ,@(if (and (car rest) (stringp (cadr rest)))
+		  `((eval-when (load eval)
+		      (%put ',access-fn '%setf-documentation ,(cadr rest)))))
+	    ',access-fn))
+	((and (listp (car rest)) (cdr rest) (listp (cadr rest)))
+	 (if (not (= (length (cadr rest)) 1))
+	     (cerror "Ignore the extra items in the list."
+		     "Only one new-value variable allowed in DEFSETF."))
+	 (multiple-value-bind (setting-form-generator doc)
+			      (defsetter access-fn rest env)
+	   `(eval-when (load compile eval)
+	      (setf (info setf inverse ',access-fn) nil)
+	      (setf (info setf expander ',access-fn)
+		    #'(lambda (access-form environment)
+			(declare (ignore environment))
+			(do* ((args (cdr access-form) (cdr args))
+			      (dummies nil (cons (gensym) dummies))
+			      (newval-var (gensym))
+			      (new-access-form nil))
+			     ((atom args)
+			      (setq new-access-form 
+				    (cons (car access-form) dummies))
+			      (values
+			       dummies
+			       (cdr access-form)
+			       (list newval-var)
+			       (funcall (function ,setting-form-generator)
+					new-access-form newval-var)
+			       new-access-form)))))
+	      ,@(if doc
+		    `((eval-when (load eval)
+			(%put ',access-fn '%setf-documentation ',doc)))
+		    `((eval-when (load eval)             ;SKH 4/17/84
+			(remprop ',access-fn '%setf-documentation))))
+	      ',access-fn)))
+	(t (error "Ill-formed DEFSETF for ~S." access-fn))))
+
+); Compiler-Let
+
+(defmacro setf (&rest args &environment env)
+  "Takes pairs of arguments like SETQ.  The first is a place and the second
+  is the value that is supposed to go into that place.  Returns the last
+  value.  The place argument may be any of the access forms for which SETF
+  knows a corresponding setting form."
+  (let ((temp (length args)))
+    (cond ((= temp 2)
+	   (cond ((atom (car args))
+		  `(setq ,(car args) ,(cadr args)))
+		 ((info function accessor-for (caar args))
+		  `(funcall #'(setf ,(caar args)) ,@(cdar args) ,(cadr args)))
+		 ((setq temp (info setf inverse (caar args)))
+		  `(,temp ,@(cdar args) ,(cadr args)))
+		 (t (multiple-value-bind (dummies vals newval setter getter)
+					 (foo-get-setf-method (car args) env)
+		      (declare (ignore getter))
+		      (do* ((d dummies (cdr d))
+			    (v vals (cdr v))
+			    (let-list nil))
+			   ((null d)
+			    (setq let-list
+				  (nreverse (cons (list (car newval)
+							(cadr args))
+						  let-list)))
+			    `(let* ,let-list ,setter))
+			(setq let-list
+			      (cons (list (car d) (car v)) let-list)))))))
+	  ((oddp temp) 
+	   (error "Odd number of args to SETF."))
+	  (t (do ((a args (cddr a)) (l nil))
+		 ((null a) `(progn ,@(nreverse l)))
+	       (setq l (cons (list 'setf (car a) (cadr a)) l)))))))
+
+
+(defmacro psetf (&rest args &environment env)
+  "This is to SETF as PSETQ is to SETQ.  Args are alternating place
+  expressions and values to go into those places.  All of the subforms and
+  values are determined, left to right, and only then are the locations
+  updated.  Returns NIL."
+  (do ((a args (cddr a))
+       (let-list nil)
+       (setf-list nil))
+      ((atom a)
+       `(let* ,(nreverse let-list) ,@(nreverse setf-list) nil))
+    (if (atom (cdr a))
+	(error "Odd number of args to PSETF."))
+    (multiple-value-bind (dummies vals newval setter getter)
+      (foo-get-setf-method (car a) env)
+      (declare (ignore getter))
+      (do* ((d dummies (cdr d))
+	    (v vals (cdr v)))
+	   ((null d))
+	(push (list (car d) (car v)) let-list))
+      (push (list (car newval) (cadr a)) let-list)
+      (push setter setf-list))))
+
+
+
+(defmacro shiftf (&rest args &environment env)
+  "One or more SETF-style place expressions, followed by a single
+  value expression.  Evaluates all of the expressions in turn, then
+  assigns the value of each expression to the place on its left,
+  returning the value of the leftmost."
+  (if (< (length args) 2)
+      (error "Too few argument forms to a SHIFTF."))
+  (let ((leftmost (gensym)))
+    (do ((a args (cdr a))
+	 (let-list nil)
+	 (setf-list nil)
+	 (next-var leftmost))
+	((atom (cdr a))
+	 (push (list next-var (car a)) let-list)
+	 `(let* ,(nreverse let-list) ,@(nreverse setf-list) ,leftmost))
+      (multiple-value-bind (dummies vals newval setter getter)
+	(foo-get-setf-method (car a) env)
+	(do* ((d dummies (cdr d))
+	      (v vals (cdr v)))
+	     ((null d))
+	  (push (list (car d) (car v)) let-list))
+	(push (list next-var getter) let-list)
+	(push setter setf-list)
+	(setq next-var (car newval))))))
+
+
+(defmacro rotatef (&rest args &environment env)
+  "Takes any number of SETF-style place expressions.  Evaluates all of the
+  expressions in turn, then assigns to each place the value of the form to
+  its right.  The rightmost form gets the value of the leftmost.  Returns NIL."
+  (cond ((null args) nil)
+	((null (cdr args)) `(progn ,(car args) nil))
+	(t (do ((a args (cdr a))
+		(let-list nil)
+		(setf-list nil)
+		(next-var nil)
+		(fix-me nil))
+	       ((atom a)
+		  (rplaca fix-me next-var)
+		  `(let* ,(nreverse let-list) ,@(nreverse setf-list) nil))
+	       (multiple-value-bind (dummies vals newval setter getter)
+                 (foo-get-setf-method (car a) env)
+		 (do ((d dummies (cdr d))
+		      (v vals (cdr v)))
+		     ((null d))
+		   (push (list (car d) (car v)) let-list))
+		 (push (list next-var getter) let-list)
+		 ;; We don't know the newval variable for the last form yet,
+		 ;; so fake it for the first getter and fix it at the end.
+		 (unless fix-me (setq fix-me (car let-list)))
+		 (push setter setf-list)
+		 (setq next-var (car newval)))))))
+
+
+(compiler-let ((*bootstrap-defmacro* :both))
+
+(defmacro define-modify-macro (name lambda-list function &optional doc-string)
+  "Creates a new read-modify-write macro like PUSH or INCF."
+  (let ((other-args nil)
+	(rest-arg nil)
+	(env (gensym))
+	(reference (gensym)))
+	     
+    ;; Parse out the variable names and rest arg from the lambda list.
+    (do ((ll lambda-list (cdr ll))
+	 (arg nil))
+	((null ll))
+      (setq arg (car ll))
+      (cond ((eq arg '&optional))
+	    ((eq arg '&rest)
+	     (if (symbolp (cadr ll))
+		 (setq rest-arg (cadr ll))
+		 (error "Non-symbol &rest arg in definition of ~S." name))
+	     (if (null (cddr ll))
+		 (return nil)
+		 (error "Illegal stuff after &rest arg in Define-Modify-Macro.")))
+	    ((memq arg '(&key &allow-other-keys &aux))
+	     (error "~S not allowed in Define-Modify-Macro lambda list." arg))
+	    ((symbolp arg)
+	     (push arg other-args))
+	    ((and (listp arg) (symbolp (car arg)))
+	     (push (car arg) other-args))
+	    (t (error "Illegal stuff in lambda list of Define-Modify-Macro."))))
+    (setq other-args (nreverse other-args))
+    `(defmacro ,name (,reference ,@lambda-list &environment ,env)
+       ,doc-string
+       (multiple-value-bind (dummies vals newval setter getter)
+	 (foo-get-setf-method ,reference ,env)
+	 (do ((d dummies (cdr d))
+	      (v vals (cdr v))
+	      (let-list nil (cons (list (car d) (car v)) let-list)))
+	     ((null d)
+	      (push 
+	       (list (car newval)
+		     ,(if rest-arg
+			  `(list* ',function getter ,@other-args ,rest-arg)
+			  `(list ',function getter ,@other-args)))
+	       let-list)
+	      `(let* ,(nreverse let-list)
+		 ,setter)))))))
+
+); Compiler-Let
+
+
+(defmacro push (obj place &environment env)
+  "Takes an object and a location holding a list.  Conses the object onto
+  the list, returning the modified list."
+  (if (symbolp place)
+      `(setq ,place (cons ,obj ,place))
+      (multiple-value-bind (dummies vals newval setter getter)
+			   (foo-get-setf-method place env)
+	(do* ((d dummies (cdr d))
+	      (v vals (cdr v))
+	      (let-list nil))
+	     ((null d)
+	      (push (list (car newval) `(cons ,obj ,getter))
+		    let-list)
+	      `(let* ,(nreverse let-list)
+		 ,setter))
+	  (push (list (car d) (car v)) let-list)))))
+
+
+(defmacro pushnew (obj place &rest keys &environment env)
+  "Takes an object and a location holding a list.  If the object is already
+  in the list, does nothing.  Else, conses the object onto the list.  Returns
+  NIL.  If there is a :TEST keyword, this is used for the comparison."
+  (if (symbolp place)
+      `(setq ,place (adjoin ,obj ,place ,@keys))
+      (multiple-value-bind (dummies vals newval setter getter)
+			   (foo-get-setf-method place env)
+	(do* ((d dummies (cdr d))
+	      (v vals (cdr v))
+	      (let-list nil))
+	     ((null d)
+	      (push (list (car newval) `(adjoin ,obj ,getter ,@keys))
+		    let-list)
+	      `(let* ,(nreverse let-list)
+		 ,setter))
+	  (push (list (car d) (car v)) let-list)))))
+
+
+(defmacro pop (place &environment env)
+  "The argument is a location holding a list.  Pops one item off the front
+  of the list and returns it."
+  (if (symbolp place)
+      `(prog1 (car ,place) (setq ,place (cdr ,place)))
+      (multiple-value-bind (dummies vals newval setter getter)
+			   (foo-get-setf-method place env)
+	(do* ((d dummies (cdr d))
+	      (v vals (cdr v))
+	      (let-list nil))
+	     ((null d)
+	      (push (list (car newval) getter) let-list)
+	      `(let* ,(nreverse let-list)
+		 (prog1 (car ,(car newval))
+			(setq ,(car newval) (cdr ,(car newval)))
+			,setter)))
+	  (push (list (car d) (car v)) let-list)))))
+
+
+(define-modify-macro incf (&optional (delta 1)) +
+  "The first argument is some location holding a number.  This number is
+  incremented by the second argument, DELTA, which defaults to 1.")
+
+
+(define-modify-macro decf (&optional (delta 1)) -
+  "The first argument is some location holding a number.  This number is
+  decremented by the second argument, DELTA, which defaults to 1.")
+#|
+(defmacro putf (place indicator value &environment env)
+  "Place may be any place expression acceptable to SETF, and is expected
+  to hold a property list or ().  This list is destructively altered so
+  that (GETF place indicator) will find the specified newvalue.  Returns
+  the new value."
+  (multiple-value-bind (dummies vals newval setter getter)
+		       (foo-get-setf-method place env)
+    (do* ((d dummies (cdr d))
+	  (v vals (cdr v))
+	  (let-list nil)
+	  (ind-temp (gensym))
+	  (val-temp (gensym)))
+	 ((null d)
+	  (push (list (car newval) getter) let-list)
+	  (push (list ind-temp indicator) let-list)
+	  (push (list val-temp value) let-list)
+	  `(let* ,(nreverse let-list)
+	     (setq ,(car newval)
+		   (%primitive putf ,(car newval) ,ind-temp ,val-temp))
+	     ,setter
+	     ,val-temp))
+      (push (list (car d) (car v)) let-list))))
+|#
+
+
+(defmacro remf (place indicator &environment env)
+  "Place may be any place expression acceptable to SETF, and is expected
+  to hold a property list or ().  This list is destructively altered to
+  remove the property specified by the indicator.  Returns T if such a
+  property was present, NIL if not."
+  (multiple-value-bind (dummies vals newval setter getter)
+		       (foo-get-setf-method place env)
+    (do* ((d dummies (cdr d))
+	  (v vals (cdr v))
+	  (let-list nil)
+	  (ind-temp (gensym))
+	  (local1 (gensym))
+	  (local2 (gensym)))
+	 ((null d)
+	  (push (list (car newval) getter) let-list)
+	  (push (list ind-temp indicator) let-list)
+	  `(let* ,(nreverse let-list)
+	     (do ((,local1 ,(car newval) (cddr ,local1))
+		  (,local2 nil ,local1))
+		 ((atom ,local1) nil)
+	       (cond ((atom (cdr ,local1))
+		      (error "Odd-length property list in REMF."))
+		     ((eq (car ,local1) ,ind-temp)
+		      (cond (,local2
+			     (rplacd (cdr ,local2) (cddr ,local1))
+			     (return t))
+			    (t (setq ,(car newval) (cddr ,(car newval)))
+			       ,setter
+			       (return t))))))))
+      (push (list (car d) (car v)) let-list))))
+
+
+;;; The built-in DEFSETFs.
+
+(defsetf car %rplaca)
+(defsetf cdr %rplacd)
+(defsetf caar (x) (v) `(%rplaca (car ,x) ,v))
+(defsetf cadr (x) (v) `(%rplaca (cdr ,x) ,v))
+(defsetf cdar (x) (v) `(%rplacd (car ,x) ,v))
+(defsetf cddr (x) (v) `(%rplacd (cdr ,x) ,v))
+(defsetf caaar (x) (v) `(%rplaca (caar ,x) ,v))
+(defsetf cadar (x) (v) `(%rplaca (cdar ,x) ,v))
+(defsetf cdaar (x) (v) `(%rplacd (caar ,x) ,v))
+(defsetf cddar (x) (v) `(%rplacd (cdar ,x) ,v))
+(defsetf caadr (x) (v) `(%rplaca (cadr ,x) ,v))
+(defsetf caddr (x) (v) `(%rplaca (cddr ,x) ,v))
+(defsetf cdadr (x) (v) `(%rplacd (cadr ,x) ,v))
+(defsetf cdddr (x) (v) `(%rplacd (cddr ,x) ,v))
+(defsetf caaaar (x) (v) `(%rplaca (caaar ,x) ,v))
+(defsetf cadaar (x) (v) `(%rplaca (cdaar ,x) ,v))
+(defsetf cdaaar (x) (v) `(%rplacd (caaar ,x) ,v))
+(defsetf cddaar (x) (v) `(%rplacd (cdaar ,x) ,v))
+(defsetf caadar (x) (v) `(%rplaca (cadar ,x) ,v))
+(defsetf caddar (x) (v) `(%rplaca (cddar ,x) ,v))
+(defsetf cdadar (x) (v) `(%rplacd (cadar ,x) ,v))
+(defsetf cdddar (x) (v) `(%rplacd (cddar ,x) ,v))
+(defsetf caaadr (x) (v) `(%rplaca (caadr ,x) ,v))
+(defsetf cadadr (x) (v) `(%rplaca (cdadr ,x) ,v))
+(defsetf cdaadr (x) (v) `(%rplacd (caadr ,x) ,v))
+(defsetf cddadr (x) (v) `(%rplacd (cdadr ,x) ,v))
+(defsetf caaddr (x) (v) `(%rplaca (caddr ,x) ,v))
+(defsetf cadddr (x) (v) `(%rplaca (cdddr ,x) ,v))
+(defsetf cdaddr (x) (v) `(%rplacd (caddr ,x) ,v))
+(defsetf cddddr (x) (v) `(%rplacd (cdddr ,x) ,v))
+
+(defsetf first %rplaca)
+(defsetf second (x) (v) `(%rplaca (cdr ,x) ,v))
+(defsetf third (x) (v) `(%rplaca (cddr ,x) ,v))
+(defsetf fourth (x) (v) `(%rplaca (cdddr ,x) ,v))
+(defsetf fifth (x) (v) `(%rplaca (cddddr ,x) ,v))
+(defsetf sixth (x) (v) `(%rplaca (cdr (cddddr ,x)) ,v))
+(defsetf seventh (x) (v) `(%rplaca (cddr (cddddr ,x)) ,v))
+(defsetf eighth (x) (v) `(%rplaca (cdddr (cddddr ,x)) ,v))
+(defsetf ninth (x) (v) `(%rplaca (cddddr (cddddr ,x)) ,v))
+(defsetf tenth (x) (v) `(%rplaca (cdr (cddddr (cddddr ,x))) ,v))
+(defsetf rest %rplacd)
+
+(defsetf elt %setelt)
+(defsetf aref %aset)
+(defsetf svref %svset)
+(defsetf char %charset)
+(defsetf bit %bitset)
+(defsetf schar %scharset)
+(defsetf sbit %sbitset)
+(defsetf symbol-value set)
+(defsetf symbol-function %sp-set-definition)
+(defsetf symbol-plist %sp-set-plist)
+(defsetf documentation %set-documentation)
+(defsetf nth %setnth)
+(defsetf fill-pointer %set-fill-pointer)
+(defsetf search-list %set-search-list)
+
+
+(define-setf-method getf (place prop &optional default &environment env)
+  (multiple-value-bind (temps values stores set get)
+		       (foo-get-setf-method place env)
+    (let ((newval (gensym))
+	  (ptemp (gensym))
+	  (def-temp (gensym)))
+      (values `(,@temps ,(car stores) ,ptemp ,@(if default `(,def-temp)))
+	      `(,@values ,get ,prop ,@(if default `(,default)))
+	      `(,newval)
+	      `(progn (setq ,(car stores)
+			    (%primitive putf ,(car stores) ,ptemp ,newval))
+		      ,set
+		      ,newval)
+	      `(getf ,(car stores) ,ptemp ,@(if default `(,def-temp)))))))
+
+(define-setf-method get (symbol prop &optional default)
+  "Get turns into %put. Don't put in the default unless it really is supplied and 
+  non-nil, so that we can transform into the get instruction whenever possible."
+  (let ((symbol-temp (gensym))
+	(prop-temp (gensym))
+	(def-temp (gensym))
+	(newval (gensym)))
+    (values `(,symbol-temp ,prop-temp ,@(if default `(,def-temp)))
+	    `(,symbol ,prop ,@(if default `(,default)))
+	    (list newval)
+	    `(%put ,symbol-temp ,prop-temp ,newval)
+	    `(get ,symbol-temp ,prop-temp ,@(if default `(,def-temp))))))
+
+(define-setf-method gethash (key hashtable &optional default)
+  (let ((key-temp (gensym))
+	(hashtable-temp (gensym))
+	(default-temp (gensym))
+	(new-value-temp (gensym)))
+    (values
+     `(,key-temp ,hashtable-temp ,@(if default `(,default-temp)))
+     `(,key ,hashtable ,@(if default `(,default)))
+     `(,new-value-temp)
+     `(%puthash ,key-temp ,hashtable-temp ,new-value-temp)
+     `(gethash ,key-temp ,hashtable-temp ,@(if default `(,default-temp))))))
+
+(defsetf subseq (sequence start &optional (end nil)) (v)
+  `(progn (replace ,sequence ,v :start1 ,start :end1 ,end)
+	  ,v))
+
+
+;;; Evil hack invented by the gnomes of Vassar Street.  The function
+;;; arg must be constant.  Get a setf method for this function, pretending
+;;; that the final (list) arg to apply is just a normal arg.  If the
+;;; setting and access forms produced in this way reference this arg at
+;;; the end, then just splice the APPLY back onto the front and the right
+;;; thing happens.
+
+(define-setf-method apply (function &rest args &environment env)
+  (if (and (listp function)
+	   (= (list-length function) 2)
+	   (eq (first function) 'function)
+	   (symbolp (second function)))
+      (setq function (second function))
+      (error
+       "Setf of Apply is only defined for function args of form #'symbol."))
+  (multiple-value-bind (dummies vals newval setter getter)
+		       (foo-get-setf-method (cons function args) env)
+    ;; Special case aref and svref.
+    (cond ((or (eq function 'aref) (eq function 'svref))
+	   (let ((nargs (subseq setter 0 (1- (length setter))))
+		 (fcn (if (eq function 'aref) 'lisp::%apply-aset 'lisp::%apply-svset)))
+	     (values dummies vals newval
+		     `(apply (function ,fcn) ,(car newval) ,@(cdr nargs))
+		     `(apply (function ,function) ,@(cdr getter)))))
+	  ;; Make sure the place is one that we can handle.
+	  (T (unless (and (eq (car (last args)) (car (last vals)))
+			  (eq (car (last getter)) (car (last dummies)))
+			  (eq (car (last setter)) (car (last dummies))))
+	       (error "Apply of ~S not understood as a location for Setf."
+		      function))
+	     (values dummies vals newval
+		     `(apply (function ,(car setter)) ,@(cdr setter))
+		     `(apply (function ,(car getter)) ,@(cdr getter)))))))
+
+
+(define-setf-method ldb (bytespec place &environment env)
+  "The first argument is a byte specifier.  The second is any place form
+  acceptable to SETF.  Replaces the specified byte of the number in this
+  place with bits from the low-order end of the new value."
+  (multiple-value-bind (dummies vals newval setter getter)
+		       (foo-get-setf-method place env)
+    (let ((btemp (gensym))
+	  (gnuval (gensym)))
+      (values (cons btemp dummies)
+	      (cons bytespec vals)
+	      (list gnuval)
+	      `(let ((,(car newval) (dpb ,gnuval ,btemp ,getter)))
+		 ,setter
+		 ,gnuval)
+	      `(ldb ,btemp ,getter)))))
+
+
+(define-setf-method mask-field (bytespec place &environment env)
+  "The first argument is a byte specifier.  The second is any place form
+  acceptable to SETF.  Replaces the specified byte of the number in this place
+  with bits from the corresponding position in the new value."
+  (multiple-value-bind (dummies vals newval setter getter)
+		       (foo-get-setf-method place env)
+    (let ((btemp (gensym))
+	  (gnuval (gensym)))
+      (values (cons btemp dummies)
+	      (cons bytespec vals)
+	      (list gnuval)
+	      `(let ((,(car newval) (deposit-field ,gnuval ,btemp ,getter)))
+		 ,setter
+		 ,gnuval)
+	      `(mask-field ,btemp ,getter)))))
+
+
+(define-setf-method char-bit (place bit-name &environment env)
+  "The first argument is any place form acceptable to SETF.  Replaces the
+  specified bit of the character in this place with the new value."
+  (multiple-value-bind (dummies vals newval setter getter)
+		       (foo-get-setf-method place env)
+    (let ((btemp (gensym))
+	  (gnuval (gensym)))
+      (values `(,@dummies ,btemp)
+	      `(,@vals ,bit-name)
+	      (list gnuval)
+	      `(let ((,(car newval)
+		      (set-char-bit ,getter ,btemp ,gnuval)))
+		 ,setter
+		 ,gnuval)
+	      `(char-bit ,getter ,btemp)))))
+
+
+(define-setf-method the (type place &environment env)
+  (multiple-value-bind (dummies vals newval setter getter)
+		       (foo-get-setf-method place env)
+      (values dummies
+	      vals
+	      newval
+	      (subst `(the ,type ,(car newval)) (car newval) setter)
+	      `(the ,type ,getter))))
+
+
+
+;;;; CASE, TYPECASE, & Friends.
+
+(eval-when (compile load eval)
+
+;;; CASE-BODY returns code for all the standard "case" macros.  Name is the
+;;; macro name, and keyform is the thing to case on.  Multi-p indicates whether
+;;; a branch may fire off a list of keys; otherwise, a key that is a list is
+;;; interpreted in some way as a single key.  When multi-p, test is applied to
+;;; the value of keyform and each key for a given branch; otherwise, test is
+;;; applied to the value of keyform and the entire first element, instead of
+;;; each part, of the case branch.  When errorp, no t or otherwise branch is
+;;; permitted, and an ERROR form is generated.  When proceedp, it is an error
+;;; to omit errorp, and the ERROR form generated is executed within a
+;;; RESTART-CASE allowing keyform to be set and retested.
+;;;
+(defun case-body (name keyform cases multi-p test errorp proceedp)
+  (let ((keyform-value (gensym))
+	(clauses ())
+	(keys ()))
+    (dolist (case cases)
+      (cond ((atom case)
+	     (error "~S -- Bad clause in ~S." case name))
+	    ((memq (car case) '(t otherwise))
+	     (if errorp
+		 (error "No default clause allowed in ~S: ~S" name case)
+		 (push `(t nil ,@(rest case)) clauses)))
+	    ((and multi-p (listp (first case)))
+	     (setf keys (append (first case) keys))
+	     (push `((or ,@(mapcar #'(lambda (key)
+				       `(,test ,keyform-value ',key))
+				   (first case)))
+		     nil ,@(rest case))
+		   clauses))
+	    (t
+	     (push (first case) keys)
+	     (push `((,test ,keyform-value
+			    ',(first case)) nil ,@(rest case)) clauses))))
+    (case-body-aux name keyform keyform-value clauses keys errorp proceedp
+		   `(,(if multi-p 'member 'or) ,@keys))))
+
+;;; CASE-BODY-AUX provides the expansion once CASE-BODY has groveled all the
+;;; cases.  Note: it is not necessary that the resulting code signal
+;;; case-failure conditions, but that's what KMP's prototype code did.  We call
+;;; CASE-BODY-ERROR, because of how closures are compiled.  RESTART-CASE has
+;;; forms with closures that the compiler causes to be generated at the top of
+;;; any function using the case macros, regardless of whether they are needed.
+;;;
+(defun case-body-aux (name keyform keyform-value clauses keys
+		      errorp proceedp expected-type)
+  (if proceedp
+      (let ((block (gensym))
+	    (again (gensym)))
+	`(let ((,keyform-value ,keyform))
+	   (block ,block
+	     (tagbody
+	      ,again
+	      (return-from
+	       ,block
+	       (cond ,@(nreverse clauses)
+		     (t
+		      (setf ,keyform-value
+			    (setf ,keyform
+				  (case-body-error
+				   ',name ',keyform ,keyform-value
+				   ',expected-type ',keys)))
+		      (go ,again))))))))
+      `(let ((,keyform-value ,keyform))
+	 (cond
+	  ,@(nreverse clauses)
+	  ,@(if errorp
+		`((t (error 'conditions::case-failure
+			    :name ',name
+			    :datum ,keyform-value
+			    :expected-type ',expected-type
+			    :possibilities ',keys))))))))
+
+); eval-when
+
+(defun case-body-error (name keyform keyform-value expected-type keys)
+  (restart-case
+      (error 'conditions::case-failure
+	     :name name
+	     :datum keyform-value
+	     :expected-type expected-type
+	     :possibilities keys)
+    (store-value (value)
+      :report (lambda (stream)
+		(format stream "Supply a new value for ~S." keyform))
+      :interactive read-evaluated-form
+      value)))
+
+
+
+(defmacro case (keyform &body cases)
+  "CASE Keyform {({(Key*) | Key} Form*)}*
+  Evaluates the Forms in the first clause with a Key EQL to the value of
+  Keyform.  If a singleton key is T then the clause is a default clause."
+  (case-body 'case keyform cases t 'eql nil nil))
+
+(defmacro ccase (keyform &body cases)
+  "CCASE Keyform {({(Key*) | Key} Form*)}*
+  Evaluates the Forms in the first clause with a Key EQL to the value of
+  Keyform.  If none of the keys matches then a correctable error is
+  signalled."
+  (case-body 'ccase keyform cases t 'eql t t))
+
+(defmacro ecase (keyform &body cases)
+  "ECASE Keyform {({(Key*) | Key} Form*)}*
+  Evaluates the Forms in the first clause with a Key EQL to the value of
+  Keyform.  If none of the keys matches then an error is signalled."
+  (case-body 'ecase keyform cases t 'eql t nil))
+
+(defmacro typecase (keyform &body cases)
+  "TYPECASE Keyform {(Type Form*)}*
+  Evaluates the Forms in the first clause for which TYPEP of Keyform and Type
+  is true."
+  (case-body 'typecase keyform cases nil 'typep nil nil))
+
+(defmacro ctypecase (keyform &body cases)
+  "CTYPECASE Keyform {(Type Form*)}*
+  Evaluates the Forms in the first clause for which TYPEP of Keyform and Type
+  is true.  If no form is satisfied then a correctable error is signalled."
+  (case-body 'ctypecase keyform cases nil 'typep t t))
+
+(defmacro etypecase (keyform &body cases)
+  "ETYPECASE Keyform {(Type Form*)}*
+  Evaluates the Forms in the first clause for which TYPEP of Keyform and Type
+  is true.  If no form is satisfied then an error is signalled."
+  (case-body 'etypecase keyform cases nil 'typep t nil))
+
+
+;;;; ASSERT and CHECK-TYPE.
+
+;;; ASSERT is written this way, to call ASSERT-ERROR, because of how closures
+;;; are compiled.  RESTART-CASE has forms with closures that the compiler
+;;; causes to be generated at the top of any function using ASSERT, regardless
+;;; of whether they are needed.
+;;;
+(defmacro assert (test-form &optional places datum &rest arguments)
+  "Signals an error if the value of test-form is nil.  Continuing from this
+   error using the CONTINUE restart will allow the user to alter the value of
+   some locations known to SETF, starting over with test-form.  Returns nil."
+  `(loop
+     (when ,test-form (return nil))
+     (assert-error ',test-form ',places ,datum ,@arguments)
+     ,@(mapcar #'(lambda (place)
+		   `(setf ,place (assert-prompt ',place ,place)))
+	       places)))
+
+(defun assert-error (test-form places datum &rest arguments)
+  (restart-case (if datum
+		    (apply #'error datum arguments)
+		    (simple-assertion-failure test-form))
+    (continue ()
+      :report (lambda (stream) (assert-report places stream))
+      nil)))
+
+(defun simple-assertion-failure (assertion)
+  (error 'simple-type-error
+	 :datum assertion
+	 :expected-type nil ;this needs some work in next revision. -kmp
+	 :format-string "The assertion ~S failed."
+	 :format-arguments (list assertion)))
+
+(defun assert-report (names stream)
+  (format stream "Retry assertion")
+  (if names
+      (format stream " with new value~P for ~{~S~^, ~}."
+	      (length names) names)
+      (format stream ".")))
+
+(defun assert-prompt (name value)
+  (cond ((y-or-n-p "The old value of ~S is ~S.~
+		  ~%Do you want to supply a new value? "
+		   name value)
+	 (format *query-io* "~&Type a form to be evaluated:~%")
+	 (flet ((read-it () (eval (read *query-io*))))
+	   (if (symbolp name) ;help user debug lexical variables
+	       (progv (list name) (list value) (read-it))
+	       (read-it))))
+	(t value)))
+
+
+;;; CHECK-TYPE is written this way, to call CHECK-TYPE-ERROR, because of how
+;;; closures are compiled.  RESTART-CASE has forms with closures that the
+;;; compiler causes to be generated at the top of any function using
+;;; CHECK-TYPE, regardless of whether they are needed.  Because it would be
+;;; nice if this were cheap to use, and some things can't afford this excessive
+;;; consing (e.g., READ-CHAR), we bend backwards a little.
+;;;
+
+(defmacro check-type (place type &optional type-string)
+  "Signals an error of type type-error if the contents of place are not of the
+   specified type.  If an error is signaled, this can only return if
+   STORE-VALUE is invoked.  It will store into place and start over."
+  (let ((place-value (gensym)))
+    `(loop
+       (let ((,place-value ,place))
+	 (when (typep ,place-value ',type) (return nil))
+	 (setf ,place
+	       (check-type-error ',place ,place-value ',type ,type-string))))))
+
+(defun check-type-error (place place-value type type-string)
+  (restart-case (if type-string
+		    (error 'simple-type-error
+			   :datum place :expected-type type
+			   :format-string
+			   "The value of ~S is ~S, which is not ~A."
+			   :format-arguments
+			   (list place place-value type-string))
+		    (error 'simple-type-error
+			   :datum place :expected-type type
+			   :format-string
+			   "The value of ~S is ~S, which is not of type ~S."
+			   :format-arguments
+			   (list place place-value type)))
+    (store-value (value)
+      :report (lambda (stream)
+		(format stream "Supply a new value of ~S."
+			place))
+      :interactive read-evaluated-form
+      value)))
+
+;;; READ-EVALUATED-FORM is used as the interactive method for restart cases
+;;; setup by the Common Lisp "casing" (e.g., CCASE and CTYPECASE) macros
+;;; and by CHECK-TYPE.
+;;;
+(defun read-evaluated-form ()
+  (format *query-io* "~&Type a form to be evaluated:~%")
+  (list (eval (read *query-io*))))
+
+
+;;;; With-XXX
+
+(defmacro with-open-file ((var &rest open-args) &body (forms decls))
+  "Bindspec is of the form (Stream File-Name . Options).  The file whose name
+  is File-Name is opened using the Options and bound to the variable Stream.
+  The Forms are executed, and when they terminate, normally or otherwise,
+  the file is closed."
+  (let ((abortp (gensym)))
+    `(let ((,var (open ,@open-args))
+	   (,abortp t))
+       ,@decls
+       (unwind-protect
+	 (multiple-value-prog1
+	  (progn ,@forms)
+	  (setq ,abortp nil))
+	 (when ,var
+	   (close ,var :abort ,abortp))))))
+
+
+(defmacro with-open-stream ((var stream) &body (forms decls))
+  "The form stream should evaluate to a stream.  VAR is bound
+   to the stream and the forms are evaluated as an implicit
+   progn.  The stream is closed upon exit."
+  (let ((abortp (gensym)))
+    `(let ((,var ,stream)
+	   (,abortp t))
+       ,@decls
+       (unwind-protect
+	 (multiple-value-prog1
+	  (progn ,@forms)
+	  (setq ,abortp nil))
+	 (when ,var
+	   (close ,var :abort ,abortp))))))
+
+
+(defmacro with-input-from-string ((var string &key index start end) &body (forms decls))
+  "Binds the Var to an input stream that returns characters from String and
+  executes the body.  See manual for details."
+  `(let ((,var
+	  ,(if end
+	       `(make-string-input-stream ,string ,(or start 0) ,end)
+	       `(make-string-input-stream ,string ,(or start 0)))))
+     ,@decls
+     (unwind-protect
+       (progn ,@forms)
+       (close ,var)
+       ,@(if index `((setf ,index (string-input-stream-current ,var)))))))
+
+
+(defmacro with-output-to-string ((var &optional string) &body (forms decls))
+  "Binds the Var to a string output stream that puts characters into String
+  and executes the body.  See manual for details."
+  (if string
+      `(let ((,var (make-fill-pointer-output-stream ,string)))
+	 ,@decls
+	 (unwind-protect
+	   (progn ,@forms)
+	   (close ,var)))
+      `(let ((,var (make-string-output-stream)))
+	 ,@decls
+	 (unwind-protect
+	   (progn ,@forms)
+	   (close ,var))
+	 (get-output-stream-string ,var))))
+
+
+;;;; Iteration macros:
+
+(defmacro loop (&rest body)
+  "Executes the body repeatedly until the form is exited by a Throw or
+  Return.  The body is surrounded by an implicit block with name NIL."
+  (let ((tag (gensym)))
+    `(block nil (tagbody ,tag ,@body (go ,tag)))))
+
+
+(defmacro dotimes ((var count &optional (result nil)) &body body)
+  (cond ((numberp count)
+         `(do ((,var 0 (1+ ,var)))
+              ((>= ,var ,count) ,result)
+            ,@body))
+        (t (let ((v1 (gensym)))
+             `(do ((,var 0 (1+ ,var)) (,v1 ,count))
+                  ((>= ,var ,v1) ,result)
+                ,@body)))))
+
+
+;;; We repeatedly bind the var instead of setting it so that we never give the
+;;; var a random value such as NIL (which might conflict with a declaration).
+;;; ### Might not be legal...
+;;;
+(defmacro dolist ((var list &optional (result nil)) &body body)
+  (let ((n-list (gensym)))
+    `(do ((,n-list ,list (cdr ,n-list)))
+	 ((endp ,n-list)
+	  (let ((,var nil))
+	    (declare (ignorable ,var))
+	    ,result))
+       (let ((,var (car ,n-list)))
+	 ,@body))))
+
+
+(defmacro do (varlist endlist &body (body decls))
+  "DO ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form*
+  Iteration construct.  Each Var is initialized in parallel to the value of the
+  specified Init form.  On subsequent iterations, the Vars are assigned the
+  value of the Step form (if any) in paralell.  The Test is evaluated before
+  each evaluation of the body Forms.  When the Test is true, the the Exit-Forms
+  are evaluated as a PROGN, with the result being the value of the DO.  A block
+  named NIL is established around the entire expansion, allowing RETURN to be
+  used as an laternate exit mechanism."
+
+  (do-do-body varlist endlist body decls 'let 'psetq 'do nil))
+
+
+(defmacro do* (varlist endlist &body (body decls))
+  "DO* ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form*
+  Iteration construct.  Each Var is initialized sequentially (like LET*) to the
+  value of the specified Init form.  On subsequent iterations, the Vars are
+  sequentially assigned the value of the Step form (if any).  The Test is
+  evaluated before each evaluation of the body Forms.  When the Test is true,
+  the the Exit-Forms are evaluated as a PROGN, with the result being the value
+  of the DO.  A block named NIL is established around the entire expansion,
+  allowing RETURN to be used as an laternate exit mechanism."
+  (do-do-body varlist endlist body decls 'let* 'setq 'do* nil))
+
+
+;;;; Miscellaneous macros:
+
+(defmacro locally (&rest forms)
+  "A form providing a container for locally-scoped variables."
+  `(let () ,@forms))
+
+(defmacro psetq (&rest pairs)
+  (do ((lets nil)
+       (setqs nil)
+       (pairs pairs (cddr pairs)))
+      ((atom (cdr pairs))
+       `(let ,(nreverse lets) (setq ,@(nreverse setqs))))
+    (let ((gen (gensym)))
+      (push `(,gen ,(cadr pairs)) lets)
+      (push (car pairs) setqs)
+      (push gen setqs))))
+
+;;; ### Bootstrap hack...
+;;; Restore defmacro processing to normal.
+;;;
+(eval-when (compile)
+  (setq *bootstrap-defmacro* nil))
+
+
+;;;; With-Compilation-Unit:
+
+;;; True if we are within a With-Compilation-Unit form, which normally causes
+;;; nested uses to be NOOPS.
+;;;
+(defvar *in-compilation-unit* nil)
+
+;;; Count of the number of compilation units dynamically enclosed by the
+;;; current active WITH-COMPILATION-UNIT that were unwound out of.
+;;;
+(defvar *aborted-compilation-units*)
+
+(compiler-let ((*bootstrap-defmacro* :both))
+
+;;; With-Compilation-Unit  --  Public
+;;;
+;;;
+(defmacro with-compilation-unit (options &body body)
+  (let ((force nil)
+	(n-fun (gensym))
+	(n-abort-p (gensym)))
+    (when (oddp (length options))
+      (error "Odd number of key/value pairs: ~S." options))
+    (do ((opt options (cddr opt)))
+	((null opt))
+      (case (first opt)
+	(:force
+	 (setq force (second opt)))
+	(t
+	 (warn "Ignoring unknown option: ~S." (first opt)))))
+
+    `(flet ((,n-fun () ,@body))
+       (if (or ,force (not *in-compilation-unit*))
+	   (let ((c::*unknown-functions* nil)
+		 (c::*compiler-error-count* 0)
+		 (c::*compiler-warning-count* 0)
+		 (c::*compiler-note-count* 0)
+		 (*in-compilation-unit* t)
+		 (*aborted-compilation-units* 0)
+		 (,n-abort-p t))
+	     (unwind-protect
+		 (multiple-value-prog1
+		     (,n-fun)
+		   (setq ,n-abort-p nil))
+	       (c::print-summary ,n-abort-p *aborted-compilation-units*)))
+	   (let ((,n-abort-p t))
+	     (unwind-protect
+		 (multiple-value-prog1
+		     (,n-fun)
+		   (setq ,n-abort-p nil))
+	       (when ,n-abort-p
+		 (incf *aborted-compilation-units*))))))))
+); Compiler-Let
diff --git a/code/misc.lisp b/code/misc.lisp
new file mode 100644
index 000000000..ffa274ec2
--- /dev/null
+++ b/code/misc.lisp
@@ -0,0 +1,126 @@
+;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; Assorted miscellaneous functions for Spice Lisp.
+;;;
+;;; Written and maintained mostly by Skef Wholey and Rob MacLachlan.
+;;; Scott Fahlman, Dan Aronson, and Steve Handerson did stuff here, too.
+;;;
+(in-package "LISP")
+(export '(documentation *features* common variable room
+	  lisp-implementation-type lisp-implementation-version machine-type
+	  machine-version machine-instance software-type software-version
+	  short-site-name long-site-name dribble))
+
+
+(defun documentation (symbol doc-type)
+  "Returns the documentation string of Doc-Type for the Symbol, or NIL if
+  none exists.  System doc-types are VARIABLE, FUNCTION, STRUCTURE, TYPE,
+  and SETF."
+  (case doc-type
+    (variable (get symbol '%var-documentation))
+    (function (get symbol '%fun-documentation))
+    (structure (get symbol '%struct-documentation))
+    (type (get symbol '%type-documentation))
+    (setf (get symbol '%setf-documentation))
+    (t (cdr (assoc doc-type (get symbol '%documentation))))))
+
+(defun %set-documentation (symbol doc-type string)
+  (case doc-type
+    (variable (%put symbol '%var-documentation string))
+    (function (%put symbol '%fun-documentation string))
+    (structure (%put symbol '%struct-documentation string))
+    (type (%put symbol '%type-documentation string))
+    (setf (%put symbol '%setf-documentation string))
+    (t (let ((pair (assoc doc-type (get symbol '%documentation))))
+	 (if pair (%rplacd pair string)
+	     (push (cons doc-type string) (get symbol '%documentation))))))
+  string)
+
+(defvar *features* '(:common :cmu :mach :ibm-rt-pc :clos :new-compiler)
+  "Holds a list of symbols that describe features provided by the
+   implementation.")
+
+(defun featurep (x)
+  "If X is an atom, see if it is present in *FEATURES*.  Also
+  handle arbitrary combinations of atoms using NOT, AND, OR."
+  (cond ((atom x) (memq x *features*))
+	((eq (car x) ':not) (not (featurep (cadr x))))
+	((eq (car x) ':and)
+	 (every #'featurep (cdr x)))
+	((eq (car x) ':or)
+	 (some #'featurep (cdr x)))
+	(t nil)))
+
+
+
+;;; Other Environment Inquiries.
+
+(defun lisp-implementation-type ()
+  "Returns a string describing the implementation type."
+  "CMU Common Lisp")
+
+(defun lisp-implementation-version ()
+  "Returns a string describing the implementation version."
+  *lisp-implementation-version*)
+
+(defun machine-type ()
+  "Returns a string describing the type of the local machine."
+  "IBM RT PC")
+
+(defun machine-version ()
+  "Returns a string describing the version of the local machine."
+  (let ((version (system:%primitive 16bit-system-ref
+				    (int-sap
+				     (+ (ash clc::romp-data-base 16)
+					clc::floating-point-hardware-available))
+				    1)))
+    (if (or (not (= (logand version clc::float-mc68881) 0))
+	    (not (= (logand version clc::float-afpa) 0)))
+	"IBM RT PC/APC"
+	"IBM RT PC")))
+
+(defun machine-instance ()
+  "Returns a string giving the name of the local machine."
+  (mach::unix-gethostname))
+
+(defun software-type ()
+  "Returns a string describing the supporting software."
+  "MACH/4.3BSD")
+
+(defun software-version ()
+  "Returns a string describing version of the supporting software."
+  NIL)
+
+(defun short-site-name ()
+  "Returns a string with the abbreviated site name."
+  "CMU-CSD")
+
+(defun long-site-name ()
+  "Returns a string with the long form of the site name."
+  "Carnegie-Mellon University Computer Science Department")
+
+
+
+;;;; Dribble stuff:
+
+(defun dribble (&optional pathname &key (if-exists :append))
+  "With a file name as an argument, dribble opens the file and
+   sends a record of the output to that file.  Without an
+   argument, it closes the open dribble file."
+  (if pathname
+      (with-open-file (f pathname :direction :output  :if-exists if-exists
+			 :if-does-not-exist :create)
+	(catch 'dribble-punt
+	  (let ((*terminal-io*
+		 (make-two-way-stream
+		  (make-echo-stream *terminal-io* f)
+		  (make-broadcast-stream *terminal-io* f))))
+	    (%top-level))))
+      (throw 'dribble-punt nil)))
diff --git a/code/package.lisp b/code/package.lisp
new file mode 100644
index 000000000..d175370ca
--- /dev/null
+++ b/code/package.lisp
@@ -0,0 +1,1101 @@
+;;; -*- Log: code.log; Package: Lisp -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;;     Package stuff and stuff like that.
+;;;
+;;; Re-Written by Rob MacLachlan.  Earlier version written by
+;;; Lee Schumacher.  Apropos & iteration macros courtesy of Skef Wholey.
+;;;
+(in-package 'lisp)
+(export '(package packagep *package* make-package in-package find-package
+	  package-name package-nicknames rename-package
+	  package-use-list package-used-by-list package-shadowing-symbols
+	  list-all-packages intern find-symbol unintern export
+	  unexport import shadowing-import shadow use-package
+	  unuse-package find-all-symbols do-symbols
+	  do-external-symbols do-all-symbols apropos apropos-list))
+
+
+(in-package "EXTENSIONS")
+(export '(*keyword-package* *lisp-package*))
+(in-package 'lisp)
+
+
+(defstruct (package
+	    (:constructor internal-make-package)
+	    (:predicate packagep)
+	    (:print-function
+	     (lambda (s stream d)
+	       (declare (ignore d) (stream stream))
+	       (multiple-value-bind (iu it) (internal-symbol-count s)
+		 (multiple-value-bind (eu et) (external-symbol-count s)
+		   (format stream
+			   "#<The ~A package, ~D/~D internal, ~D/~D external>"
+			   (package-name s) iu it eu et))))))
+  "Standard structure for the description of a package.  Consists of 
+   a list of all hash tables, the name of the package, the nicknames of
+   the package, the use-list for the package, the used-by- list, hash-
+   tables for the internal and external symbols, and a list of the
+   shadowing symbols."
+  (tables (list nil))	; A list of all the hashtables for inherited symbols.
+  name			; The string name of the package.
+  nicknames		; List of nickname strings.
+  (use-list ())		; List of packages we use.
+  (used-by-list ())	; List of packages that use this package.
+  internal-symbols	; Hashtable of internal symbols.
+  external-symbols	; Hashtable of external symbols.
+  (shadowing-symbols ())) ; List of shadowing symbols.
+
+(defvar *package* () "The current package.")
+
+;;; An equal hashtable from package names to packages.
+;;;
+(defvar *package-names* (make-hash-table :test #'equal))
+
+
+;;; Lots of people want the keyword package and Lisp package without a lot
+;;; of fuss, so we give them their own variables.
+;;;
+(defvar *lisp-package*)
+(defvar *keyword-package*)
+
+
+;;; This magical variable is T during initialization so Use-Package's of packages
+;;; that don't yet exist quietly win.  Such packages are thrown onto the list
+;;; *Deferred-Use-Packages* so that this can be fixed up later.
+
+(defvar *in-package-init* nil)
+(defvar *deferred-use-packages* nil)
+
+;;; Find-Package  --  Public
+;;;
+;;;
+(defun find-package (name)
+  "Find the package having the specified name."
+  (values (gethash (string name) *package-names*)))
+
+;;; Package-Listify  --  Internal
+;;;
+;;;    Return a list of packages given a package-or-string-or-symbol or
+;;; list thereof, or die trying.
+;;;
+(defun package-listify (thing)
+  (let ((res ()))
+    (dolist (thing (if (listp thing) thing (list thing)) res)
+      (push (package-or-lose thing) res))))
+
+;;; Package-Or-Lose  --  Internal
+;;;
+;;;    Take a package-or-string-or-symbol and return a package.
+;;;
+(defun package-or-lose (thing)
+  (if (packagep thing)
+      thing
+      (let ((thing (string thing)))
+	(cond ((gethash thing *package-names*))
+	      (t
+	       (cerror "Make this package."
+		       "~S is not the name of a package." thing)
+	       (make-package thing))))))  
+
+;;;; Package-Hashtables
+;;;
+;;;    Packages are implemented using a special kind of hashtable.  It is
+;;; an open hashtable with a parallel 8-bit I-vector of hash-codes.  The
+;;; primary purpose of the hash for each entry is to reduce paging by
+;;; allowing collisions and misses to be detected without paging in the
+;;; symbol and pname for an entry.  If the hash for an entry doesn't
+;;; match that for the symbol that we are looking for, then we can
+;;; go on without touching the symbol, pname, or even hastable vector.
+;;;    It turns out that, contrary to my expectations, paging is a very
+;;; important consideration the design of the package representation.
+;;; Using a similar scheme without the entry hash, the fasloader was
+;;; spending more than half its time paging in INTERN.
+;;;    The hash code also indicates the status of an entry.  If it zero,
+;;; the the entry is unused.  If it is one, then it is deleted.
+;;; Double-hashing is used for collision resolution.
+
+(defstruct (package-hashtable
+	    (:constructor internal-make-package-hashtable ())
+	    (:copier nil)
+	    (:print-function
+	     (lambda (table stream d)
+	       (declare (ignore d))
+	       (format stream
+		       "#<Package-Hashtable: Size = ~D, Free = ~D, Deleted = ~D>"
+		       (package-hashtable-size table)
+		       (package-hashtable-free table)
+		       (package-hashtable-deleted table)))))
+  table		; The g-vector of symbols.
+  hash		; The i-vector of pname hash values.
+  size		; The maximum number of entries allowed.
+  free		; The entries that can be made before we have to rehash.
+  deleted)	; The number of deleted entries.
+
+
+;;; The maximum density we allow in a package hashtable.
+;;;
+(defparameter package-rehash-threshold 3/4)
+
+;;; Entry-Hash  --  Internal
+;;;
+;;;    Compute a number from the sxhash of the pname and the length which
+;;; must be between 2 and 255.
+;;;
+(defmacro entry-hash (length sxhash)
+  `(the fixnum (+ (the fixnum (rem (the fixnum (logxor ,length
+						       ,sxhash
+						       (the fixnum (ash ,sxhash -8))
+						       (the fixnum (ash ,sxhash -16))
+						       (the fixnum (ash ,sxhash -19))))
+				   254))
+		  2)))
+
+;;; Make-Package-Hashtable  --  Internal
+;;;
+;;;    Make a package hashtable having a prime number of entries at least
+;;; as great as (/ size package-rehash-threshold).  If Res is supplied,
+;;; then it is destructively modified to produce the result.  This is
+;;; useful when changing the size, since there are many pointers to
+;;; the hashtable.
+;;;
+(defun make-package-hashtable (size &optional
+				    (res (internal-make-package-hashtable)))
+  (do ((n (logior (truncate size package-rehash-threshold) 1)
+	  (+ n 2)))
+      ((primep n)
+       (setf (package-hashtable-table res)
+	     (make-array n))
+       (setf (package-hashtable-hash res)
+	     (make-array n :element-type '(unsigned-byte 8) :initial-element 0))
+       (let ((size (truncate (* n package-rehash-threshold))))
+	 (setf (package-hashtable-size res) size)
+	 (setf (package-hashtable-free res) size))
+       (setf (package-hashtable-deleted res) 0)
+       res)
+    (declare (fixnum n))))
+
+
+;;; Internal-Symbol-Count, External-Symbols-Count  --  Internal
+;;;
+;;;    Return internal and external symbols.  Used by Genesis and stuff.
+;;;
+(flet ((stuff (table)
+	      (let ((size (the fixnum (- (the fixnum (package-hashtable-size table))
+					 (the fixnum (package-hashtable-deleted table))))))
+		(declare (fixnum size))
+		(values (the fixnum (- size (the fixnum (package-hashtable-free table)))) size))))
+
+  (defun internal-symbol-count (package)
+    (stuff (package-internal-symbols package)))
+
+  (defun external-symbol-count (package)
+    (stuff (package-external-symbols package))))
+
+
+;;; Add-Symbol  --  Internal
+;;;
+;;;    Add a symbol to a package hashtable.  The symbol is assumed
+;;; not to be present.
+;;;
+(defun add-symbol (table symbol)
+  (let* ((vec (package-hashtable-table table))
+	 (hash (package-hashtable-hash table))
+	 (len (length vec))
+	 (sxhash (%primitive sxhash-simple-string (symbol-name symbol)))
+	 (h2 (the fixnum (1+ (the fixnum (rem sxhash
+					      (the fixnum (- len 2))))))))
+    (declare (simple-vector vec)
+	     (type (simple-array (unsigned-byte 8)) hash)
+	     (fixnum len sxhash h2))
+    (cond ((zerop (the fixnum (package-hashtable-free table)))
+	   (make-package-hashtable (the fixnum
+					(* (the fixnum
+						(package-hashtable-size table))
+					   2))
+				   table)
+	   (add-symbol table symbol)
+	   (dotimes (i len)
+	     (declare (fixnum i))
+	     (when (> (the fixnum (aref hash i)) 1)
+	       (add-symbol table (svref vec i)))))
+	  (t
+	   (do ((i (rem sxhash len) (rem (+ i h2) len)))
+	       ((< (the fixnum (aref hash i)) 2)
+		(if (zerop (the fixnum (aref hash i)))
+		    (decf (the fixnum (package-hashtable-free table)))
+		    (decf (the fixnum (package-hashtable-deleted table))))
+		(setf (svref vec i) symbol)
+		(setf (aref hash i)
+		      (entry-hash (length (the simple-string (symbol-name symbol)))
+				  sxhash)))
+	     (declare (fixnum i)))))))
+
+;;; With-Symbol  --  Internal
+;;;
+;;;    Find where the symbol named String is stored in Table.  Index-Var
+;;; is bound to the index, or NIL if it is not present.  Symbol-Var
+;;; is bound to the symbol.  Length and Hash are the length and sxhash
+;;; of String.  Entry-Hash is the entry-hash of the string and length.
+;;;
+(defmacro with-symbol ((index-var symbol-var table string length sxhash
+				  entry-hash)
+		       &body forms)
+  (let ((vec (gensym)) (hash (gensym)) (len (gensym)) (h2 (gensym))
+	(name (gensym)) (name-len (gensym)) (ehash (gensym)))
+    `(let* ((,vec (package-hashtable-table ,table))
+	    (,hash (package-hashtable-hash ,table))
+	    (,len (length ,vec))
+	    (,h2 (1+ (the fixnum (rem (the fixnum ,sxhash)
+				      (the fixnum (- ,len 2)))))))
+       (declare (type (simple-array (unsigned-byte 8)) ,hash)
+		(simple-vector ,vec)
+		(fixnum ,len ,h2))
+       (prog ((,index-var (rem (the fixnum ,sxhash) ,len))
+	      ,symbol-var ,ehash)
+	 (declare (type (or fixnum null) ,index-var))
+	 LOOP
+	 (setq ,ehash (aref ,hash ,index-var))
+	 (cond ((eql ,ehash ,entry-hash)
+		(setq ,symbol-var (svref ,vec ,index-var))
+		(let* ((,name (symbol-name ,symbol-var))
+		       (,name-len (length ,name)))
+		  (declare (simple-string ,name)
+			   (fixnum ,name-len))
+		  (when (and (= ,name-len ,length)
+			     (string= ,string ,name  :end1 ,length
+				      :end2 ,name-len))
+		    (go DOIT))))
+	       ((zerop ,ehash)
+		(setq ,index-var nil)
+		(go DOIT)))
+	 (setq ,index-var (rem (+ ,index-var ,h2) ,len))
+	 (go LOOP)
+	 DOIT
+	 (return (progn ,@forms))))))
+
+;;; Nuke-Symbol  --  Internal
+;;;
+;;;    Delete the entry for String in Table.  The entry must exist.
+;;;
+(defun nuke-symbol (table string)
+  (declare (simple-string string))
+  (let* ((length (length string))
+	 (hash (%primitive sxhash-simple-string string))
+	 (ehash (entry-hash length hash)))
+    (declare (fixnum length hash))
+    (with-symbol (index symbol table string length hash ehash)
+      (setf (aref (package-hashtable-hash table) index) 1)
+      (setf (aref (package-hashtable-table table) index) nil)
+      (incf (package-hashtable-deleted table)))))
+
+;;;; Iteration macros.
+
+;;; Instead of using slow, silly successor functions, we make the iteration
+;;; guys be big PROG's.  Yea!
+
+(eval-when (compile load eval)
+
+(defun make-do-symbols-vars ()
+  `(,(gensym)					; index
+    ,(gensym)					; hash
+    ,(gensym)					; hash-vector
+    ,(gensym)))					; terminus
+
+(defun make-do-symbols-code (vars var hash-table exit-form forms)
+  (let ((index (first vars))
+	(hash-vector (second vars))
+	(hash (third vars))
+	(terminus (fourth vars))
+	(TOP (gensym)))
+    `((setq ,index 0)
+      (setq ,hash-vector (package-hashtable-table ,hash-table))
+      (setq ,hash (package-hashtable-hash ,hash-table))
+      (setq ,terminus (length (the simple-vector ,hash-vector)))
+      ,TOP
+      (if (= (the fixnum ,index) (the fixnum ,terminus))
+	  ,exit-form)
+      (when (> (the fixnum (aref (the (simple-array (unsigned-byte 8)) ,hash)
+				 ,index))
+	       1)
+	(setq ,var (svref ,hash-vector ,index))
+	,@forms)
+      (incf ,index)
+      (go ,TOP))))
+
+); eval-when (compile load eval)
+
+(defmacro do-symbols ((var &optional (package '*package*) result-form)
+		      &body (code decls))
+  "Do-Symbols (Var [Package [Result-Form]]) {Declaration}* {Tag | Statement}*
+  Executes the Forms at least once for each symbol accessible in the given
+  Package with Var bound to the current symbol."
+  (let* ((DONE-INTERNAL (gensym))
+	 (DONE-EXTERNAL (gensym))
+	 (NEXT-INHERIT (gensym))
+	 (vars (make-do-symbols-vars))
+	 (n-package (gensym))
+	 (shadowed (gensym))
+	 (inherits (gensym))
+	 (this-inherit (gensym)))
+    `(prog* ((,n-package (package-or-lose ,package))
+	     (,shadowed (package-shadowing-symbols ,n-package))
+	     (,inherits (package-use-list ,n-package))
+	     ,var ,@vars ,this-inherit)
+       ,@decls
+       ,@(make-do-symbols-code
+	  vars var `(package-internal-symbols ,n-package)
+	  `(go ,DONE-INTERNAL)
+	  code)
+       ,DONE-INTERNAL
+
+       ,@(make-do-symbols-code
+	  vars var `(package-external-symbols ,n-package)
+	  `(go ,DONE-EXTERNAL)
+	  code)
+       ,DONE-EXTERNAL
+
+       ,NEXT-INHERIT
+       (when (null ,inherits)
+	 (setq ,var nil)
+	 (return ,result-form))
+
+       (setq ,this-inherit (package-external-symbols (car ,inherits)))
+       ,@(make-do-symbols-code
+	  vars var this-inherit
+	  `(progn
+	    (setq ,inherits (cdr ,inherits))
+	    (go ,NEXT-INHERIT))
+	  `((when (or (not ,shadowed)
+		      (eq (find-symbol (symbol-name ,var) ,n-package) ,var))
+	      ,@code))))))
+
+(defmacro do-external-symbols ((var &optional (package '*package*) result-form)
+			       &body (code decls))
+  "Do-External-Symbols (Var [Package [Result-Form]])
+                       {Declaration}* {Tag | Statement}*
+  Executes the Forms once for each external symbol in the given Package with
+  Var bound to the current symbol."
+  (let ((vars (make-do-symbols-vars))
+	(n-package (gensym)))
+    `(prog ((,n-package (package-or-lose ,package))
+	    ,var ,@vars)
+       ,@decls
+       ,@(make-do-symbols-code
+	  vars var `(package-external-symbols ,n-package)
+	  `(return (progn (setq ,var nil) ,result-form))
+	  code))))
+
+(defmacro do-all-symbols ((var &optional result-form)
+			  &body (code decls))
+  "Do-All-Symbols (Var [Result-Form]) {Declaration}* {Tag | Statement}*
+  Executes the Forms once for each symbol in each package with Var bound
+  to the current symbol."
+  (let* ((PACKAGE-LOOP (gensym))
+	 (TAG (gensym))
+	 (package-list (gensym))
+	 (vars (make-do-symbols-vars))
+	 (internal-code (make-do-symbols-code
+			 vars var `(package-internal-symbols (car ,package-list))
+			 `(go ,TAG)
+			 code))
+	 (external-code (make-do-symbols-code
+			 vars var `(package-external-symbols (car ,package-list))
+			 `(progn (setq ,package-list (cdr ,package-list))
+				 (go ,PACKAGE-LOOP))
+			 code)))
+    `(prog (,package-list ,var ,@vars)
+       ,@decls
+       (setq ,package-list (list-all-packages))
+      ,PACKAGE-LOOP
+       (when (null ,package-list)
+	 (setq ,var nil)
+	 (return ,result-form))
+       ,@internal-code
+      ,TAG
+       ,@external-code)))
+
+;;; Enter-New-Nicknames  --  Internal
+;;;
+;;;    Enter any new Nicknames for Package into *package-names*.
+;;; If there is a conflict then give the user a chance to do
+;;; something about it.
+;;;
+(defun enter-new-nicknames (package nicknames)
+  (check-type nicknames list)
+  (dolist (n nicknames)
+    (let* ((n (string n))
+	   (found (gethash n *package-names*)))
+      (cond ((not found)
+	     (setf (gethash n *package-names*) package)
+	     (push n (package-nicknames package)))
+	    ((eq found package))
+	    ((string= (package-name found) n)
+	     (cerror "Ignore this nickname."
+		     "~S is a package name, so it cannot be a nickname for ~S."
+		     n (package-name package)))
+	    (t
+	     (cerror "Redefine this nickname."
+		     "~S is already a nickname for ~S."
+		     n (package-name found))
+	     (setf (gethash n *package-names*) package)
+	     (push n (package-nicknames package)))))))
+
+
+;;; Make-Package  --  Public
+;;;
+;;;    Check for package name conflicts in name and nicknames, then
+;;; make the package.  Do a use-package for each thing in the use list
+;;; so that checking for conflicting exports among used packages is done.
+;;;
+(defun make-package (name &key (use '("LISP")) nicknames
+			  (internal-symbols 10) (external-symbols 10))
+  "Makes a new package having the specified Name and Nicknames.  The
+  package will inherit all external symbols from each package in
+  the use list.  :Internal-Symbols and :External-Symbols are
+  estimates for the number of internal and external symbols which
+  will ultimately be present in the package."
+  (when (find-package name)
+    (error "A package named ~S already exists" name))
+  (let* ((name (string name))
+	 (package (internal-make-package
+		   :name name
+		   :internal-symbols (make-package-hashtable internal-symbols)
+		   :external-symbols (make-package-hashtable external-symbols))))
+    (if *in-package-init*
+	(push (list use package) *deferred-use-packages*)
+	(use-package use package))
+    (enter-new-nicknames package nicknames)
+    (setf (gethash name *package-names*) package)))
+
+;;; In-Package  --  Public
+;;;
+;;;    Like Make-Package, only different.
+;;;
+(defun in-package (name &rest keys &key nicknames use)
+  "Sets *package* to package with given name, creating the package if
+  it does not exist.  If the package already exists then it is modified
+  to agree with the :Use and :Nicknames arguments.  Any new nicknames
+  are added without removing any old ones not specified.  If any package
+  in the :Use list is not currently used, then it is added to the use
+  list."
+  (let ((package (find-package name)))
+    (cond
+     (package
+      (if *in-package-init*
+	  (push (list use package) *deferred-use-packages*)
+	  (use-package use package))
+      (enter-new-nicknames package nicknames)
+      (setq *package* package))
+     (t
+      (setq *package* (apply #'make-package name keys))))))
+
+;;; Rename-Package  --  Public
+;;;
+;;;    Change the name if we can, blast any old nicknames and then
+;;; add in any new ones.
+;;;
+(defun rename-package (package name &optional (nicknames ()))
+  "Changes the name and nicknames for a package."
+  (check-type package package)
+  (let* ((package (package-or-lose package))
+	 (name (string name))
+	 (found (find-package name)))
+    (unless (or (not found) (eq found package))
+      (error "A package named ~S already exists." name))
+    (remhash (package-name package) *package-names*)
+    (setf (package-name package) name)
+    (setf (gethash name *package-names*) package)
+    (dolist (n (package-nicknames package))
+      (remhash n *package-names*))
+    (setf (package-nicknames package) ())
+    (enter-new-nicknames package nicknames)
+    package))
+
+;;; List-All-Packages  --  Public
+;;;
+;;;
+(defun list-all-packages ()
+  "Returns a list of all existing packages."
+  (let ((res ()))
+    (maphash #'(lambda (k v)
+		 (declare (ignore k))
+		 (pushnew v res))
+	     *package-names*)
+    res))
+
+;;; Intern  --  Public
+;;;
+;;;    Simple-stringify the name and call intern*.
+;;;
+(defun intern (name &optional package)
+  "Returns a symbol having the specified name, creating it if necessary."
+  (let ((name (if (simple-string-p name) name (coerce name 'simple-string))))
+    (declare (simple-string name))
+    (intern* name (length name)
+	     (if package (package-or-lose package) *package*))))
+
+;;; Find-Symbol  --  Public
+;;;
+;;;    Ditto.
+;;;
+(defun find-symbol (name &optional package)
+  "Returns the symbol named String in Package.  If such a symbol is found
+  then the second value is :internal, :external or :inherited to indicate
+  how the symbol is accessible.  If no symbol is found then both values
+  are NIL."
+  (let ((name (if (simple-string-p name) name (coerce name 'simple-string))))
+    (declare (simple-string name))
+    (find-symbol* name (length name)
+		  (if package (package-or-lose package) *package*))))
+
+;;; Intern*  --  Internal
+;;;
+;;;    If the symbol doesn't exist then create it, special-casing
+;;; the keyword package.
+;;;
+(defun intern* (name length package)
+  (declare (simple-string name))
+  (multiple-value-bind (symbol where) (find-symbol* name length package)
+    (if where
+	(values symbol where)
+	(let ((symbol (%primitive alloc-symbol (subseq name 0 length))))
+	  (%primitive set-package symbol package)
+	  (cond ((eq package *keyword-package*)
+		 (add-symbol (package-external-symbols package) symbol)
+		 (set symbol symbol))
+		(t
+		 (add-symbol (package-internal-symbols package) symbol)))
+	  (values symbol nil)))))
+
+;;; Find-Symbol*  --  Internal
+;;;
+;;;    Check internal and external symbols, then scan down the list
+;;; of hashtables for inherited symbols.  When an inherited symbol
+;;; is found pull that table to the beginning of the list.
+;;;
+(defun find-symbol* (string length package)
+  (declare (simple-string string)
+	   (fixnum length))
+  (let* ((hash (%primitive sxhash-simple-substring string length))
+	 (ehash (entry-hash length hash)))
+    (declare (fixnum hash ehash))
+    (with-symbol (found symbol (package-internal-symbols package)
+			string length hash ehash)
+      (when found
+	(return-from find-symbol* (values symbol :internal))))
+    (with-symbol (found symbol (package-external-symbols package)
+			string length hash ehash)
+      (when found
+	(return-from find-symbol* (values symbol :external))))
+    (let ((head (package-tables package)))
+      (do ((prev head table)
+	   (table (cdr head) (cdr table)))
+	  ((null table) (values nil nil))
+	(with-symbol (found symbol (car table) string length hash ehash)
+	  (when found
+	    (unless (eq prev head)
+	      (shiftf (cdr prev) (cdr table) (cdr head) table))
+	    (return-from find-symbol* (values symbol :inherited))))))))
+
+;;; Find-External-Symbol  --  Internal
+;;;
+;;;    Similar to Find-Symbol, but only looks for an external symbol.
+;;; This is used for fast name-conflict checking in this file and symbol
+;;; printing in the printer.
+;;;
+(defun find-external-symbol (string package)
+  (declare (simple-string string))
+  (let* ((length (length string))
+	 (hash (%primitive sxhash-simple-string string))
+	 (ehash (entry-hash length hash)))
+    (declare (fixnum length hash))
+    (with-symbol (found symbol (package-external-symbols package)
+			string length hash ehash)
+      (values symbol found))))
+
+;;; Unintern  --  Public
+;;;
+;;;    If we are uninterning a shadowing symbol, then a name conflict can
+;;; result, otherwise just nuke the symbol.
+;;;
+(defun unintern (symbol &optional (package *package*))
+  "Makes Symbol no longer present in Package.  If Symbol was present
+  then T is returned, otherwise NIL.  If Package is Symbol's home
+  package, then it is made uninterned."
+  (let* ((package (package-or-lose package))
+	 (name (symbol-name symbol))
+	 (shadowing-symbols (package-shadowing-symbols package)))
+    (declare (list shadowing-symbols) (simple-string name))
+    ;;
+    ;; If a name conflict is revealed, give use a chance to shadowing-import
+    ;; one of the accessible symbols.
+    (when (member symbol shadowing-symbols)
+      (let ((cset ()))
+	(dolist (p (package-use-list package))
+	  (multiple-value-bind (s w) (find-external-symbol name p)
+	    (when w (pushnew s cset))))
+	(when (cdr cset)
+	  (loop
+	   (cerror
+	    "prompt for a symbol to shadowing-import."
+	    "Uninterning symbol ~S causes name conflict among these symbols:~%~S"
+	    symbol cset)
+	   (write-string "Symbol to shadowing-import: " *query-io*)
+	   (let ((sym (read *query-io*)))
+	     (cond
+	      ((not (symbolp sym))
+	       (format *query-io* "~S is not a symbol."))
+	      ((not (member sym cset))
+	       (format *query-io* "~S is not one of the conflicting symbols."))
+	      (t
+	       (shadowing-import sym package)
+	       (return-from unintern t)))))))
+      (setf (package-shadowing-symbols package)
+	    (delete symbol shadowing-symbols)))
+
+    (multiple-value-bind (s w) (find-symbol name package)
+      (declare (ignore s))
+      (cond ((or (eq w :internal) (eq w :external))
+	     (nuke-symbol (if (eq w :internal)
+			      (package-internal-symbols package)
+			      (package-external-symbols package))
+			  name)
+	     (if (eq (symbol-package symbol) package)
+		 (%primitive set-package symbol nil))
+	     t)
+	    (t nil)))))
+
+;;; Symbol-Listify  --  Internal
+;;;
+;;;    Take a symbol-or-list-of-symbols and return a list, checking types.
+;;;
+(defun symbol-listify (thing)
+  (cond ((listp thing)
+	 (dolist (s thing)
+	   (unless (symbolp s) (error "~S is not a symbol." s)))
+	 thing)
+	((symbolp thing) (list thing))
+	(t
+	 (error "~S is neither a symbol nor a list of symbols." thing))))
+
+;;; Moby-Unintern  --  Internal
+;;;
+;;;    Like Unintern, but if symbol is inherited chases down the
+;;; package it is inherited from and uninterns it there.  Used
+;;; for name-conflict resolution.  Shadowing symbols are not
+;;; uninterned since they do not cause conflicts.
+;;;
+(defun moby-unintern (symbol package)
+  (unless (member symbol (package-shadowing-symbols package))
+    (or (unintern symbol package)
+	(let ((name (symbol-name symbol)))
+	  (multiple-value-bind (s w) (find-symbol name package)
+	    (declare (ignore s))
+	    (when (eq w :inherited)
+	      (dolist (q (package-use-list package))
+		(multiple-value-bind (u x) (find-external-symbol name q)
+		  (declare (ignore u))
+		  (when x
+		    (unintern symbol q)
+		    (return t))))))))))
+
+;;; Export  --  Public
+;;;
+;;;    Do more stuff.
+;;;
+(defun export (symbols &optional (package *package*))
+  "Exports Symbols from Package, checking that no name conflicts result."
+  (let ((package (package-or-lose package))
+	(syms ()))
+    ;;
+    ;; Punt any symbols that are already external.
+    (dolist (sym (symbol-listify symbols))
+      (multiple-value-bind (s w)
+			   (find-external-symbol (symbol-name sym) package)
+	(declare (ignore s))
+	(unless (or w (member sym syms)) (push sym syms))))
+    ;;
+    ;; Find symbols and packages with conflicts.
+    (let ((used-by (package-used-by-list package))
+	  (cpackages ())
+	  (cset ()))
+      (dolist (sym syms)
+	(let ((name (symbol-name sym)))
+	  (dolist (p used-by)
+	    (multiple-value-bind (s w) (find-symbol name p)
+	      (when (and w (not (eq s sym))
+			 (not (member s (package-shadowing-symbols p))))
+		(pushnew sym cset)
+		(pushnew p cpackages))))))
+      (when cset
+	(restart-case
+	    (error "Exporting these symbols from the ~A package:~%~S~%~
+		    results in name conflicts with these packages:~%~{~A ~}"
+		   (package-name package) cset (mapcar #'package-name cpackages))
+	  (unintern-conflicting-symbols ()
+	   :report "Unintern conflicting symbols."
+	   (dolist (p cpackages)
+	     (dolist (sym cset)
+	       (moby-unintern sym p))))
+	  (skip-exporting-these-symbols ()
+	   :report "Skip exporting conflicting symbols."
+	   (setq syms (nset-difference syms cset))))))
+    ;;
+    ;; Check that all symbols are accessible.  If not, ask to import them.
+    (let ((missing ())
+	  (imports ()))
+      (dolist (sym syms)
+	(multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
+	  (cond ((not (and w (eq s sym))) (push sym missing))
+		((eq w :inherited) (push sym imports)))))
+      (when missing
+	(cerror "Import these symbols into the ~A package."
+		"These symbols are not accessible in the ~A package:~%~S"
+		(package-name package) missing)
+	(import missing package))
+      (import imports package))
+    ;;
+    ;; And now, three pages later, we export the suckers.
+    (let ((internal (package-internal-symbols package))
+	  (external (package-external-symbols package)))
+      (dolist (sym syms)
+	(nuke-symbol internal (symbol-name sym))
+	(add-symbol external sym)))
+    t))
+
+;;; Unexport  --  Public
+;;;
+;;;    Check that all symbols are accessible, then move from external to
+;;; internal.
+;;;
+(defun unexport (symbols &optional (package *package*))
+  "Makes Symbols no longer exported from Package."
+  (let ((package (package-or-lose package))
+	(syms ()))
+    (dolist (sym (symbol-listify symbols))
+      (multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
+	(cond ((or (not w) (not (eq s sym)))
+	       (error "~S is not accessible in the ~A package."
+		      sym (package-name package)))
+	      ((eq w :external) (pushnew sym syms)))))
+
+    (let ((internal (package-internal-symbols package))
+	  (external (package-external-symbols package)))
+      (dolist (sym syms)
+	(add-symbol internal sym)
+	(nuke-symbol external (symbol-name sym))))
+    t))
+
+;;; Import  --  Public
+;;;
+;;;    Check for name conflic caused by the import and let the user 
+;;; shadowing-import if there is.
+;;;
+(defun import (symbols &optional (package *package*))
+  "Make Symbols accessible as internal symbols in Package.  If a symbol
+  is already accessible then it has no effect.  If a name conflict
+  would result from the importation, then a correctable error is signalled."
+  (let ((package (package-or-lose package))
+	(symbols (symbol-listify symbols))
+	(syms ())
+	(cset ()))
+    (dolist (sym symbols)
+      (multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
+	(cond ((not w)
+	       (let ((found (member sym syms :test #'string=)))
+		 (if found
+		     (when (not (eq (car found) sym))
+		       (push sym cset))
+		     (push sym syms))))
+	      ((not (eq s sym)) (push sym cset))
+	      ((eq w :inherited) (push sym syms)))))
+    (when cset
+      (cerror
+       "Import these symbols with Shadowing-Import."
+       "Importing these symbols into the ~A package causes a name conflict:~%~S"
+       (package-name package) cset))
+    ;;
+    ;; Add the new symbols to the internal hashtable.
+    (let ((internal (package-internal-symbols package)))
+      (dolist (sym syms)
+	(add-symbol internal sym)))
+    ;;
+    ;; If any of the symbols are uninterned, make them be owned by Package.
+    (dolist (sym symbols)
+      (unless (symbol-package sym) (%primitive set-package sym package)))
+    (shadowing-import cset package)))
+
+;;; Shadowing-Import  --  Public
+;;;
+;;;    If a conflicting symbol is present, unintern it, otherwise just
+;;; stick the symbol in.
+;;;
+(defun shadowing-import (symbols &optional (package *package*))
+  "Import Symbols into package, disregarding any name conflict.  If
+  a symbol of the same name is present, then it is uninterned.
+  The symbols are added to the Package-Shadowing-Symbols."
+  (let* ((package (package-or-lose package))
+	 (internal (package-internal-symbols package)))
+    (dolist (sym (symbol-listify symbols))
+      (multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
+	(unless (and w (not (eq w :inherited)) (eq s sym))
+	  (when (or (eq w :internal) (eq w :external))
+	    ;;
+	    ;; If it was shadowed, we don't want Unintern to flame out...
+	    (setf (package-shadowing-symbols package)
+		  (delete s (the list (package-shadowing-symbols package))))
+	    (unintern s package))
+	  (add-symbol internal sym))
+	(pushnew sym (package-shadowing-symbols package)))))
+  t)
+
+
+;;; Shadow  --  Public
+;;;
+;;;
+(defun shadow (symbols &optional (package *package*))
+  "Make an internal symbol in Package with the same name as each of the
+  specified symbols, adding the new symbols to the Package-Shadowing-Symbols.
+  If a symbol with the given name is already present in Package, then
+  the existing symbol is placed in the shadowing symbols list if it is
+  not already present."
+  (let* ((package (package-or-lose package))
+	 (internal (package-internal-symbols package)))
+    (dolist (sym (symbol-listify symbols))
+      (let ((name (symbol-name sym)))
+	(multiple-value-bind (s w) (find-symbol name package)
+	  (when (or (not w) (eq w :inherited))
+	    (setq s (%primitive alloc-symbol name))
+	    (%primitive set-package s package)
+	    (add-symbol internal s))
+	  (pushnew s (package-shadowing-symbols package))))))
+  t)
+
+;;; Use-Package  --  Public
+;;;
+;;;    Do stuff to use a package, with all kinds of fun name-conflict
+;;; checking.
+;;;
+(defun use-package (packages-to-use &optional (package *package*))
+  "Add all the Package-To-Use to the use list for Package so that
+  the external symbols of the used packages are accessible as internal
+  symbols in Package."
+  (let ((packages (package-listify packages-to-use))
+	(package (package-or-lose package)))
+    ;;
+    ;; Loop over each package, use'ing one at a time...
+    (dolist (pkg packages)
+      (unless (member pkg (package-use-list package))
+	(let ((cset ())
+	      (shadowing-symbols (package-shadowing-symbols package))
+	      (use-list (package-use-list package)))
+	  ;;
+	  ;;   If the number of symbols already accessible is less than the
+	  ;; number to be inherited then it is faster to run the test the
+	  ;; other way.  This is particularly valuable in the case of
+	  ;; a new package use'ing Lisp.
+	  (cond
+	   ((< (+ (internal-symbol-count package)
+		  (external-symbol-count package)
+		  (let ((res 0))
+		    (dolist (p use-list res)
+		      (incf res (external-symbol-count p)))))
+	       (external-symbol-count pkg))
+	    (do-symbols (sym package)
+	      (multiple-value-bind (s w)
+				   (find-external-symbol (symbol-name sym) pkg)
+		(when (and w (not (eq s sym))
+			   (not (member sym shadowing-symbols)))
+		  (push sym cset))))
+	    (dolist (p use-list)
+	      (do-external-symbols (sym p)
+		(multiple-value-bind (s w)
+				     (find-external-symbol (symbol-name sym)
+							   pkg)
+		  (when (and w (not (eq s sym))
+			     (not (member (find-symbol (symbol-name sym)
+						       package)
+					  shadowing-symbols)))
+		    (push sym cset))))))
+	   (t
+	    (do-external-symbols (sym pkg)
+	      (multiple-value-bind (s w)
+				   (find-symbol (symbol-name sym) package)
+		(when (and w (not (eq s sym))
+			   (not (member s shadowing-symbols)))
+		  (push s cset))))))
+	  
+	  (when cset
+	    (cerror
+	     "unintern the conflicting symbols in the ~2*~A package."
+	     "Use'ing package ~A results in name conflicts for these symbols:~%~S"
+	     (package-name pkg) cset (package-name package))
+	    (dolist (s cset) (moby-unintern s package))))
+
+	(push pkg (package-use-list package))
+	(push (package-external-symbols pkg) (cdr (package-tables package)))
+	(push package (package-used-by-list pkg)))))
+  t)
+
+;;; Unuse-Package  --  Public
+;;;
+;;;
+(defun unuse-package (packages-to-unuse &optional (package *package*))
+  "Remove Packages-To-Unuse from the use list for Package."
+  (let ((package (package-or-lose package)))
+    (dolist (p (package-listify packages-to-unuse))
+      (setf (package-use-list package)
+	    (delete p (the list (package-use-list package))))
+      (setf (package-tables package)
+	    (delete (package-external-symbols p)
+		    (the list (package-tables package))))
+      (setf (package-used-by-list p)
+	    (delete package (the list (package-used-by-list p)))))
+    t))
+
+;;; Find-All-Symbols --  Public
+;;;
+;;;
+(defun find-all-symbols (string-or-symbol)
+  "Return a list of all symbols in the system having the specified name."
+  (let ((string (string string-or-symbol))
+	(res ()))
+    (maphash #'(lambda (k v)
+		 (declare (ignore k))
+		 (multiple-value-bind (s w) (find-symbol string v)
+		   (when w (pushnew s res))))
+	     *package-names*)
+    res))
+
+
+;;; Apropos and Apropos-List.
+
+(defun briefly-describe-symbol (symbol)
+  (fresh-line)
+  (prin1 symbol)
+  (when (boundp symbol)
+    (write-string ", value: ")
+    (prin1 (symbol-value symbol)))
+  (if (fboundp symbol)
+      (write-string " (defined)")))
+
+(defun apropos-search (symbol string)
+  (declare (simple-string string))
+  (do* ((index 0 (1+ index))
+	(name (symbol-name symbol))
+	(length (length string))
+	(terminus (- (length name) length)))
+       ((> index terminus)
+	nil)
+    (declare (simple-string name)
+	     (fixnum index terminus length))
+    (if (do ((jndex 0 (1+ jndex))
+	     (kndex index (1+ kndex)))
+	    ((= jndex length)
+	     t)
+	  (declare (fixnum jndex kndex))
+	  (let ((char (schar name kndex)))
+	    (unless (char= (schar string jndex) (char-upcase char))
+	      (return nil))))
+	(return t))))
+
+(defun apropos (string &optional package external-only)
+  "Briefly describe all symbols which contain the specified String.
+  If Package is supplied then only describe symbols present in
+  that package.  If External-Only is true then only describe
+  external symbols in the specified package."
+  (let ((string (string-upcase string)))
+    (declare (simple-string string))
+    (if (null package)
+	(do-all-symbols (symbol)
+	   (if (apropos-search symbol string)
+	       (briefly-describe-symbol symbol)))
+	(let ((package (package-or-lose package)))
+	  (if external-only
+	      (do-external-symbols (symbol package)
+		(if (apropos-search symbol string)
+		    (briefly-describe-symbol symbol)))
+	      (do-symbols (symbol package)
+		(if (apropos-search symbol string)
+		    (briefly-describe-symbol symbol))))))
+    (values)))
+
+(defun apropos-list (string &optional package external-only)
+  "Identical to Apropos, except that it returns a list of the symbols
+  found instead of describing them."
+  (let ((string (string-upcase string))
+	(list '()))
+    (declare (simple-string string))
+    (if (null package)
+	(do-all-symbols (symbol)
+	   (if (apropos-search symbol string)
+	       (push symbol list)))
+	(let ((package (package-or-lose package)))
+	  (if external-only
+	      (do-external-symbols (symbol package)
+		(if (apropos-search symbol string)
+		    (push symbol list)))
+	      (do-symbols (symbol package)
+		(if (apropos-search symbol string)
+		    (push symbol list))))))
+    list))
+
+;;; Initialization.
+
+;;; The cold loader (Genesis) makes the data structure in *initial-symbols*.
+;;; We grovel over it, making the specified packages and interning the
+;;; symbols.  For a description of the format of *initial-symbols* see
+;;; the Genesis source.
+
+(defvar *initial-symbols*)
+
+(defun package-init ()
+  (let ((*in-package-init* t))
+    (dolist (spec *initial-symbols*)
+      (let* ((pkg (apply #'make-package (first spec)))
+	     (internal (package-internal-symbols pkg))
+	     (external (package-external-symbols pkg)))
+	;;
+	;; Put internal symbols in the internal hashtable and set package.
+	(dolist (symbol (second spec))
+	  (add-symbol internal symbol)
+	  (%primitive set-package symbol pkg))
+	;;
+	;; External symbols same, only go in external table.
+	(dolist (symbol (third spec))
+	  (add-symbol external symbol)
+	  (%primitive set-package symbol pkg))
+	;;
+	;; Don't set package for Imported symbols.
+	(dolist (symbol (fourth spec))
+	  (add-symbol internal symbol))
+	(dolist (symbol (fifth spec))
+	  (add-symbol external symbol))
+	;;
+	;; Put shadowing symbols in the shadowing symbols list.
+	(setf (package-shadowing-symbols pkg) (sixth spec))))
+
+    (makunbound '*initial-symbols*) ; So it gets GC'ed.
+    
+    ;; Make some other packages that should be around in the cold load:
+    (in-package "SYSTEM")
+    (in-package "USER")
+    (in-package "DEBUG")
+
+    ;; Now do the *deferred-use-packages*:
+    (dolist (args *deferred-use-packages*)
+      (apply #'use-package args))
+    (makunbound '*deferred-use-packages*)
+
+    (setq *lisp-package* (find-package "LISP"))
+    (setq *keyword-package* (find-package "KEYWORD"))
+
+    ;; For the kernel core image wizards, set the package to *Lisp-Package*.
+    (setq *package* *lisp-package*)))
diff --git a/code/pred.lisp b/code/pred.lisp
new file mode 100644
index 000000000..a137b2624
--- /dev/null
+++ b/code/pred.lisp
@@ -0,0 +1,619 @@
+;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; Predicate functions for Spice Lisp.
+;;; The type predicates are implementation-specific.  A different version
+;;;   of this file will be required for implementations with different
+;;;   data representations.
+;;;
+;;; Written and currently maintained by Scott Fahlman.
+;;; Based on an earlier version by Joe Ginder.
+;;;
+(in-package 'lisp)
+(export '(typep null symbolp atom consp listp numberp integerp rationalp
+	  floatp complexp characterp stringp bit-vector-p vectorp
+	  simple-vector-p simple-string-p simple-bit-vector-p arrayp
+	  functionp compiled-function-p commonp eq eql equal equalp not
+	  type-of
+	  ;; Names of types...
+	  array atom bignum bit bit-vector character common
+	  compiled-function complex cons double-float
+	  fixnum float function integer keyword list long-float nil
+	  null number ratio rational sequence short-float signed-byte
+	  simple-array simple-bit-vector simple-string simple-vector
+	  single-float standard-char string string-char symbol t
+	  unsigned-byte vector structure satisfies))
+
+(in-package "EXTENSIONS")
+(export '(structurep fixnump bignump bitp ratiop))
+(in-package "LISP")
+
+
+;;; Data type predicates.
+
+;;; Translation from type keywords to specific predicates.  Assumes that
+;;; the following are named structures and need no special type hackery:
+;;; PATHNAME, STREAM, READTABLE, PACKAGE, HASHTABLE, RANDOM-STATE.
+
+(defconstant type-pred-alist
+  '((keyword . keywordp)
+    (common . commonp)
+    (null . null)
+    (cons . consp)
+    (list . listp)
+    (symbol . symbolp)
+    (array . arrayp)
+    (vector . vectorp)
+    (bit-vector . bit-vector-p)
+    (string . stringp)
+    (sequence . sequencep)
+    (simple-array . simple-array-p)
+    (simple-vector . simple-vector-p)
+    (simple-string . simple-string-p)
+    (simple-bit-vector . simple-bit-vector-p)
+    (function . functionp)
+    (compiled-function . compiled-function-p)
+    (character . characterp)
+    (number . numberp)
+    (rational . rationalp)
+    (float . floatp)
+    (string-char . %string-char-p)
+    (integer . integerp)
+    (ratio . ratiop)
+    (short-float . short-float-p)
+    (standard-char . %standard-char-p)
+    (fixnum . fixnump)
+    (complex . complexp)
+;    (single-float . single-float-p)
+    (single-float . short-float-p)
+    (bignum . bignump)
+    (double-float . double-float-p)
+    (bit . bitp)
+    (long-float . long-float-p)
+    (structure . structurep)
+    (atom . atom)))
+
+
+;;;; TYPE-OF and auxiliary functions.
+
+(defun type-of (object)
+  "Returns the type of OBJECT as a type-specifier.
+  Since objects may be of more than one type, the choice is somewhat
+  arbitrary and may be implementation-dependent."
+  (if (null object) 'symbol
+      (case (%primitive get-type object)
+	(#.%+-fixnum-type 'fixnum)
+	(#.%bignum-type 'bignum)
+	(#.%ratio-type 'ratio)
+	((#.%short-+-float-type #.%short---float-type) 'short-float)
+	(#.%long-float-type 'long-float)
+	(#.%complex-type 'complex)
+	(#.%string-type `(simple-string ,(%primitive vector-length object)))
+	(#.%bit-vector-type
+	 `(simple-bit-vector ,(%primitive vector-length object)))
+	(#.%integer-vector-type (type-of-i-vector object))
+	(#.%general-vector-type (type-of-g-vector object))
+	(#.%array-type (type-of-array object))
+	(#.%function-type 'function)
+	(#.%symbol-type 'symbol)
+	(#.%list-type 'cons)
+	(#.%string-char-type 'string-char)
+	(#.%bitsy-char-type 'character)
+	(#.%--fixnum-type 'fixnum)
+	(t 'random))))
+
+;;; %String-Char-P is called by typep when the type specification
+;;; is string-char.  The CL string-char-p does not do the right thing.
+(defun %string-char-p (x)
+  (and (characterp x)
+       (< (the fixnum (char-int x)) char-code-limit)))
+
+;;; Create the list-style description of a G-vector.
+
+(defun type-of-g-vector (object)
+  (cond ((structurep object) (svref object 0))
+	(t `(simple-vector ,(%primitive vector-length object)))))
+
+;;; I-Vector-Element-Type  --  Internal
+;;;
+;;;    Return a type specifier for the element type of an I-Vector.
+;;;
+(defun i-vector-element-type (object)
+  (let ((ac (%primitive get-vector-access-code object)))
+    (if (< 0 ac 6)
+	(svref '#((mod 2) (mod 4) (mod 16) (mod 256) (mod 65536)
+		  (mod 4294967296))
+	       ac)
+	(error "Invalid I-Vector access code: ~S" ac))))
+	
+;;; Create the list-style description of an I-vector.
+	
+(defun type-of-i-vector (object)
+  `(simple-array ,(i-vector-element-type object)
+		 ,(%primitive vector-length object)))
+
+
+;;; Create the list-style description of an array.
+
+(defun type-of-array (object)
+  (with-array-data ((data-vector object) (start) (end))
+    (declare (ignore start end))
+    (let ((rank (- (the fixnum (%primitive header-length object))
+		   %array-first-dim-slot))
+	  (length (%primitive header-ref object %array-length-slot)))
+      (declare (fixnum rank length))
+      (if (= rank 1)
+	  (typecase data-vector
+	    (simple-bit-vector `(bit-vector ,length))
+	    (simple-string `(string ,length))
+	    (simple-vector `(vector t ,length))
+	    (t `(vector ,(i-vector-element-type data-vector) ,length)))
+	  `(array
+	    ,(typecase data-vector
+	       (simple-bit-vector '(mod 2))
+	       (simple-string 'string-char)
+	       (simple-vector 't)
+	       (t (i-vector-element-type data-vector)))
+	    ,(array-dimensions object))))))
+
+;;;; TYPEP and auxiliary functions.
+
+(defun %typep (object type)
+  (let ((type (type-expand type))
+	temp)
+    (cond ((symbolp type)
+	   (cond ((or (eq type t) (eq type '*)) t)
+		 ((eq type 'nil) nil)
+		 ((setq temp (assq type type-pred-alist))
+		  (funcall (cdr temp) object))
+		 (t (structure-typep object type))))
+	  ((listp type) 
+	   ;; This handles list-style type specifiers.
+	   (case (car type)
+	     (vector (and (vectorp object)
+			  (vector-eltype object (cadr type))
+			  (test-length object (caddr type))))
+	     (simple-vector (and (simple-vector-p object)
+				 (test-length object (cadr type))))
+	     (string (and (stringp object)
+			  (test-length object (cadr type))))
+	     (simple-string (and (simple-string-p object)
+				 (test-length object (cadr type))))
+	     (bit-vector (and (bit-vector-p object)
+			      (test-length object (cadr type))))
+	     (simple-bit-vector (and (simple-bit-vector-p object)
+				     (test-length object (cadr type))))
+	     (array (array-typep object type))
+	     (simple-array (and (not (array-header-p object))
+				(array-typep object type)))
+	     (satisfies (funcall (cadr type) object))
+	     (member (member object (cdr type)))
+	     (not (not (typep object (cadr type))))
+	     (or (dolist (x (cdr type) nil)
+		   (if (typep object x) (return t))))
+	     (and (dolist (x (cdr type) t)
+		    (if (not (typep object x)) (return nil))))
+	     (integer (and (integerp object) (test-limits object type)))
+	     (rational (and (rationalp object) (test-limits object type)))
+	     (float (and (floatp object) (test-limits object type)))
+	     (short-float (and (short-float-p object)
+			       (test-limits object type)))
+	     (single-float (and (single-float-p object)
+				(test-limits object type)))
+	     (double-float (and (double-float-p object)
+				(test-limits object type)))
+	     (long-float (and (long-float-p object)
+			      (test-limits object type)))
+	     (mod (and (integerp object)
+		       (>= object 0)
+		       (< object (cadr type))))
+	     (signed-byte
+	      (and (integerp object)
+		   (let ((n (cadr type)))
+		     (or (not n) (eq n '*)
+			 (> n (integer-length object))))))
+	     (unsigned-byte
+	      (and (integerp object)
+		   (not (minusp object))
+		   (let ((n (cadr type)))
+		     (or (not n) (eq n '*)
+			 (>= n (integer-length object))))))
+	     (complex (and (numberp object)
+			   (or (not (cdr type))
+			       (typep (realpart object) (cadr type)))))
+	     (t (error "~S -- Illegal type specifier to TYPEP."  type))))
+	  (t (error "~S -- Illegal type specifier to TYPEP."  type)))))
+
+(defun typep (obj type)
+  "Returns T if OBJECT is of the specified TYPE, otherwise NIL."
+  (declare (notinline %typep))
+  (%typep obj type))
+
+
+;;; Type-Expand  --  Internal
+;;;
+;;;    Similar to Macroexpand, but expands deftypes.  We don't bother returning
+;;; a second value.
+;;;
+(defun type-expand (form)
+  (let ((def (cond ((symbolp form)
+		    (get form 'deftype-expander))
+		   ((and (consp form) (symbolp (car form)))
+		    (get (car form) 'deftype-expander))
+		   (t nil))))
+    (if def
+	(type-expand (funcall def (if (consp form) form (list form))))
+	form)))
+
+	       
+;;; Given that the object is a vector of some sort, and that we've already
+;;; verified that it matches CAR of TYPE, see if the rest of the type
+;;; specifier wins.  Mild hack: Eltype Nil means either type not supplied
+;;; or was Nil.  Any vector can hold objects of type Nil, since there aren't
+;;; any, so (vector nil) is the same as (vector *).
+;;;
+(defun vector-eltype (object eltype)
+  (let ((data (if (array-header-p object)
+		  (with-array-data ((data object) (start) (end))
+		    (declare (ignore start end))
+		    data)
+		  object))
+	(eltype (type-expand eltype)))
+    (case eltype
+      ((t) (simple-vector-p data))
+      (string-char (simple-string-p data))
+      (bit (simple-bit-vector-p data))
+      ((* nil) t)
+      (t
+       (subtypep eltype
+		 (cond ((simple-vector-p data) t)
+		       ((simple-string-p data) 'string-char)
+		       ((simple-bit-vector-p data) 'bit)
+		       (t
+			(i-vector-element-type data))))))))
+
+
+;;; Test sequence for specified length.
+
+(defun test-length (object length)
+  (or (null length)
+      (eq length '*)
+      (= length (length object))))
+
+
+;;; See if object satisfies the specifier for an array.
+
+(defun array-typep (object type)
+  (and (arrayp object)
+       (vector-eltype object (cadr type))
+       (if (cddr type)
+	   (let ((dims (third type)))
+	     (cond ((eq dims '*) t)
+		   ((numberp dims)
+		    (and (vectorp object)
+			 (= (the fixnum (length (the vector object)))
+			    (the fixnum dims))))
+		   (t
+		    (dotimes (i (array-rank object) (null dims))
+		      (when (null dims) (return nil))
+		      (let ((dim (pop dims)))
+			(unless (or (eq dim '*)
+				    (= dim (array-dimension object i)))
+			  (return nil)))))))
+	   t)))
+
+
+;;; Test whether a number falls within the specified limits.
+
+(defun test-limits (object type)
+  (let ((low (cadr type))
+	(high (caddr type)))
+    (and (cond ((null low) t)
+	       ((eq low '*) t)
+	       ((numberp low) (>= object low))
+	       ((and (consp low) (numberp (car low)))
+		(> object (car low)))
+	       (t nil))
+	 (cond ((null high) t)
+	       ((eq high '*) t)
+	       ((numberp high) (<= object high))
+	       ((and (consp high) (numberp (car high)))
+		(< object (car high)))
+	       (t nil)))))
+
+
+;;; Structure-Typep  --  Internal
+;;;
+;;; This is called by Typep if the type-specifier is a symbol and is not one of
+;;; the built-in Lisp types.  If it's a structure, see if it's that type, or if
+;;; it includes that type.
+;;;
+(defun structure-typep (object type)
+  (declare (optimize speed))
+  (let ((type (type-expand type)))
+    (if (symbolp type)
+	(case (info type kind type)
+	  ((:primitive :structure)
+	   (and (structurep object)
+		(let ((obj-name (%primitive header-ref object 0)))
+		  (or (eq obj-name type)
+		      (let ((def (info type structure-info obj-name)))
+			(not (null (memq type (c::dd-includes def)))))))))
+	  (t
+	   (error "~S is an unknown type specifier." type)))
+	(error "~S is an unknown type specifier." type))))
+
+
+;;;; Assorted mumble-P type predicates.
+
+(defun commonp (object)
+  "Returns T if object is a legal Common-Lisp type, NIL if object is any
+  sort of implementation-dependent or internal type."
+  (or (structurep object)
+      (let ((type-spec (type-of object)))
+	(if (listp type-spec) (setq type-spec (car type-spec)))
+	(when (memq type-spec
+		    '(character fixnum short-float single-float double-float
+				long-float vector string simple-vector
+				simple-string bignum ratio complex
+				compiled-function array symbol cons))
+	  T))))
+
+(defun bit-vector-p (object)
+  "Returns T if the object is a bit vector, else returns NIL."
+  (bit-vector-p object))
+
+;;; The following definitions are trivial because the compiler open-codes
+;;; all of these.
+
+(defun null (object)
+  "Returns T if the object is NIL, else returns NIL."
+  (null object))
+
+(defun not (object)
+  "Returns T if the object is NIL, else returns NIL."
+  (null object))
+
+(defun symbolp (object)
+  "Returns T if the object is a symbol, else returns NIL."
+  (symbolp object))
+
+(defun atom (object)
+  "Returns T if the object is not a cons, else returns NIL.
+  Note that (ATOM NIL) => T."
+  (atom object))
+
+(defun consp (object)
+  "Returns T if the object is a cons cell, else returns NIL.
+  Note that (CONSP NIL) => NIL."
+  (consp object))
+
+(defun listp (object)
+  "Returns T if the object is a cons cell or NIL, else returns NIL."
+  (listp object))
+
+(defun numberp (object)
+  "Returns T if the object is any kind of number."
+  (numberp object))
+
+(defun integerp (object)
+  "Returns T if the object is an integer (fixnum or bignum), else 
+  returns NIL."
+  (integerp object))
+
+(defun rationalp (object)
+  "Returns T if the object is an integer or a ratio, else returns NIL."
+  (rationalp object))
+
+(defun floatp (object)
+  "Returns T if the object is a floating-point number, else returns NIL."
+  (floatp object))
+
+(defun complexp (object)
+  "Returns T if the object is a complex number, else returns NIL."
+  (complexp object))
+
+(defun %standard-char-p (x)
+  (and (characterp x) (standard-char-p x)))
+
+(defun characterp (object)
+  "Returns T if the object is a character, else returns NIL."
+  (characterp object))
+
+(defun stringp (object)
+  "Returns T if the object is a string, else returns NIL."
+  (stringp object))
+
+(defun simple-string-p (object)
+  "Returns T if the object is a simple string, else returns NIL."
+  (simple-string-p object))
+
+(defun vectorp (object)
+  "Returns T if the object is any kind of vector, else returns NIL."
+  (vectorp object))
+
+(defun simple-array-p (object)
+  "Returns T if the object is a simple array, else returns NIL."
+  (and (arrayp object) (not (array-header-p object))))
+
+(defun simple-vector-p (object)
+  "Returns T if the object is a simple vector, else returns NIL."
+  (simple-vector-p object))
+
+(defun simple-bit-vector-p (object)
+  "Returns T if the object is a simple bit vector, else returns NIL."
+  (simple-bit-vector-p object))
+
+(defun arrayp (object)
+  "Returns T if the argument is any kind of array, else returns NIL."
+  (arrayp object))
+
+(defun functionp (object)
+  "Returns T if the object is a function, suitable for use by FUNCALL
+  or APPLY, else returns NIL."
+  (functionp object))
+
+(defun compiled-function-p (object)
+  "Returns T if the object is a compiled function object, else returns NIL."
+  (compiled-function-p object))
+
+;;; ### Dummy definition until we figure out what to really do...
+(defun clos::funcallable-instance-p (object)
+  (declare (ignore object))
+  nil)
+
+(defun sequencep (object)
+  "Returns T if object is a sequence, NIL otherwise."
+  (typep object 'sequence))
+
+
+;;; The following are not defined at user level, but are necessary for
+;;; internal use by TYPEP.
+
+(defun structurep (object)
+  (structurep object))
+
+(defun fixnump (object)
+  (fixnump object))
+
+(defun bignump (object)
+  (bignump object))
+
+(defun bitp (object)
+  (typep object 'bit))
+
+(defun short-float-p (object)
+  (typep object 'short-float))
+
+(defun single-float-p (object)
+  (typep object 'single-float))
+
+(defun double-float-p (object)
+  (typep object 'double-float))
+
+(defun long-float-p (object)
+  (typep object 'long-float))
+
+(defun ratiop (object)
+  (ratiop object))
+
+;;; Some silly internal things for tenser array hacking:
+
+(defun array-header-p (object)
+  (array-header-p object))
+
+;;;; Equality Predicates.
+
+(defun eq (x y)
+  "Returns T if X and Y are the same object, else returns NIL."
+  (eq x y))
+
+(defun eql (x y)
+  "Returns T if X and Y are EQ, or if they are numbers of the same
+  type and precisely equal value, or if they are characters and
+  are CHAR=, else returns NIL."
+  (eql x y))
+
+(defun equal (x y)
+  "Returns T if X and Y are EQL or if they are structured components
+  whose elements are EQUAL.  Strings and bit-vectors are EQUAL if they
+  are the same length and have indentical components.  Other arrays must be
+  EQ to be EQUAL."
+  (cond ((eql x y) t)
+	((consp x)
+	 (and (consp y)
+	      (equal (car x) (car y))
+	      (equal (cdr x) (cdr y))))
+	((stringp x)
+	 (and (stringp y) (string= x y)))
+	((pathnamep x)
+	 (and (pathnamep y)
+	      (do* ((i 1 (1+ i))
+		    (len (length x)))
+		   ((>= i len) t)
+		(declare (fixnum i len))
+		(let ((x-el (svref x i))
+		      (y-el (svref y i)))
+		  (if (and (simple-vector-p x-el)
+			   (simple-vector-p y-el))
+		      (let ((lx (length x-el))
+			    (ly (length y-el)))
+			(declare (fixnum lx ly))
+			(if (/= lx ly) (return nil))
+			(do ((i 0 (1+ i)))
+			    ((>= i lx))
+			  (declare (fixnum i))
+			  (if (not (equal (svref x-el i) (svref y-el i)))
+			      (return-from equal nil))))
+		      (unless (or (eql x-el y-el)
+				  (equal x-el y-el))
+			(return nil)))))))
+	((bit-vector-p x)
+	 (and (bit-vector-p y)
+	      (= (the fixnum (length x))
+		 (the fixnum (length y)))
+	      (do ((i 0 (1+ i))
+		   (length (length x)))
+		  ((= i length) t)
+		(declare (fixnum i))
+		(or (= (the fixnum (bit x i))
+		       (the fixnum (bit y i)))
+		    (return nil)))))
+	(t nil)))
+
+
+(defun equalp (x y)
+  "Just like EQUAL, but more liberal in several respects.
+  Numbers may be of different types, as long as the values are identical
+  after coercion.  Characters may differ in alphabetic case.  Vectors and
+  arrays must have identical dimensions and EQUALP elements, but may differ
+  in their type restriction."
+  (cond ((eql x y) t)
+	((characterp x) (char-equal x y))
+	((numberp x) (and (numberp y) (= x y)))
+	((consp x)
+	 (and (consp y)
+	      (equalp (car x) (car y))
+	      (equalp (cdr x) (cdr y))))
+	((vectorp x)
+	 (let ((length (length x)))
+	   (declare (fixnum length))
+	   (and (vectorp y)
+		(= length (the fixnum (length y)))
+		(dotimes (i length t)
+		  (let ((x-el (aref x i))
+			(y-el (aref y i)))
+		    (unless (or (eql x-el y-el)
+				(equalp x-el y-el))
+		      (return nil)))))))
+	((arrayp x)
+	 (let ((rank (array-rank x))
+	       (len (%primitive header-ref x %array-length-slot)))
+	   (declare (fixnum rank len))
+	   (and (arrayp y)
+		(= (the fixnum (array-rank y)) rank)
+		(dotimes (i rank t)
+		  (unless (= (the fixnum (array-dimension x i))
+			     (the fixnum (array-dimension y i)))
+		    (return nil)))
+		(with-array-data ((x-vec x) (x-start) (end))
+		  (declare (ignore end))
+		  (with-array-data ((y-vec y) (y-start) (end))
+		    (declare (ignore end))
+		    (do ((i x-start (1+ i))
+			 (j y-start (1+ j))
+			 (count len (1- count)))
+			((zerop count) t)
+		      (declare (fixnum i j count))
+		      (let ((x-el (aref x-vec i))
+			    (y-el (aref y-vec j)))
+			(unless (or (eql x-el y-el)
+				    (equalp x-el y-el))
+			  (return nil)))))))))
+	(t nil)))
diff --git a/code/print.lisp b/code/print.lisp
new file mode 100644
index 000000000..6dd29226d
--- /dev/null
+++ b/code/print.lisp
@@ -0,0 +1,1267 @@
+;;; -*- Log: code.log; Package: Lisp -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; Spice Lisp printer.
+;;; Written by Neal Feinberg, Spice Lisp Group.
+;;; Currently maintained by Skef Wholey.
+;;; 
+(in-package 'lisp)
+(export '(*print-escape* *print-pretty* *print-circle* *print-base* *print-radix*
+	  *print-case* *print-level* *print-length* *print-array* *print-gensym*
+	  write prin1 print princ write-to-string prin1-to-string
+	  princ-to-string))
+
+(defvar *print-escape* T
+  "Flag which indicates that slashification is on.  See the manual")
+(defvar *print-pretty* T
+  "Flag which indicates that pretty printing is to be used")
+(defvar *print-base* 10.
+  "The output base for integers and rationals.")
+(defvar *print-radix* ()
+  "This flag requests to verify base when printing rationals.")
+(defvar *print-level* ()
+  "How many levels deep to print.  Unlimited if null.")
+(defvar *print-length* ()
+  "How many elements to print on each level.  Unlimited if null.")
+(defvar *print-circle* ()
+  "Whether to worry about circular list structures. See the manual.")
+(defvar *print-case* ':upcase
+  "What kind of case the printer should use by default")
+(defvar previous-case ()
+  "What the previous case selection the printer was set to.")
+(defvar *print-array* T
+  "Whether the array should print it's guts out")
+(defvar *print-gensym* T
+  "If true, symbols with no home package are printed with a #: prefix.
+  If false, no prefix is printed.")
+
+
+;; This variable contains the current definition of one of three symbol
+;; printers.  This variable is set by the various print function (PRINT, 
+;; PRINC, and PRIN1).
+
+(defvar internal-symbol-output-function ())
+
+(defvar print-string-stream (make-string-output-stream)
+  "Holds the string stream for the x-TO-STRING functions.")
+
+(defvar *in-stringify-object* ()
+  "T if in the middle of stringify-object.")
+
+;; Imported from reader
+(proclaim '(special *read-default-float-format*))
+
+;; From the package system
+(proclaim '(special *package* *keyword-package*))
+
+;; This macro returns code which maps over a string, binding VARIABLE to each
+;; successive character in the string INIT-FORM, and executing BODY with
+;; the variable so bound.  This function used to be part of Common Lisp, but
+;; is no more.  It lives on in the printer, though.
+
+(defmacro dostring (varform &rest body)
+  ;; Varform looks like (variable init-form terminate-form)
+  (let ((variable (car varform))
+	(init-form (cadr varform))
+	(terminate-form (caddr varform)))
+    `(do ((,variable)
+	  (index 0 (1+ index))
+	  (terminate-index (length (the string ,init-form))))
+	 ((= index terminate-index)
+	  ,terminate-form)
+       (declare (fixnum index terminate-index))
+       (setq ,variable (char ,init-form index))
+       ,@body)))
+
+
+(proclaim '(inline setup-printer-state))
+
+;; This function sets the internal global symbol 
+;; "internal-symbol-output-function" to the right function depending on 
+;; the value of *print-case*.  See the manual for details.  The print buffer
+;; stream is also reset.
+
+(defun setup-printer-state ()
+  (unless (eq *print-case* previous-case)
+    (setq previous-case *print-case*)
+    (setq internal-symbol-output-function
+	  (case *print-case*
+	    (:upcase #'output-uppercase-symbol)
+	    (:downcase #'output-lowercase-symbol)
+	    (:capitalize #'output-capitalize-symbol)
+	    (T (let ((bad-case *print-case*))
+		 (setq *print-case* :upcase)
+		 (Error "Invalid *print-case* value: ~s" bad-case))))))))
+
+;;; Toplevel print functions
+
+(defun write (object &key
+		     ((:stream  stream)		     *standard-output*)
+		     ((:escape  *print-escape*)      *print-escape*)
+		     ((:radix   *print-radix*)       *print-radix*)
+		     ((:base    *print-base*)        *print-base*)
+		     ((:circle  *print-circle*)      *print-circle*)
+		     ((:pretty  *print-pretty*)      *print-pretty*)
+		     ((:level   *print-level*)       *print-level*)
+		     ((:length  *print-length*)      *print-length*)
+		     ((:case    *print-case*)        *print-case*)
+		     ((:array   *print-array*)       *print-array*)
+		     ((:gensym  *print-gensym*)      *print-gensym*))
+  "Outputs OBJECT to the specified stream, defaulting to *standard-output*"
+  (setup-printer-state)
+  (let ((*standard-output* (if (or (eq stream 't)
+				   (and (synonym-stream-p stream)
+					(eq (synonym-stream-symbol stream)
+					    '*standard-output*)))
+			       *standard-output*
+			       stream)))
+    (if *print-pretty*
+	(output-pretty-object object)
+	(output-object object)))
+  object)
+
+(defun prin1 (object &optional stream)
+  "Outputs a mostly READable printed representation of OBJECT on the specified
+  stream."
+  (let ((*standard-output* (if (or (null stream)
+				   (eq stream 't)
+				   (and (synonym-stream-p stream)
+					(eq (synonym-stream-symbol stream)
+					    '*standard-output*)))
+			       *standard-output*
+			       stream)))
+    (setup-printer-state)
+    (let ((*print-escape* T))
+      (if *print-pretty*
+	  (output-pretty-object object)
+	  (output-object object)))
+    object))
+
+(defun princ (object &optional stream)
+  "Outputs an asthetic but not READable printed representation of OBJECT on the
+  specified stream."
+  (let ((*standard-output* (if (or (null stream)
+				   (eq stream 't)
+				   (and (synonym-stream-p stream)
+					(eq (synonym-stream-symbol stream)
+					    '*standard-output*)))
+			       *standard-output*
+			       stream)))
+    (setup-printer-state)
+    (let ((*print-escape* NIL))
+      (if *print-pretty*
+	  (output-pretty-object object)
+	  (output-object object)))
+    object))
+
+(defun print (object &optional stream)
+  "Outputs a terpri, the mostly READable printed represenation of OBJECT, and 
+  space to the stream."
+  (let ((*standard-output* (if (or (null stream)
+				   (eq stream 't)
+				   (and (synonym-stream-p stream)
+					(eq (synonym-stream-symbol stream)
+					    '*standard-output*)))
+			       *standard-output*
+			       stream)))
+    (terpri)
+    (prin1 object)
+    (write-char #\space)
+    object))
+
+
+;; STRINGIFY-OBJECT is an internal printer function produces the printed
+;; representation of an object as a string.  It is called by various x-TO-STRING
+;; functions below.
+
+(defun stringify-object (object &optional (*print-escape* ()))
+  (let ((*standard-output* (if *in-stringify-object*
+			       (make-string-output-stream)
+			       print-string-stream))
+	(*in-stringify-object* T))
+    (setup-printer-state)
+    (if *print-pretty*
+	(output-pretty-object object)
+	(output-object object 0))
+    (get-output-stream-string *standard-output*)))
+
+;;; Top-level x-TO-STRING functions.  These functions all take an object
+;;; and return that object's printed representation as a string. 
+
+(defun write-to-string (object &key
+		     ((:escape  *print-escape*)      *print-escape*)
+		     ((:radix   *print-radix*)       *print-radix*)
+		     ((:base    *print-base*)        *print-base*)
+		     ((:circle  *print-circle*)      *print-circle*)
+		     ((:pretty  *print-pretty*)      *print-pretty*)
+		     ((:level   *print-level*)       *print-level*)
+		     ((:length  *print-length*)      *print-length*)
+		     ((:case    *print-case*)        *print-case*)
+		     ((:array   *print-array*)       *print-array*)
+		     ((:gensym  *print-gensym*)      *print-gensym*))
+  "Returns the printed representation of OBJECT as a string."
+  (stringify-object object *print-escape*))
+
+(defun prin1-to-string (object)
+  "Returns the printed representation of OBJECT as a string with 
+   slashification on."
+  (stringify-object object t))
+
+(defun princ-to-string (object)
+  "Returns the printed representation of OBJECT as a string with
+  slashification off."
+  (stringify-object object nil))
+
+
+;;; Central print functions.  
+
+;;; OUTPUT-OBJECT takes an object and outputs its printed representation to
+;;; *STANDARD-OUTPUT*, which is typically bound the the internal print stream.
+;;; This function is called recursively by the sub-functions which know how
+;;; to print structures which can contain other lisp objects.
+
+(defun output-object (object &optional (currlevel 0))
+  "Outputs a string which is the printed representation of the given object."
+  ;; First check and make sure we aren't too deep
+  (declare (fixnum currlevel))
+  (if (and (not (null *print-level*))
+	   (not (= *print-level* 0))
+	   (>= currlevel (the fixnum *print-level*)))
+      (write-char #\#)
+      (typecase object
+	    (symbol
+	     (if *print-escape*
+		 (output-symbol object)
+		 (case *print-case*
+		   (:upcase (write-string (symbol-name object)))
+		   (:downcase
+		    (let ((name (symbol-name object)))
+		      (declare (simple-string name))
+		      (dotimes (i (length name))
+			(write-char (char-downcase (char name i))))))
+		   (:capitalize
+		    (write-string (string-capitalize (symbol-name object)))))))
+	    ;; If a list, go through element by element, being careful
+	    ;; about not running over the printlength
+	    (list
+	     (if (clos::funcallable-instance-p object)
+		 (clos::print-object object *standard-output* (1+ currlevel))
+		 (output-list object (1+ currlevel))))
+	    (string
+	     (if *print-escape*
+		 (quote-string object)
+		 (write-string object)))
+	    (integer
+	     (output-integer object))
+	    (float
+	     (output-float object))
+	    (ratio
+	     (output-ratio object))
+	    (complex
+	     (output-complex object))
+	    (structure
+	     (output-structure object currlevel))
+	    (character
+	     (output-character object))
+	    (vector
+	     (output-vector object))
+	    (array
+	     (output-array object (1+ currlevel))) 
+	    (t (output-random object))))
+  'T)
+
+
+;;; Symbol Printing Subfunctions
+
+(defun output-symbol (object)
+  (let ((package (symbol-package object))
+	(name (symbol-name object)))
+    (cond
+     ;; If the symbol's home package is the current one, then a
+     ;; prefix is never necessary.
+     ((eq package *package*))
+     ;; If the symbol is in the keyword package, output a colon.
+     ((eq package *keyword-package*)
+      (write-char #\:))
+     ;; Uninterned symbols print with a leading #:.
+     ((null package)
+      (when *print-gensym* (write-string "#:")))
+     (t
+      (let ((found (car (memq package (package-use-list *package*)))))
+	(multiple-value-bind (symbol externalp)
+			     (find-external-symbol name package)
+	  ;;
+	  ;;  If the symbol's home package is in our use list and is an external
+	  ;; symbol there, then it needs no qualification.
+	  (unless (and found externalp (eq symbol object))
+	    (multiple-value-bind (symbol accessible)
+				 (find-symbol name *package*)
+	      ;;
+	      ;;    If we can find the symbol by looking it up, it
+	      ;; need not be qualified.  This can happen if the symbol
+	      ;; has been inherited from a package other than its home
+	      ;; package.
+	      (unless (and accessible (eq symbol object))
+		(funcall internal-symbol-output-function (package-name package))
+		(if externalp
+		    (write-char #\:)
+		    (write-string "::")))))))))
+    (funcall internal-symbol-output-function name)))
+
+;;;; Escaping symbols:
+;;;
+;;;    When we print symbols we have to figure out if they need to
+;;; be printed with escape characters.  This isn't a whole lot easier
+;;; than reading symbols in the first place.
+;;;
+
+;;; For each character, the value of the corresponding element is a fixnum
+;;; with bits set corresponding to attributes that the character has.
+;;; This is also used by the character printer.
+;;;
+(defvar character-attributes
+  (make-array char-code-limit :element-type '(unsigned-byte 8)
+	      :initial-element 0))
+
+(eval-when (compile load eval)
+
+;;; Constants which are a bit-mask for each interesting character attribute.
+;;;
+(defconstant number-attribute	#b10)		; A numeric digit.
+(defconstant letter-attribute	#b100)		; A upper-case letter.
+(defconstant sign-attribute	#b1000)		; +-
+(defconstant extension-attribute #b10000)	; ^_
+(defconstant dot-attribute 	#b100000)	; .
+(defconstant slash-attribute	#b1000000)	; /
+(defconstant other-attribute	#b1)            ; Anything else legal.
+(defconstant funny-attribute	#b10000000)	; Anything illegal.
+
+(defconstant attribute-names
+  '((number . number-attribute) (letter . letter-attribute)
+    (sign . sign-attribute) (extension . extension-attribute)
+    (dot . dot-attribute) (slash . slash-attribute)
+    (other . other-attribute) (funny . funny-attribute)))
+
+); Eval-When (compile load eval)
+
+(flet ((set-bit (char bit)
+	 (let ((code (char-code char)))
+	   (setf (aref character-attributes code)
+		 (logior bit (aref character-attributes code))))))
+
+  (dolist (char '(#\! #\@ #\$ #\% #\& #\* #\= #\~ #\[ #\] #\{ #\}
+		  #\? #\< #\>))
+    (set-bit char other-attribute))
+
+  (dotimes (i 10)
+    (set-bit (digit-char i) number-attribute))
+
+  (do ((code (char-code #\A) (1+ code))
+       (end (char-code #\Z)))
+      ((> code end))
+    (declare (fixnum code end))
+    (set-bit (code-char code) letter-attribute))
+
+  (set-bit #\- sign-attribute)
+  (set-bit #\+ sign-attribute)
+  (set-bit #\^ extension-attribute)
+  (set-bit #\_ extension-attribute)
+  (set-bit #\. dot-attribute)
+  (set-bit #\/ slash-attribute)
+
+  ;; Make anything not explicitly allowed funny...
+  (dotimes (i char-code-limit)
+    (when (zerop (aref character-attributes i))
+      (setf (aref character-attributes i) funny-attribute))))
+
+;;; For each character, the value of the corresponding element is the lowest
+;;; base in which that character is a digit.
+;;;
+(defvar digit-bases
+  (make-array char-code-limit :element-type '(mod 37) :initial-element 36))
+
+(dotimes (i 36)
+  (let ((char (digit-char i 36)))
+    (setf (aref digit-bases (char-code char)) i)))
+
+
+;;; Symbol-Quotep  --  Internal
+;;;
+;;;    A FSM-like thingie that determines whether a symbol is a potential
+;;; number or has evil characters in it.
+;;;
+(defun symbol-quotep (name)
+  (declare (simple-string name))
+  (macrolet ((advance (tag &optional (at-end t))
+	       `(progn
+		 (when (= index len)
+		   ,(if at-end '(go TEST-SIGN) '(return nil)))
+		 (setq current (schar name index)
+		       code (char-code current)
+		       bits (aref attributes code))
+		 (incf index)
+		 (go ,tag)))
+	     (test (&rest attributes)
+		`(not (zerop
+		       (the fixnum
+			    (logand
+			     (logior ,@(mapcar
+					#'(lambda (x)
+					    (or (cdr (assoc x attribute-names))
+						(error "Blast!")))
+					attributes))
+			     bits)))))
+	     (digitp ()
+	       `(< (the fixnum (aref bases code)) base)))
+
+    (prog ((len (length name))
+	   (attributes character-attributes)
+	   (bases digit-bases)
+	   (base *print-base*)
+	   (index 0)
+	   (bits 0)
+	   (code 0)
+	   current)
+      (declare (fixnum len base index bits code))
+      (advance START t)
+
+     TEST-SIGN ; At end, see if it is a sign...
+      (return (not (test sign)))
+
+     OTHER ; Not potential number, see if funny chars...
+      (return (not (null (%primitive find-character-with-attribute
+				     name (1- index) len
+				     attributes funny-attribute))))
+     START
+      (when (digitp)
+	(if (test letter)
+	    (advance LAST-DIGIT-ALPHA)
+	    (advance DIGIT)))
+      (when (test letter number other slash) (advance OTHER nil))
+      (when (char= current #\.) (advance DOT-FOUND))
+      (when (test sign extension) (advance START-STUFF nil))
+      (return t)
+		  
+     DOT-FOUND ; Leading dots...
+      (when (test letter) (advance START-DOT-MARKER nil))
+      (when (digitp) (advance DOT-DIGIT))
+      (when (test number other) (advance OTHER nil))
+      (when (test extension slash sign) (advance START-DOT-STUFF nil))
+      (when (char= current #\.) (advance DOT-FOUND))
+      (return t)
+
+     START-STUFF ; Leading stuff before any dot or digit.
+      (when (digitp)
+	(if (test letter)
+	    (advance LAST-DIGIT-ALPHA)
+	    (advance DIGIT)))
+      (when (test number other) (advance OTHER nil))
+      (when (test letter) (advance START-MARKER nil))
+      (when (char= current #\.) (advance START-DOT-STUFF nil))
+      (when (test sign extension slash) (advance START-STUFF nil))
+      (return t)
+
+     START-MARKER ; Number marker in leading stuff...
+      (when (test letter) (advance OTHER nil))
+      (go START-STUFF)
+
+     START-DOT-STUFF ; Leading stuff containing dot w/o digit...
+      (when (test letter) (advance START-DOT-STUFF nil))
+      (when (digitp) (advance DOT-DIGIT))
+      (when (test sign extension dot slash) (advance START-DOT-STUFF nil))
+      (when (test number other) (advance OTHER nil))
+      (return t)
+
+     START-DOT-MARKER ; Number marker in leading stuff w/ dot..
+      ;; Leading stuff containing dot w/o digit followed by letter...
+      (when (test letter) (advance OTHER nil))
+      (go START-DOT-STUFF)
+
+     DOT-DIGIT ; In a thing with dots...
+      (when (test letter) (advance DOT-MARKER))
+      (when (digitp) (advance DOT-DIGIT))
+      (when (test number other) (advance OTHER nil))
+      (when (test sign extension dot slash) (advance DOT-DIGIT))
+      (return t)
+
+     DOT-MARKER ; Number maker in number with dot...
+      (when (test letter) (advance OTHER nil))
+      (go DOT-DIGIT)
+
+     LAST-DIGIT-ALPHA ; Previous char is a letter digit...
+      (when (or (digitp) (test sign slash))
+	(advance ALPHA-DIGIT))
+      (when (test letter number other dot) (advance OTHER nil))
+      (return t)
+      
+     ALPHA-DIGIT ; Seen a digit which is a letter...
+      (when (or (digitp) (test sign slash))
+	(if (test letter)
+	    (advance LAST-DIGIT-ALPHA)
+	    (advance ALPHA-DIGIT)))
+      (when (test letter) (advance ALPHA-MARKER))
+      (when (test number other dot) (advance OTHER nil))
+      (return t)
+
+     ALPHA-MARKER ; Number marker in number with alpha digit...
+      (when (test letter) (advance OTHER nil))
+      (go ALPHA-DIGIT)
+
+     DIGIT ; Seen only real numeric digits...
+      (when (digitp)
+	(if (test letter)
+	    (advance ALPHA-DIGIT)
+	    (advance DIGIT)))
+      (when (test number other) (advance OTHER nil))
+      (when (test letter) (advance MARKER)) 
+      (when (test extension slash sign) (advance DIGIT))
+      (when (char= current #\.) (advance DOT-DIGIT))
+      (return t)
+
+     MARKER ; Number marker in a numeric number...
+      (when (test letter) (advance OTHER nil))
+      (go DIGIT))))
+
+;;;
+;;; This function takes the pname of a symbol and adds slashes and/or 
+;;; vertical bars to it to make it readable again.
+;;; Special quoting characters are currently vertical bar and slash who's 
+;;; role in life are to specially quote symbols.  Funny symbol characters
+;;; are those who need special slashification when they are to be printed
+;;; so they can be read in again.  These currently include such characters 
+;;; as hash signs, colons of various sorts, etc.
+;;; Now there are three different version: UPPERCASE, lowercase and Captialize.
+;;; Check out the manual under the entry for *print-case* for details.
+
+(eval-when (compile eval)
+(defmacro symbol-quote-char-p (char)
+  `(or (char= ,char #\\) (char= ,char #\|)))
+); eval-when (compile eval)
+
+(defun output-uppercase-symbol (pname)
+  (declare (simple-string pname))
+  (cond ((symbol-quotep pname)
+	 (write-char #\|)
+	 (dostring (char pname)
+	   ;;If it needs slashing, do it.
+	   (if (symbol-quote-char-p char)
+	       (write-char #\\))
+	   (write-char char))
+	 (write-char #\|))
+	(t
+	 (write-string pname))))
+
+;; See documentation for output-symbol-uppercase (above).
+
+(defun output-lowercase-symbol (pname)
+  (declare (simple-string pname))
+  (cond ((symbol-quotep pname)
+	 (write-char #\|)
+	 (dostring (char pname)
+	   (if (symbol-quote-char-p char)
+	       (write-char #\\))
+	   (write-char char))
+	 (write-char #\|))
+	(t
+	 (dostring (char pname)
+	   (write-char (char-downcase char))))))
+
+
+(defun output-capitalize-symbol (pname)
+  (declare (simple-string pname))
+  (cond
+   ((symbol-quotep pname)
+    (write-char #\|)
+    (dostring (char pname)
+      (if (symbol-quote-char-p char)
+	  (write-char #\\))
+      (write-char char))
+    (write-char #\|))
+   (t
+    (do ((index 0 (1+ index))
+	 (pname-length (length (the string pname)))
+	 (prev-not-alpha t))
+	((= index pname-length))
+      (declare (fixnum index pname-length))
+      (let ((char (char pname index)))
+	(write-char (if prev-not-alpha char (char-downcase char)))
+	(setq prev-not-alpha (not (alpha-char-p char))))))))
+
+;;; Recursive Datatype Printing Subfunctions
+
+
+(defun output-list (list &optional (currlevel 0))
+  "Outputs the printed representation of a list."
+  (write-char #\()	#|)|#
+  (do ((list list (cdr list))
+       (currlength 0 (1+ currlength)))
+      ((or (null list)
+	   (and (not (null *print-length*))
+		(>= currlength (the fixnum *print-length*))))
+       (if (not (null list)) (write-string " ..."))
+       (write-char #|(|# #\)))
+    (declare (fixnum currlength))
+    ;;If we are not printing the first object, we should space first.
+    (if (> currlength 0) (write-char #\space))
+    ;;Print whatever the car of the list is, at this level.
+    (output-object (car list) currlevel)
+    (cond ((not (or (consp (cdr list))
+		    (null (cdr list))))
+	   (write-string " .  ")
+	   (output-object (cdr list) currlevel)
+	   (write-char #|(|# #\))
+	   (return ())))))
+ 
+(defun output-vector (vector &optional (currlevel 0))
+  "Outputs the printed representation of a 1-D array."
+  (declare (fixnum currlevel))
+  (cond ((not *print-array*)
+	 (output-terse-array vector currlevel))
+	(T
+	 (if (bit-vector-p vector)
+	     (write-string "#*")
+	     (write-string "#(" #|)|# ))
+	 (do ((currlength 0 (1+ currlength))
+	      (vlength (length (the vector vector)))
+	      (not-bit-vector-p (not (bit-vector-p vector))))
+	     ((or (and (not (null *print-length*))
+		       (>= currlength (the fixnum *print-length*)))
+		  (= currlength vlength))
+	      (if (not (= currlength vlength)) (write-string " ..."))
+	      (if not-bit-vector-p
+		  (write-char #|(|# #\))))
+	   (declare (fixnum currlength vlength))
+	 ;;Put a space before every element except the first
+	 ;; and not in bit vectors.
+	 (if (and (> currlength 0)
+		  not-bit-vector-p)
+	     (write-char #\space))
+	 ;;Output an element of the vector
+	 (output-object (aref vector currlength) currlevel)))))
+
+(defun output-array (array &optional (currlevel 0))
+  "Outputs the printed representation of any array in either the #< or #A form."
+  (let ((rank (array-rank array)))
+    (cond ((not *print-array*)
+	   (output-terse-array array rank))
+	  (T
+	   (output-array-guts array rank currlevel)))))
+
+;; Master function for outputing the #A form of an array
+
+(defun output-array-guts (array rank currlevel)
+  (write-char #\#)
+  (let ((*print-base* 10))
+    (output-integer rank))
+  (write-char #\A)
+  (with-array-data ((data array) (start) (end))
+    (declare (ignore end))
+    (sub-output-array-guts data (array-dimensions array) currlevel start)))
+
+;; Some Ideas stolen from Skef Wholey.
+;; Helping function for above.
+(defun sub-output-array-guts (array dimensions currlevel index)
+  (declare (fixnum currlevel index))
+  (cond ((null dimensions)
+	 (output-object (aref array index) currlevel)
+	 (1+ index))
+	((and (not (null *print-level*))
+	      (>= currlevel (the fixnum *print-level*)))
+	 (write-char #\#) index)
+	(T
+	 (write-char #\()
+	 (do ((index index)
+	      (times 0 (1+ times))
+	      (limit (pop dimensions)))
+	     ((or (= times limit)
+		  (and (not (null *print-length*))
+		       (= times *print-length*)))
+	      (if (not (= times limit))
+		  (write-string " ...)")
+		  (write-char #\)))
+	      index)
+	   (declare (fixnum index times limit))
+	   (if (not (zerop times)) (write-char #\space))
+	   (setq index
+		 (sub-output-array-guts array dimensions (1+ currlevel) index))
+	   ))))
+
+;; Used to output the #< form of any array.
+
+(defun output-terse-array (array rank)
+  (write-string "#<")
+  (cond ((vectorp array)
+	 (if (bit-vector-p array)
+	     (write-string "Bit-vector")
+	     (write-string "Vector")))
+	(T
+	 (write-string "Array, rank ")
+	 (output-integer rank)))
+  (finish-random array))
+
+
+;;; Structure Printing.  These days we can always pass the buck to the Defstruct
+;;; code.
+
+(defun output-structure (structure currlevel)
+  (let ((info (info type structure-info (svref structure 0))))
+    (if info
+	(funcall (c::dd-print-function info) structure *standard-output*
+		 currlevel)
+	(write-string "#<Bizarre illegal thing that looks like a structure>"))))
+
+;; Helping functions for printing strings.
+
+(defmacro funny-string-char-p (char)
+  "Determines whether or not the character needs quoting in a string."
+  ;; Should maybe look at readtable, not quite ready for such feat so
+  ;; use hack.
+  `(or (char= ,char #\\)
+       (char= ,char #\")))
+
+;;;
+;;; This function takes a string and slashifies it sufficiently so
+;;; that if so that it may be read in again.
+;;; Strategy: Put slash before all and only those characters which are
+;;; either double-quote or backslash.
+;;;
+
+(defun quote-string (string)
+  "Quotes a string so that if printed, it could be read back in again."
+  (write-char #\")
+  (dostring (char string)
+    (if (funny-string-char-p char) (write-char #\\))
+    (write-char char))
+  (write-char #\"))
+
+
+
+(defun whitespace-char-p (char)
+  "Determines whether or not the character is considered whitespace."
+  (or (char= char #\space)
+      (char= char #\tab)
+      (char= char #\return)
+      (char= char #\linefeed)))
+
+;;; Numerical Printer Functions.
+
+;; Helping function for above that actually outputs the individual digits.
+
+(defun output-integer (integer)
+  "This function outputs the printed representation of any integer"
+  (cond ((not (and (fixnump *print-base*) (> (the fixnum *print-base*) 1)))
+	 (let ((obase *print-base*))
+	   (setq *print-base* 10.)
+	   (error "~A is not a reasonable value for *Print-Base*." obase)))
+	;; Otherwise print the base
+	(T (cond ((and (not (= *print-base* 10.))
+		       *print-radix*)
+		  ;; First print leading base information, if any.
+		  (write-char #\#)
+		  (write-char (case *print-base*
+			  (2.  #\b)
+			  (8.  #\o)
+			  (16. #\x)
+			  (T (let ((fixbase *print-base*)
+				   (*print-base* 10.)
+				   (*print-radix* ()))
+			       (sub-output-integer fixbase))
+			     #\r)))))
+	   ;; Then output a minus sign if the number is negative, then output
+	   ;; the absolute value of the number.
+	   (cond ((bignump integer) (print-bignum integer))
+		 ((< integer 0)
+		  (write-char #\-)
+		  (sub-output-integer (- integer)))
+		 (T (sub-output-integer integer)))
+	   ;; Print any trailing base information, if any.
+	   (if (and (= *print-base* 10.) *print-radix*) (write-char #\.)))))
+
+
+(defun sub-output-integer (integer)
+  (let  ((quotient ())
+	 (remainder ()))
+    ;; Recurse until you have all the digits pushed on the stack.
+    (if (not (zerop (multiple-value-setq (quotient remainder)
+		      (truncate integer *print-base*))))
+      (sub-output-integer quotient))
+    ;; Then as each recursive call unwinds, turn the digit (in remainder) 
+    ;; into a character and output the character.
+    (write-char (int-char (if (and (> remainder 9.)
+			     (> *print-base* 10.))
+			(+ (char-int #\A) (- remainder 10.))
+			(+ (char-int #\0) remainder))))))
+
+
+;;; Outputs the printed representation of a ratio.
+
+(defun output-ratio (ratio)
+  (output-integer (numerator ratio))
+  (write-char #\/)
+  (output-integer (denominator ratio)))
+
+
+;;; Outputs the printed representation of a complex number.
+
+(defun output-complex (complex)
+  (write-string "#C(" #|)|#)
+  (output-object (realpart complex))
+  (write-char #\space)
+  (output-object (imagpart complex))
+  (write-char #|(|# #\)))
+
+;;; Bignum printing
+;;;
+;;; Written by Steven Handerson
+;;;  (based on Skef's idea)
+;;;
+
+;;; Bignum-fixnum-divide-inplace wants the divisor to be of integer-length
+;;; 19 or less.
+
+;;; 1- the ideal power of the base for a divisor.
+(defparameter *fixnum-power--1*
+  '#(NIL NIL 17 10 8 7 6 5 5 4 4 4 4 4 3 3 3 3 3 3 3 3 3 3 3 3 3 2 2 2 2 2 2 2 2
+	 2))
+
+;;; The base raised to the ideal power.
+(defparameter *base-power*
+  '#(NIL NIL 262144 177147 262144 390625 279936 117649 262144 59049 100000 161051
+	 248832 371293 38416 50625 65536 83521 104976 130321 160000 194481 234256
+	 279841 331776 390625 456976 19683 21952 24389 27000 29791 32768 35937
+	 39304 42875))
+
+(defun print-bignum (big)
+  (bignum-print-aux (cond ((minusp big) (write-char #\-) (- big))
+			  (t (copy-xnum big))))
+  big)
+
+(defun bignum-print-aux (big)
+  (multiple-value-bind (newbig fix)
+		       (bignum-fixnum-divide-inplace
+			big (aref *base-power* *print-base*))
+    (if (fixnump newbig) (sub-output-integer newbig)
+	(bignum-print-aux newbig))
+    (do ((zeros (aref *fixnum-power--1* *print-base*) (1- zeros))
+	 (base-power *print-base* (* base-power *print-base*)))
+	((> base-power fix)
+	 (dotimes (i zeros) (write-char #\0))
+	 (sub-output-integer fix)))))
+
+
+
+;;;; Floating Point printing
+;;;
+;;;  Written by Bill Maddox
+;;;
+;;;
+;;;
+;;; FLONUM-TO-STRING (and its subsidiary function FLOAT-STRING) does most of 
+;;; the work for all printing of floating point numbers in the printer and in
+;;; FORMAT.  It converts a floating point number to a string in a free or 
+;;; fixed format with no exponent.  The interpretation of the arguments is as 
+;;; follows:
+;;;
+;;;     X        - The floating point number to convert, which must not be
+;;;                negative.
+;;;     WIDTH    - The preferred field width, used to determine the number
+;;;                of fraction digits to produce if the FDIGITS parameter
+;;;                is unspecified or NIL.  If the non-fraction digits and the
+;;;                decimal point alone exceed this width, no fraction digits
+;;;                will be produced unless a non-NIL value of FDIGITS has been
+;;;                specified.  Field overflow is not considerd an error at this
+;;;                level.
+;;;     FDIGITS  - The number of fractional digits to produce. Insignificant
+;;;                trailing zeroes may be introduced as needed.  May be
+;;;                unspecified or NIL, in which case as many digits as possible
+;;;                are generated, subject to the constraint that there are no
+;;;                trailing zeroes.
+;;;     SCALE    - If this parameter is specified or non-NIL, then the number
+;;;                printed is (* x (expt 10 scale)).  This scaling is exact,
+;;;                and cannot lose precision.
+;;;     FMIN     - This parameter, if specified or non-NIL, is the minimum
+;;;                number of fraction digits which will be produced, regardless
+;;;                of the value of WIDTH or FDIGITS.  This feature is used by
+;;;                the ~E format directive to prevent complete loss of
+;;;                significance in the printed value due to a bogus choice of
+;;;                scale factor.
+;;;
+;;; Most of the optional arguments are for the benefit for FORMAT and are not
+;;; used by the printer.
+;;;
+;;; Returns:
+;;; (VALUES DIGIT-STRING DIGIT-LENGTH LEADING-POINT TRAILING-POINT DECPNT)
+;;; where the results have the following interpretation:
+;;;
+;;;     DIGIT-STRING    - The decimal representation of X, with decimal point.
+;;;     DIGIT-LENGTH    - The length of the string DIGIT-STRING.
+;;;     LEADING-POINT   - True if the first character of DIGIT-STRING is the
+;;;                       decimal point.
+;;;     TRAILING-POINT  - True if the last character of DIGIT-STRING is the
+;;;                       decimal point.
+;;;     POINT-POS       - The position of the digit preceding the decimal
+;;;                       point.  Zero indicates point before first digit.
+;;;
+;;; WARNING: For efficiency, there is a single string object *digit-string*
+;;; which is modified destructively and returned as the value of
+;;; FLONUM-TO-STRING.  Thus the returned value is not valid across multiple 
+;;; calls.
+;;;
+;;; NOTE:  FLONUM-TO-STRING goes to a lot of trouble to guarantee accuracy.
+;;; Specifically, the decimal number printed is the closest possible 
+;;; approximation to the true value of the binary number to be printed from 
+;;; among all decimal representations  with the same number of digits.  In
+;;; free-format output, i.e. with the number of digits unconstrained, it is 
+;;; guaranteed that all the information is preserved, so that a properly-
+;;; rounding reader can reconstruct the original binary number, bit-for-bit, 
+;;; from its printed decimal representation. Furthermore, only as many digits
+;;; as necessary to satisfy this condition will be printed.
+;;;
+;;;
+;;; FLOAT-STRING actually generates the digits for positive numbers.  The
+;;; algorithm is essentially that of algorithm Dragon4 in "How to Print 
+;;; Floating-Point Numbers Accurately" by Steele and White.  The current 
+;;; (draft) version of this paper may be found in [CMUC]<steele>tradix.press.
+;;; DO NOT EVEN THINK OF ATTEMPTING TO UNDERSTAND THIS CODE WITHOUT READING 
+;;; THE PAPER!
+
+
+(defvar *digits* "0123456789")
+
+(defvar *digit-string*
+  (make-array 50 :element-type 'string-char :fill-pointer 0 :adjustable t))
+
+(defun flonum-to-string (x &optional width fdigits scale fmin)
+  (cond ((zerop x)
+	 ;;zero is a special case which float-string cannot handle
+	 (if fdigits
+	     (let ((s (make-string (1+ fdigits) :initial-element #\0)))
+	       (setf (schar s 0) #\.)
+	       (values s (length s) t (zerop fdigits) 0))
+	     (values "." 1 t t 0)))
+	(t
+	  (setf (fill-pointer *digit-string*) 0)
+	  (multiple-value-bind (sig exp)
+			       (integer-decode-float x)
+	    (if (typep x 'short-float)
+		;;20 and 53 are the number of bits of information in the
+		;;significand, less sign, of a short float and a long float
+		;;respectively.
+		(float-string sig exp 20 width fdigits scale fmin)
+		(float-string sig exp 53 width fdigits scale fmin))))))
+
+
+(defun float-string (fraction exponent precision width fdigits scale fmin)
+  (let ((r fraction) (s 1) (m- 1) (m+ 1) (k 0)
+	(digits 0) (decpnt 0) (cutoff nil) (roundup nil) u low high)
+    ;;Represent fraction as r/s, error bounds as m+/s and m-/s.
+    ;;Rational arithmetic avoids loss of precision in subsequent calculations.
+    (cond ((> exponent 0)
+	   (setq r (ash fraction exponent))
+	   (setq m- (ash 1 exponent))	   
+	   (setq m+ m-))                   
+	  ((< exponent 0)
+	   (setq s (ash 1 (- exponent)))))
+    ;;adjust the error bounds m+ and m- for unequal gaps
+    (when (= fraction (ash 1 precision))
+      (setq m+ (ash m+ 1))
+      (setq r (ash r 1))
+      (setq s (ash s 1)))
+    ;;scale value by requested amount, and update error bounds
+    (when scale
+      (if (minusp scale)
+	  (let ((scale-factor (expt 10 (- scale))))
+	    (setq s (* s scale-factor)))
+	  (let ((scale-factor (expt 10 scale)))
+	    (setq r (* r scale-factor))
+	    (setq m+ (* m+ scale-factor))
+	    (setq m- (* m- scale-factor)))))
+    ;;scale r and s and compute initial k, the base 10 logarithm of r
+    (do ()
+        ((>= r (ceiling s 10)))
+      (decf k)
+      (setq r (* r 10))
+      (setq m- (* m- 10))
+      (setq m+ (* m+ 10)))
+    (do ()(nil)
+      (do ()
+	  ((< (+ (ash r 1) m+) (ash s 1)))
+	(setq s (* s 10))
+	(incf k))
+      ;;determine number of fraction digits to generate
+      (cond (fdigits
+	     ;;use specified number of fraction digits
+	     (setq cutoff (- fdigits))
+	     ;;don't allow less than fmin fraction digits
+	     (if (and fmin (> cutoff (- fmin))) (setq cutoff (- fmin))))
+	    (width
+	     ;;use as many fraction digits as width will permit
+             ;;but force at least fmin digits even if width will be exceeded
+	     (if (< k 0)
+		 (setq cutoff (- 1 width))
+		 (setq cutoff (1+ (- k width))))
+	     (if (and fmin (> cutoff (- fmin))) (setq cutoff (- fmin)))))
+      ;;If we decided to cut off digit generation before precision has
+      ;;been exhausted, rounding the last digit may cause a carry propagation.
+      ;;We can prevent this, preserving left-to-right digit generation, with
+      ;;a few magical adjustments to m- and m+.  Of course, correct rounding
+      ;;is also preserved.
+      (when (or fdigits width)
+	(let ((a (- cutoff k))
+	      (y s))
+	  (if (>= a 0)
+	      (dotimes (i a) (setq y (* y 10)))
+	      (dotimes (i (- a)) (setq y (ceiling y 10))))
+	  (setq m- (max y m-))
+	  (setq m+ (max y m+))
+	  (when (= m+ y) (setq roundup t))))
+      (when (< (+ (ash r 1) m+) (ash s 1)) (return)))
+
+    ;;zero-fill before fraction if no integer part
+    (when (< k 0)
+      (setq decpnt digits)
+      (vector-push-extend #\. *digit-string*)
+      (dotimes (i (- k))
+	(incf digits) (vector-push-extend #\0 *digit-string*)))
+    ;;generate the significant digits
+    (do ()(nil)
+      (decf k)
+      (when (= k -1)
+	(vector-push-extend #\. *digit-string*)
+	(setq decpnt digits))
+      (multiple-value-setq (u r) (truncate (* r 10) s))
+      (setq m- (* m- 10))
+      (setq m+ (* m+ 10))
+      (setq low (< (ash r 1) m-))
+      (if roundup
+	  (setq high (>= (ash r 1) (- (ash s 1) m+)))
+	  (setq high (> (ash r 1) (- (ash s 1) m+))))
+      ;;stop when either precision is exhausted or we have printed as many
+      ;;fraction digits as permitted
+      (when (or low high (and cutoff (<= k cutoff))) (return))
+      (vector-push-extend (char *digits* u) *digit-string*)
+      (incf digits))
+    ;;if cutoff occured before first digit, then no digits generated at all
+    (when (or (not cutoff) (>= k cutoff))
+      ;;last digit may need rounding
+      (vector-push-extend (char *digits*
+				(cond ((and low (not high)) u)
+				      ((and high (not low)) (1+ u))
+				      (t (if (<= (ash r 1) s) u (1+ u)))))
+			  *digit-string*)
+      (incf digits))
+    ;;zero-fill after integer part if no fraction
+    (when (>= k 0)
+      (dotimes (i k) (incf digits) (vector-push-extend #\0 *digit-string*))
+      (vector-push-extend #\. *digit-string*)
+      (setq decpnt digits))
+    ;;add trailing zeroes to pad fraction if fdigits specified
+    (when fdigits
+      (dotimes (i (- fdigits (- digits decpnt)))
+	(incf digits)
+	(vector-push-extend #\0 *digit-string*)))
+    ;;all done
+    (values *digit-string* (1+ digits) (= decpnt 0) (= decpnt digits) decpnt)))
+
+
+
+;;; Given a non-negative floating point number, SCALE-EXPONENT returns a
+;;; new floating point number Z in the range (0.1, 1.0] and and exponent
+;;; E such that Z * 10^E is (approximately) equal to the original number.
+;;; There may be some loss of precision due the floating point representation.
+
+
+(defconstant short-log10-of-2 0.30103s0)
+
+(defun scale-exponent (x)
+  (if (typep x 'short-float)
+      (scale-expt-aux x 0.0s0 1.0s0 1.0s1 1.0s-1 short-log10-of-2)
+      (scale-expt-aux x 0.0l0 1.0l0 %long-float-ten
+		      %long-float-one-tenth long-log10-of-2)))
+
+
+(defun scale-expt-aux (x zero one ten one-tenth log10-of-2)
+  (multiple-value-bind (sig exponent)
+		       (decode-float x)
+    (declare (ignore sig))
+    (if (= x zero)
+	(values zero 1)
+	(let* ((ex (round (* exponent log10-of-2)))
+	       (x (if (minusp ex)		;For the end ranges.
+		      (* x ten (expt ten (- -1 ex)))
+		      (/ x ten (expt ten (1- ex))))))
+	  (do ((d ten (* d ten))
+	       (y x (/ x d))
+	       (ex ex (1+ ex)))
+	      ((< y one)
+	       (do ((m ten (* m ten))
+		    (z y (* z m))
+		    (ex ex (1- ex)))
+		   ((>= z one-tenth) (values z ex)))))))))
+
+
+;;; Entry point for the float printer as called by PRINT, PRIN1, PRINC,
+;;; etc.  The argument is printed free-format, in either exponential or 
+;;; non-exponential notation, depending on its magnitude.
+;;;
+;;; NOTE:  When a number is to be printed in exponential format, it is scaled
+;;; in floating point.  Since precision may be lost in this process, the
+;;; guaranteed accuracy properties of FLONUM-TO-STRING are lost.  The
+;;; difficulty is that FLONUM-TO-STRING performs extensive computations with
+;;; integers of similar magnitude to that of the number being printed.  For
+;;; large exponents, the bignums really get out of hand.  When we switch to
+;;; IEEE format for long floats, this will significantly restrict the magnitude
+;;; of the largest allowable float.  This combined with microcoded bignum
+;;; arithmetic might make it attractive to handle exponential notation with
+;;; the same accuracy as non-exponential notation, using the method described
+;;; in the Steele and White paper.
+
+(defun output-float (x)
+  (if (typep x 'short-float)
+      (output-float-aux x 1.0s-3 1.0s7)
+      (output-float-aux x %long-float1l-3 %long-float1l7)))
+
+
+(defun output-float-aux (x e-min e-max)
+  (cond ((zerop x)
+	 (write-string "0.0")
+	 (if (and (not (typep x *read-default-float-format*))
+		  (not (and (eq *read-default-float-format* 'single-float)
+			    (typep x 'short-float))))
+	     (write-string (if (typep x 'short-float) "s0" "L0"))))
+	(t (when (minusp x) 
+	     (write-char #\-)
+	     (setq x (- x)))
+	   (if (and (>= x e-min) (< x e-max))
+	       ;;free format
+	       (multiple-value-bind (str len lpoint tpoint)
+				    (flonum-to-string x)
+		 (declare (ignore len))
+		 (when lpoint (write-char #\0))
+		 (write-string str)
+		 (when tpoint (write-char #\0))
+		 (if (and (not (typep x *read-default-float-format*))
+			  (not (and (eq *read-default-float-format* 'single-float)
+				    (typep x 'short-float))))
+		     (write-string (if (typep x 'short-float) "s0" "L0"))))
+	       ;;exponential format 
+	       (multiple-value-bind (f ex)
+				    (scale-exponent x)
+		 (multiple-value-bind (str len lpoint tpoint)
+				      (flonum-to-string f nil nil 1)
+		   (declare (ignore len))
+		   (when lpoint (write-char #\0))
+		   (write-string str)
+		   (when tpoint (write-char #\0))
+		   (write-char (if (typep x *read-default-float-format*)
+				   #\E
+				   (if (typep x 'short-float) #\S #\L)))
+		   ;;must subtract 1 from exponent here, due to
+		   ;;the scale factor of 1 in call to FLONUM-TO-STRING
+		   (unless (minusp (1- ex)) (write-char #\+))
+		   (output-integer (1- ex))))))))
+
+
+
+;; FUNNY-CHARACTER-CHAR-P returns a predicate which determines whether a
+;; character must be slashified when being output.
+
+(defmacro funny-character-char-p (char)
+  `(and (not (zerop (char-bits ,char)))
+	(not (zerop (logand (aref character-attributes (char-code ,char))
+			    funny-attribute)))))
+
+;;; Output-Character  --  Internal
+;;;
+;;;    If *print-escape* is false, just do a write-char, otherwise output
+;;; any bits and then the character or name, escaping if necessary.  In
+;;; either case, we blast the bits or font before writing the character
+;;; itself to the stream.
+;;;
+(defun output-character (char)
+  (let ((base (make-char char)))
+    (if *print-escape*
+	(let ((name (char-name base)))
+	  (write-string "#\\")
+	  (macrolet ((frob (key string)
+		       `(when (char-bit char ,key)
+			  (write-string ,string))))
+	    (frob :control "CONTROL-")
+	    (frob :meta "META-")
+	    (frob :super "SUPER-")
+	    (frob :hyper "HYPER-"))
+	  (cond (name (write-string name))
+		(t 
+		 (when (funny-character-char-p char)
+		   (write-char #\\))
+		 (write-char base))))
+	(write-char base))))
+
+
+
+;;; Random and Misc. Print Subfunctions
+
+
+;;; OUTPUT-FUNCTION-OBJECT outputs the main part of the printed 
+;;; representation of function objects.  It is called from OUTPUT-RANDOM
+;;; below.
+
+(defun output-function-object (subr)
+  (let ((name (%primitive header-ref subr %function-name-slot)))
+  (case (%primitive get-vector-subtype subr)
+    (#.%function-entry-subtype
+     (if (stringp name)
+	 (format t "Internal Function ~S" name)
+	 (format t "Function ~S" name)))
+    (#.%function-closure-subtype
+     (if (eval:interpreted-function-p subr)
+	 (multiple-value-bind
+	     (ig1 ig2 name)
+	     (eval:interpreted-function-lambda-expression subr)
+	   (declare (ignore ig1 ig2))
+	   (format t "Interpreted Function ~S" name))
+	 (format t "Closure ~S"
+		 (%primitive header-ref name %function-name-slot))))
+    (#.%function-closure-entry-subtype
+     (format t "Closure Entry ~S" name))
+    (#.%function-constants-subtype
+     (format t "Function Constants ~S" name))
+    (#.%function-value-cell-subtype
+     (assert (= %function-value-cell-value-slot %function-name-slot))
+     (format t "Indirect Value Cell ~S" name))
+#|
+    (#.%function-funcallable-instance-subtype
+     (format t "Funcallable Instance ~S" name))
+|#
+    (t (error "Unknown function subtype.")))))
+
+
+;;; FINISH-RANDOM is a helping function for OUTPUT-RANDOM below.  
+;;; It outputs the numerical value of the low 28 bits of 
+;;; RANDOM-OBJECT, enclosed in braces, followed by the closing
+;;; angle-bracket (">") random objects have at the end.  This
+;;; is used to distringuish random objects of the same type.
+
+(defun finish-random (random-object)
+  (write-string " {")
+  (let ((*print-base* 16))
+    (output-integer (%primitive make-fixnum random-object)))
+  (write-string "}>"))
+
+;;; Functions Objects and other implmentation specific objects 
+;;; are output here. 
+
+(defun output-random (object)
+  (write-string "#<")
+  (if (compiled-function-p object)
+      (output-function-object object)
+      (let ((type (%primitive get-type object)))
+	(write-string "Pointer into Hell, level ")
+	(sub-output-integer type)))
+  (finish-random object))
diff --git a/code/purify.lisp b/code/purify.lisp
new file mode 100644
index 000000000..24f322e43
--- /dev/null
+++ b/code/purify.lisp
@@ -0,0 +1,538 @@
+;;; -*- Log: code.log; Package: Lisp -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; Storage purifier for Spice Lisp.
+;;; Written by Rob MacLachlan and Skef Wholey.
+;;;
+;;;    The function Purify, defined herein, puts as much of the Lisp system as
+;;; possible into Read-Only and Static spaces so that subsequent garbage
+;;; collections are quicker.  This is done by frobbing the free-pointers for
+;;; spaces so that new objects are put in static or read-only space as
+;;; appropiate, then doing a GC.
+;;;
+;;;    We also transport all of the dynamic symbols in Lisp code so we
+;;; can do clever things that improve locality in the resulting Lisp. 
+;;; Some constant conses and g-vectors are also transported in macrocode
+;;; so that we can put them in read-only space.
+;;;
+(in-package 'lisp)
+
+(defun purify (&key root-structures)
+  (declare (special lisp-environment-list))
+  (setq lisp-environment-list NIL)
+  (write-string "[Doing purification: ")
+  (force-output)
+  (setq *already-maybe-gcing* t)
+  ;;
+  ;; Move symbols to static space, constants to read-only space.
+  #| But don't until it works...
+  (localify root-structures)
+  |#
+  ;;
+  ;; Move everything else to either static or read-only space, depending
+  ;; on type.
+  (let ((fixups (gc-grovel-stack)))
+    (%primitive clear-registers)
+    (%primitive purify)
+    (gc-fixup-stack fixups))
+
+  (setq *already-maybe-gcing* nil)
+  (setq *need-to-collect-garbage* nil)
+  (write-line "done]")
+  nil)
+
+;;;; Localify
+
+(eval-when (compile eval)
+;;; Peek, Poke  --  Internal
+;;;
+;;;    Read or write the cell at a location without doing any type-checking or
+;;; anything silly like that.
+;;; 
+(defmacro peek (x)
+  `(%primitive read-control-stack ,x))
+(defmacro poke (x val)
+  `(%primitive write-control-stack ,x ,val))
+
+;;; Symbol-Bits  --  Internal
+;;;
+;;;    There is a whole 32 bits at the end of every symbol, which until
+;;; now, was unused.  We will use the low 16 to annotate some stuff about
+;;; how symbols are referenced.
+;;;
+(defmacro symbol-bits (sym)
+  `(get ,sym 'purify-symbol-bits 0))
+
+(defsetf symbol-bits (sym) (val)
+  `(let ((space (%primitive get-allocation-space)))
+     (%primitive set-allocation-space %dynamic-space)
+     (prog1 (setf (get ,sym 'purify-symbol-bits) ,val)
+	    (%primitive set-allocation-space space))))
+
+(defconstant marked-bit		#b001)
+(defconstant worthwhile-bit	#b010)
+(defconstant referenced-bit	#b100)
+
+;;; Do-Allocated-Symbols  --  Internal
+;;;
+;;;    Iterate over all the symbols allocated in some space.
+;;;
+(defmacro do-allocated-symbols ((symbol space) &body forms)
+  `(let* ((old-alloc-space (%primitive get-allocation-space)))
+     (%primitive set-allocation-space %dynamic-space)
+     (let* ((index (+ (ash %symbol-type %alloc-ref-type-shift)
+		      (ash ,space %alloc-ref-space-shift)))
+	    (alloc-table (int-sap %fixnum-alloctable-address))
+	    (end (+ (logior (%primitive 16bit-system-ref alloc-table (1+ index))
+			    (ash (logand %type-space-mask
+					 (%primitive 16bit-system-ref alloc-table index))
+				 16))
+		    (ash ,space %space-shift))))
+       (declare (fixnum end))
+       (do ((base (ash ,space %space-shift) (+ base %symbol-length)))
+	   ((= base end))
+	 (declare (fixnum base))
+	 (let ((,symbol (%primitive make-immediate-type base %symbol-type)))
+	   (%primitive set-allocation-space old-alloc-space)
+	   ,@forms
+	   (%primitive set-allocation-space %dynamic-space))))
+     (%primitive set-allocation-space old-alloc-space)))
+
+;;; Inlinep  --  Internal
+;;;
+;;;    Return true if symbol appears to be the name of a function likely
+;;; to be coded inline.
+;;;
+(defmacro inlinep (sym)
+  `(or (info function source-transform ,sym)
+       (and (boundp 'c::*function-info*)
+	    (let ((info (gethash ,sym c::*function-info*)))
+	      (and info
+		   (or (c::function-info-templates info)
+		       (c::function-info-ir2-convert info)))))))
+
+
+;;; Next-Symbol, Next-Cons  --  Internal
+;;;
+;;;    Return the object allocated after the supplied one.
+;;;
+(defmacro next-symbol (sym)
+  `(%primitive make-immediate-type (+ (%primitive make-fixnum ,sym) %symbol-length)
+	       %symbol-type))
+(defmacro next-cons (cons)
+  `(%primitive make-immediate-type (+ (%primitive make-fixnum ,cons) %cons-length)
+	       %list-type))
+
+;;; Purep  --  Internal
+;;;
+;;;    True if Obj is either not dynamic or has already been transported.
+;;;
+(defmacro purep (obj)
+  `(or (>= (%primitive get-space ,obj) %static-space)
+       (let ((type (%primitive get-type ,obj)))
+	 (declare (fixnum type))
+	 (or (< type %first-pointer-type)
+	     (> type %last-pointer-type)
+	     (= (%primitive get-type (peek ,obj)) %gc-forward-type)))))
+
+;;; Free-Pointer-Location  --  Internal
+;;;
+;;;    Return the SAP which points to the location of the free-pointer
+;;; for the specifed type and space in the alloc table.
+;;;
+(defmacro free-pointer-location (type space)
+  `(+ %fixnum-alloctable-address
+      (%primitive lsh ,type (1+ %alloc-ref-type-shift))
+      (%primitive lsh ,space (1+ %alloc-ref-space-shift))))
+
+;;; Transport-Symbol  --  Internal
+;;;
+;;;    If Sym is impure, copy it into static space and put a GC forward in the
+;;; old symbol.  Return True only if we actually did something.
+;;; 
+(defmacro transport-symbol (sym)
+  `(unless (purep ,sym)
+     (let ((new-sym (%primitive alloc-symbol (symbol-name ,sym))))
+       (when (boundp ,sym)
+	 (setf (symbol-value new-sym) (symbol-value ,sym)))
+       (when (fboundp ,sym)
+	 (setf (symbol-function new-sym) (symbol-function ,sym)))
+       (setf (symbol-plist new-sym) (symbol-plist ,sym))
+       (%primitive set-package new-sym (symbol-package ,sym))
+       (poke ,sym (%primitive make-immediate-type new-sym %gc-forward-type))
+       t)))
+
+;;; Copy-G-Vector  --  Internal
+;;;
+;;;    Copy a G-Vector into the current allocation space, and forward
+;;; the old object.  Return the new object.  If an EQ hashtable,
+;;; change the subtype, otherwise preserve it.
+;;;
+(defmacro copy-g-vector (object)
+  `(let* ((len (length ,object))
+	  (new (%primitive alloc-g-vector len nil))
+	  (st (%primitive get-vector-subtype ,object)))
+     (dotimes (i len)
+       (setf (svref new i) (svref ,object i)))
+     (%primitive set-vector-subtype new
+		 (case st
+		   ((2 3) 4)
+		   (t st)))
+     (poke ,object (%primitive make-immediate-type new %gc-forward-type))
+     new))
+
+
+;;; Scavenge-Symbols  --  Internal
+;;;
+;;;    Scan through static symbol space doing a Transport-Function on
+;;; the definition of every Fbound symbol between the free pointer
+;;; and our clean pointer.  The free pointer can move during the process
+;;; due to symbols being transported.
+;;;
+(defmacro scavenge-symbols ()
+  `(do ((free-ptr (peek free-ptr-loc) (peek free-ptr-loc)))
+       ((eq clean-ptr free-ptr))
+     (when (fboundp clean-ptr)
+       (transport-function (symbol-function clean-ptr)))
+     (setq clean-ptr (next-symbol clean-ptr))))
+); eval-when (compile eval)
+
+;;; Mark-Function  --  Internal
+;;;
+;;;    Set the referenced bit in any symbol constants, and call
+;;; Mark-If-Worthwhile on any which are not marked.
+;;;
+(defun mark-function (fun)
+  (let ((len (%primitive header-length fun)))
+    (do ((i %function-constants-offset (1+ i)))
+	((= i len))
+      (let ((el (%primitive header-ref fun i)))
+	(when (symbolp el)
+	  (let ((bits (symbol-bits el)))
+	    (setf (symbol-bits el) (logior referenced-bit bits))
+	    (when (zerop (logand marked-bit bits))
+	      (mark-if-worthwhile el))))))))
+
+
+;;; Mark-If-Worthwhile  --  Internal
+;;;
+;;;    Mark the symbol if it is not already marked.  If it is appears to
+;;; be a symbol likely to be used at runtime, we set the worthwhile
+;;; bit as well.
+;;;
+(defun mark-if-worthwhile (sym)
+  (when (zerop (logand (symbol-bits sym) marked-bit))
+    ;;
+    ;; Mark it so we know we have been here...
+    (setf (symbol-bits sym) (logior marked-bit (symbol-bits sym)))
+    ;;
+    ;; If fbound and not an open-coded function, walk the function.
+    (when (and (fboundp sym) (not (inlinep sym)))
+      (setf (symbol-bits sym)
+	    (logior worthwhile-bit (symbol-bits sym)))
+      (mark-function (symbol-function sym)))
+    ;;
+    ;; If bound and not a inline constant, or neither bound nor fbound, 
+    ;; but has a plist, mark as worthwhile.
+    (when (if (boundp sym)
+	      (not (and (constantp sym)
+			(let ((val (symbol-value sym)))
+			  (or (characterp val) (numberp val) (eq sym val)))))
+	      (and (not (fboundp sym))
+		   (not (null (cddr (symbol-plist sym))))))
+      (setf (symbol-bits sym)
+	    (logior worthwhile-bit (symbol-bits sym))))))
+
+
+;;; Transport-And-Scavenge  --  Internal
+;;;
+;;;    Transport a symbol and then scavenge to completion.
+;;;
+(defun transport-and-scavenge (symbol)
+  (let* ((free-ptr-loc (free-pointer-location %symbol-type %static-space))
+	 (clean-ptr (peek free-ptr-loc)))
+    (transport-symbol symbol)
+    (scavenge-symbols)))
+
+
+;;; Transport-Function  --  Internal
+;;;
+;;;    Grovel the constants of a function object, transporting things
+;;; that look useful.  If a symbol has the worthwhile bit set, we move it.  We
+;;; transport conses and g-vectors here so that they can go into read-only
+;;; space.  If a constant is a compiled function, we recurse on it.
+;;;
+(defun transport-function (fun)
+  (unless (purep fun)
+    (let ((def (ecase (%primitive get-vector-subtype fun)
+		 (#.%function-entry-subtype
+		  (%primitive header-ref fun %function-entry-constants-slot))
+		 (#.%function-closure-subtype
+		  (%primitive header-ref
+			      (%primitive header-ref fun %function-name-slot)
+			      %function-entry-constants-slot))
+		 (#.%function-funcallable-instance-subtype
+		  nil))))
+      (when def
+	(do ((i %function-constants-constants-offset (1+ i))
+	     (length (%primitive header-length def)))
+	    ((= i length))
+	  (let ((const (%primitive header-ref def i)))
+	    (typecase const
+	      (symbol
+	       (unless (zerop (logand worthwhile-bit (symbol-bits const)))
+		 (transport-symbol const)))
+	      (cons
+	       (transport-cons const))
+	      (compiled-function
+	       (transport-function const))
+	      (simple-vector
+	       (transport-g-vector const)))))))))
+
+
+;;; Transport-Cons  --  Internal
+;;;
+;;;    Transport a cons and any list structure attached to it into read-only
+;;; space and scavenge to completion.
+;;;
+(defun transport-cons (cons)
+  (unless (purep cons)
+    (%primitive set-allocation-space %read-only-space)
+    (let* ((free-ptr-loc (free-pointer-location %list-type %read-only-space))
+	   (clean-ptr (peek free-ptr-loc)))
+      (loop
+       (loop
+	(let ((new (cons (car cons) (cdr cons))))
+	  (poke cons (%primitive make-immediate-type new %gc-forward-type))
+	  (setq cons (cdr cons))
+	  (when (or (atom cons) (purep cons)) (return nil))))
+       (let ((free-ptr (peek free-ptr-loc)))
+	 (loop
+	  (when (eq clean-ptr free-ptr)
+	    (%primitive set-allocation-space %static-space)
+	    (return-from transport-cons nil))
+	  (setq cons (car clean-ptr))
+	  (setq clean-ptr (next-cons clean-ptr))
+	  (unless (or (atom cons) (purep cons)) (return nil))))))))
+
+;;; Transport-G-Vector  --  Internal
+;;;
+;;;    Transport a G-Vector into static space.  We only bother with
+;;; the top level, and leave the rest to GC.
+;;;
+(defun transport-g-vector (vec &optional read-only)
+  (unless (purep vec)
+    (when read-only
+      (%primitive set-allocation-space %read-only-space))
+    (copy-g-vector vec)
+    (when read-only
+      (%primitive set-allocation-space %static-space))))
+
+;;; Transport-Root  --  Internal
+;;;
+;;;    Descend into lists, simple-vectors and compiled functions, transporting 
+;;; any useful symbols we run into, and scavenging to completion after each.  We
+;;; transport simple-vectors now so that we don't lose on circular or highly
+;;; shared structures.
+;;;
+(defun transport-root (object)
+  (unless (purep object)
+    (typecase object
+      (symbol
+       (unless (zerop (logand worthwhile-bit (symbol-bits object)))
+	 (transport-and-scavenge object)))
+      (simple-vector
+       (let ((new (copy-g-vector object)))
+	 (dotimes (i (length new))
+	   (transport-root (svref new i)))))
+      (cons
+       (transport-root (car object))
+       (transport-root (cdr object)))
+      (compiled-function
+       (transport-function object)))))
+
+;;; Localify  --  Internal
+;;;
+;;;    This function goes GC-Like stuff at lisp level to try to increase 
+;;; the locality in a purified core image.  The basic idea is to do a
+;;; breadth-first walk of the function objects, moving interesting symbols
+;;; into static space.
+;;;
+(defun localify (root-structures)
+  (%primitive set-allocation-space %static-space)
+  ;;
+  ;; Mark interesting symbols, and those referenced by their definitions.
+  (do-allocated-symbols (sym %dynamic-space)
+    (setf (symbol-bits sym) 0))
+  (do-allocated-symbols (sym %dynamic-space)
+    (mark-if-worthwhile sym))
+  ;;
+  ;; Move interesting symbols referenced by the root structures.
+  (dolist (x root-structures)
+    (transport-root x))
+  ;;
+  ;; Treat interesting unreferenced symbols as roots...
+  (do-allocated-symbols (sym %dynamic-space)
+    (unless (purep sym)
+      (let ((bits (symbol-bits sym)))
+	(when (and (zerop (logand referenced-bit bits))
+		   (not (zerop (logand worthwhile-bit bits))))
+	  (transport-and-scavenge sym)))))
+  ;;
+  ;; Treat referenced symbols as roots...
+  (do-allocated-symbols (sym %dynamic-space)
+    (unless (or (purep sym)
+		(zerop (logand referenced-bit (symbol-bits sym))))
+      (transport-and-scavenge sym)))
+  ;;
+  ;; Do anything else that wants to be done...
+  (do-allocated-symbols (sym %dynamic-space)
+    ;;
+    ;; Move some selected property values into read-only space.
+    (macrolet ((movec (prop)
+		 `(let ((val (get sym ',prop)))
+		    (when val (transport-cons val))))
+	       (movev (prop)
+		 `(let ((val (get sym ',prop)))
+		    (when val (transport-g-vector val t)))))
+      (movec inline-expansion)
+      (movec clc::clc-transforms)
+      (movec clc::clc-args)
+      (movev %structure-definition)
+      (movev alien-variable)
+      (movev alien-stack-info)
+      (movev alien-operator-info)
+      (movev enumeration-info))
+    ;;
+    ;; Move some types of variable value...
+    (when (boundp sym)
+      (let ((val (symbol-value sym)))
+	(cond ((purep val))
+	      ((get sym '%constant)
+	       (typecase val
+		 (cons (transport-cons val))
+		 (simple-vector (transport-g-vector val t))))
+	      ((and (structurep val)
+		    (memq (svref val 0) '(clc::%instruction alien-value)))
+	       (transport-g-vector val t)))))
+    ;;
+    ;; Move any interned symbol that's left...
+    (unless (or (purep sym) (not (symbol-package sym)))
+      (transport-and-scavenge sym)))
+
+  ;;
+  ;; Reset the bits...
+  (remprop nil 'purify-symbol-bits)
+
+  (do-allocated-symbols (sym %static-space)
+    (remprop sym 'purify-symbol-bits))
+
+  (do-allocated-symbols (sym %dynamic-space)
+    (remprop sym 'purify-symbol-bits))
+
+  (%primitive set-allocation-space %dynamic-space))
+); Compiler-Let
+
+;;;; Save-Stand-Alone-Lisp
+;;;
+;;;    A stand-alone is a lisp that has had everything that doesn't pertain
+;;; to a particular application GC'ed away.  This can result in a drastic
+;;; size reduction, but tends make the Lisp unusable for anything else and
+;;; hard to debug in.  We do this by blowing away all symbols not directly
+;;; referenced and doing a GC.  We also blow away random debug info.
+
+
+(defparameter garbage-properties
+  '(%constant globally-special %constant %fun-documentation %var-documentation
+	      %struct-documentation %type-documentation
+	      %setf-documentation %documentation
+	      setf-method-expander setf-inverse))
+
+;;; Save-Stand-Alone-Lisp  --  Public
+;;;
+(defun save-stand-alone-lisp (file root-function)
+  "Write into File a core file which contains only objects referenced
+  by Root-Function or needed for the basic system.  Root-Function
+  is called when the core file is resumed.  Root-Function should be
+  a symbol rather than an actual function object."
+  (let ((all-packages (list-all-packages)))
+    (fresh-line)
+    (write-string "[Nuking useless stuff")
+    (force-output)
+    ;;
+    ;; Mark all external symbols so that we can find them later...
+    ;; We could do this with a property, but this is more fun.
+    (dolist (p all-packages)
+      (do-external-symbols (s p)
+	(setf (symbol-bits s) 1)))
+    ;;
+    ;; Nuke all hashtables in packages...
+    (dolist (p all-packages)
+      (make-package-hashtable 10 (package-internal-symbols p))
+      (make-package-hashtable 10 (package-external-symbols p)))
+    ;;
+    ;; Nuke random garbage on all symbols...
+    (do-allocated-symbols (s %dynamic-space)
+      ;;
+      ;; Nuke arglists on functions...
+      (when (fboundp s)
+	(let ((fun (symbol-function s)))
+	  (cond ((compiled-function-p fun)
+		 (%primitive header-set fun %function-arg-names-slot ()))
+		((and (consp fun) (compiled-function-p (cdr fun)))
+		 (%primitive header-set (cdr fun) %function-arg-names-slot ())))))
+      ;;
+      ;; Nuke unnecessary properties...
+      (when (symbol-plist s)
+	(dolist (p garbage-properties)
+	  (when (get s p)
+	    (remprop s p)))))
+    (write-string "]
+[GC'ing it away")
+    (force-output)
+    ;;
+    ;; GC it away....
+    (gc nil)
+    (sleep 30)
+    (write-string "]
+[Snoozing for a minute to let dirty pages get written")
+    (force-output)
+    (sleep 60)
+    ;;
+    ;; Rebuild packages...
+    (write-string "]
+[Rebuilding packages")
+    (force-output)
+    (do-allocated-symbols (s %dynamic-space)
+      (let ((p (symbol-package s)))
+	(cond ((null p))
+	      ((zerop (symbol-bits s))
+	       (add-symbol (package-internal-symbols p) s))
+	      (t
+	       (add-symbol (package-external-symbols p) s)
+	       (setf (symbol-bits s) 0)))
+	(remprop s 'purify-symbol-bits)))
+    (do-allocated-symbols (s %static-space)
+      (let ((p (symbol-package s)))
+	(cond ((null p))
+	      ((zerop (symbol-bits s))
+	       (add-symbol (package-internal-symbols p) s))
+	      (t
+	       (add-symbol (package-external-symbols p) s)
+	       (setf (symbol-bits s) 0)))
+	(remprop s 'purify-symbol-bits)))
+    (write-line "]")
+    (purify :root-structures (list root-function))
+    (write-string "[Snoozing for two minutes to let dirty pages get written")
+    (force-output)
+    (sleep 120)
+    (write-line "]")
+    (if (save file)
+	(quit)
+	(funcall root-function))))
diff --git a/code/rand.lisp b/code/rand.lisp
new file mode 100644
index 000000000..9bfbe8841
--- /dev/null
+++ b/code/rand.lisp
@@ -0,0 +1,128 @@
+;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; Functions to random number functions for Spice Lisp 
+;;; Written by David Adam.
+;;;
+;;; The random number functions are part of the standard Spicelisp environment.
+;;;
+;;; **********************************************************************
+;;;
+(in-package 'lisp)
+(export '(random-state random-state-p random *random-state*
+	  make-random-state))
+
+(defconstant random-const-a 8373)
+(defconstant random-const-c 101010101)
+(defconstant random-upper-bound 134217726)
+(defconstant random-max 54)
+(defvar rand-seed 0)
+(defvar *random-state*)
+
+(defstruct (random-state (:constructor make-random-object))
+  (j 24 :type integer)
+  (k 0 :type integer)
+  (seed (make-array (1+ random-max) :initial-contents
+		    (do ((list-rands () (cons (rand1) list-rands))
+			 (i 0 (1+ i)))
+			((> i random-max) list-rands)))
+	:type simple-vector))
+
+
+;;; Generates a random number from rand-seed.
+(defun rand1 ()
+   (setq rand-seed (mod (+ (* rand-seed random-const-a) random-const-c)
+			(1+ random-upper-bound))))
+
+;;; rand3  --  Internal
+;;;
+;;; This function generates fixnums between 0 and random-upper-bound, 
+;;; inclusive For the algorithm to work random-upper-bound must be an 
+;;; even positive fixnum.  State is the random state to use.
+;;;
+(defun rand3 (state)
+  (let ((seed (random-state-seed state))
+	(j (random-state-j state))
+	(k (random-state-k state)))
+    (declare (fixnum j k) (simple-vector seed))
+    (setf (svref seed k)
+	  (let ((a (- random-upper-bound
+		      (svref seed
+			      (setf (random-state-j state)
+				    (if (= j 0) random-max (1- j))))
+		      (svref seed
+			      (setf (random-state-k state)
+				    (if (= k 0) random-max (1- k)))))))
+	    (if (minusp a) (- a) (- random-upper-bound a))))))
+
+
+(defun random-init ()
+  (setq *random-state*
+	(make-random-object :seed
+	 (make-array (1+ random-max) :initial-contents
+		     '(45117816 133464727 86324180 99419799 68851957 87250180
+		      52971860 84081967 30854110 121122797 70449044 18801152
+		      45149898 15881380 27398356 117706009 49915564 80620628
+		      120974070 98193932 43883764 53717012 100954825 82579490
+		      17280729 118523949 42282975 127220348 6288263 56575578
+		      2474156 47934425 561006 21989698 74046730 105055318
+		      113363907 48749716 78183593 109613585 37323232 65101428
+		      46453209 76906562 5371267 86544820 33922642 60765033
+		      41889257 77176406 38775255 78514879 72553872 66916641
+		      100613180)))))
+
+(defun copy-state (cur-state)
+  (let ((state (make-random-object
+		:seed (make-array 55)
+		:j (random-state-j cur-state)
+		:k (random-state-k cur-state))))
+    (do ((i 0 (1+ i)))
+	((= i 55) state)
+      (declare (fixnum i))
+      (setf (aref (random-state-seed  state) i)
+	    (aref (random-state-seed cur-state) i)))))
+
+(defun make-random-state (&optional state)
+  "Make a random state object.  If State is not supplied, return a copy
+  of the default random state.  If State is a random state, then return a
+  copy of it.  If state is T then return a random state generated from
+  the universal time."
+  (cond ((not state) (copy-state *random-state*))
+	((random-state-p state) (copy-state state))
+	((eq state t) (setq rand-seed (get-universal-time))
+		      (make-random-object))
+	(t (error "Bad argument, ~A, for RANDOM-STATE." state))))
+
+(proclaim '(ftype (function (t) fixnum) rand3))
+(defun random (arg &optional (state *random-state*))
+  "Generate a uniformly distributed pseudo-random number between zero
+  and Arg.  State, if supplied, is the random state to use."
+  (typecase arg
+    (fixnum
+     (unless (plusp (the fixnum arg))
+       (error "Non-positive argument, ~A, to RANDOM." arg))     
+     (rem (the fixnum (rand3 state)) (the fixnum arg)))
+    (float
+     (unless (plusp arg)
+       (error "Non-positive argument, ~A, to RANDOM." arg))
+     (let ((arg-length (typecase arg
+			 (short-float %short-float-mantissa-length)
+			 (single-float %single-float-mantissa-length)
+			 (double-float %double-float-mantissa-length)
+			 (long-float %long-float-mantissa-length))))
+       (* arg (/ (float (random (ash 2 arg-length) state))
+		 (float (ash 2 arg-length))))))
+    (integer
+     (unless (plusp arg)
+       (error "Non-positive argument, ~A, to RANDOM." arg))
+     (do ((tot (rand3 state) (+ (ash tot %fixnum-length) (rand3 state)))
+	  (end (ash arg (- %fixnum-length))
+	       (ash end (- %fixnum-length))))
+	 ((zerop end) (mod tot arg))))
+    (t (error "Wrong type argument, ~A, to RANDOM." arg))))
diff --git a/code/reader.lisp b/code/reader.lisp
new file mode 100644
index 000000000..d6827f54d
--- /dev/null
+++ b/code/reader.lisp
@@ -0,0 +1,1302 @@
+;;; -*- Log: code.log; Package: Lisp -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; Spice Lisp Reader 
+;;; Written by David Dill
+;;; Package system interface by Lee Schumacher.
+;;; Runs in the standard Spice Lisp environment.
+;;;
+(in-package 'lisp)
+(export '(readtable readtablep *read-base* *readtable* copy-readtable 
+	  set-syntax-from-char set-macro-character get-macro-character
+	  make-dispatch-macro-character set-dispatch-macro-character
+	  get-dispatch-macro-character
+	  read *read-default-float-format* read-preserving-whitespace
+	  read-delimited-list parse-integer read-from-string *read-suppress*))
+
+;;;Random global variables
+
+(defvar *read-default-float-format* 'single-float "Float format for 1.0E1")
+
+(defvar *readtable* () "Variable bound to current readtable.")
+
+
+
+;;;; Readtable implementation.
+
+;;; The readtable is a structure with three components: the
+;;; CHARACTER-ATTRIBUTE-TABLE is a vector of 128 integers for describing the
+;;; character type.  Conceptually, there are 4 distinct "primary" character
+;;; attributes (WHITESPACE, TERMINATING-MACRO, ESCAPE, and CONSTITUENT --
+;;; non-terminating macros have the attribute CONSTITUENT, and the symbol
+;;; reader is implemented as a non-terminating macro), and a number of
+;;; "secondary" attributes that are used by the function READ-QUALIFIED-TOKEN,
+;;; which apply only when the primary attribute is CONSTITUENT.  In order to
+;;; make the READ-QUALIFIED-TOKEN fast, all this information is stored in the
+;;; character attribute table by having different varieties of constituents.
+;;; In order to conform with the white pages, the primary attributes should be
+;;; moved by SET-SYNTAX-FROM-CHARACTER and SET-MACRO-CHARACTER, while the
+;;; secondary attributes are constant properties of the characters (as long as
+;;; they are constituents).
+
+
+;;; The CHARACTER-MACRO-TABLE is a vector of 128 functions.  One of these
+;;; functions called with appropriate arguments whenever any non-WHITESPACE
+;;; character is encountered inside READ-PRESERVING-WHITESPACE.  These
+;;; functions are used to implement user-defined read-macros, system
+;;; read-macros, and the number-symbol reader.  Finally, there is a
+;;; DISPATCH-TABLES entry, which is an alist from dispatch characters to
+;;; vectors of 128 functions, for use in defining dispatching macros (like
+;;; #-macro).
+
+(defvar std-lisp-readtable ()
+  "Standard lisp readtable. This is for recovery from broken
+   read-tables, and should not normally be user-visible.")
+
+(defstruct (readtable
+	    (:conc-name nil)
+	    (:predicate readtablep)
+	    (:copier nil))
+  "Readtable is a data structure that maps characters into syntax
+   types for the Common Lisp expression reader."
+  (character-attribute-table (make-character-attribute-table) :type simple-vector)
+  (character-macro-table (make-character-macro-table) :type simple-vector)
+  (dispatch-tables () :type list))
+
+
+
+;;;; Constants for character attributes.  These are all as in the manual.
+
+(eval-when (compile load eval)
+  (defconstant whitespace 0)
+  (defconstant terminating-macro 1)
+  (defconstant escape 2)
+  (defconstant constituent 3)
+  (defconstant constituent-dot 4)
+  (defconstant constituent-expt 5)
+  (defconstant constituent-slash 6)
+  (defconstant constituent-digit 7)
+  (defconstant constituent-sign 8)
+  (defconstant sharp-sign 9)
+  (defconstant multiple-escape 10)
+  (defconstant package-delimiter 11)
+  ;;fake attribute for use in read-unqualified-token
+  (defconstant delimiter 12))
+
+
+
+;;;; Package specials.
+
+(defvar *old-package* ()
+  "Value of *package* at the start of the last read or Nil.")
+
+;;; In case we get an error trying to parse a symbol, we want to rebind the
+;;; above stuff so it's cool.
+
+(proclaim '(special *package* *keyword-package* *read-base*))
+
+
+
+;;;; Macros and functions for character tables.
+
+(defmacro get-cat-entry (char rt)
+  ;;only give this side-effect-free args.
+  `(elt (the simple-vector (character-attribute-table ,rt))
+	(char-int ,char)))
+
+(defun set-cat-entry (char newvalue &optional (rt *readtable*))
+  (setf (elt (the simple-vector (character-attribute-table rt))
+	     (char-int char))
+	newvalue))
+
+(defmacro get-cmt-entry (char rt)
+  `(elt (the simple-vector (character-macro-table ,rt))
+	(char-int ,char)))
+
+(defun set-cmt-entry (char newvalue &optional (rt *readtable*))
+  (setf (elt (the simple-vector (character-macro-table rt))
+	     (char-int char))
+	newvalue))
+
+(defun make-character-attribute-table ()
+  (make-array 256 :element-type t :initial-element #.constituent))
+
+(defun make-character-macro-table ()
+  (make-array 256 :element-type t
+		      :initial-element #'undefined-macro-char))
+
+(defun undefined-macro-char (ignore char)
+  (declare (ignore ignore))
+  (error "Undefined read-macro character ~S" char))
+
+
+;;; The character attribute table is a 128-long vector of integers. 
+
+(defmacro test-attribute (char whichclass rt)
+  `(= (the fixnum (get-cat-entry ,char ,rt)) ,whichclass)))
+
+;;; Predicates for testing character attributes
+
+;;; Make this a function, since other people want to use it.
+;;;
+(proclaim '(inline whitespacep))
+(defun whitespacep (char &optional (rt *readtable*))
+  (test-attribute char whitespace rt))
+
+(defmacro constituentp (char &optional (rt '*readtable*))
+  `(>= (get-cat-entry ,char ,rt) #.constituent))
+
+(defmacro terminating-macrop (char &optional (rt '*readtable*))
+  `(test-attribute ,char #.terminating-macro ,rt))
+
+(defmacro escapep (char &optional (rt '*readtable*))
+  `(test-attribute ,char #.escape ,rt))
+
+(defmacro multiple-escape-p (char &optional (rt '*readtable*))
+  `(test-attribute ,char #.multiple-escape ,rt))
+
+(defmacro token-delimiterp (char &optional (rt '*readtable*))
+  ;;depends on actual attribute numbering above.
+  `(<= (get-cat-entry ,char ,rt) #.terminating-macro))
+
+
+
+;;;; Secondary attribute table.
+
+(defvar secondary-attribute-table ())
+
+(defun set-secondary-attribute (char attribute)
+  (setf (elt (the simple-vector secondary-attribute-table) (char-int char))
+	attribute))
+
+
+(defun init-secondary-attribute-table ()
+  (setq secondary-attribute-table
+	(make-array 128 :element-type t
+			    :initial-element #.constituent))
+  (set-secondary-attribute #\: #.package-delimiter)
+  (set-secondary-attribute #\| #.multiple-escape)	; |) [For EMACS]
+  (set-secondary-attribute #\. #.constituent-dot)
+  (set-secondary-attribute #\+ #.constituent-sign)
+  (set-secondary-attribute #\- #.constituent-sign)
+  (set-secondary-attribute #\/ #.constituent-slash)  
+  (do ((i (char-int #\0) (1+ i)))
+      ((> i (char-int #\9)))
+    (set-secondary-attribute (int-char i) #.constituent-digit))
+  (set-secondary-attribute #\E #.constituent-expt)
+  (set-secondary-attribute #\F #.constituent-expt)
+  (set-secondary-attribute #\D #.constituent-expt)
+  (set-secondary-attribute #\S #.constituent-expt)
+  (set-secondary-attribute #\L #.constituent-expt)
+  (set-secondary-attribute #\e #.constituent-expt)
+  (set-secondary-attribute #\f #.constituent-expt)
+  (set-secondary-attribute #\d #.constituent-expt)
+  (set-secondary-attribute #\s #.constituent-expt)
+  (set-secondary-attribute #\l #.constituent-expt))
+
+(defmacro get-secondary-attribute (char)
+  `(elt (the simple-vector secondary-attribute-table)
+	(char-int ,char)))
+
+
+
+;;;; Readtable operations.
+
+(defun copy-readtable (&optional (from-readtable *readtable*) to-readtable)
+  "A copy is made of from-readtable and place into to-readtable."
+  (if (null from-readtable) (setq from-readtable std-lisp-readtable))
+  (if (null to-readtable) (setq to-readtable (make-readtable)))
+  ;;physically clobber contents of internal tables.
+  (replace (character-attribute-table to-readtable)
+	   (character-attribute-table from-readtable))
+  (replace (character-macro-table to-readtable)
+	   (character-macro-table from-readtable))
+  (setf (dispatch-tables to-readtable)
+	(mapcar #'(lambda (pair) (cons (car pair)
+				       (copy-seq (cdr pair))))
+		(dispatch-tables from-readtable)))
+  to-readtable)
+
+(defun set-syntax-from-char (to-char from-char &optional
+				     (to-readtable *readtable*)
+				     (from-readtable ()))
+  "Causes the syntax of to-char to be the same as from-char in the 
+   optional readtable (defaults to the current readtable).  The
+   from-table defaults the standard lisp readtable by being nil."
+  (if (null from-readtable) (setq from-readtable std-lisp-readtable))
+  ;;copy from-char entries to to-char entries, but make sure that if
+  ;;from char is a constituent you don't copy non-movable secondary
+  ;;attributes (constituent types), and that said attributes magically
+  ;;appear if you transform a non-constituent to a constituent.
+  (let ((att (get-cat-entry from-char from-readtable)))
+    (if (constituentp from-char from-readtable)
+	(setq att (get-secondary-attribute to-char)))
+    (set-cat-entry to-char att to-readtable)
+    (set-cmt-entry to-char
+		   (get-cmt-entry from-char from-readtable)
+		   to-readtable)
+    NIL))
+
+(defun set-macro-character (char function &optional
+				 (non-terminatingp nil) (rt *readtable*))
+  "Causes char to be a macro character which invokes function when
+   seen by the reader.  The non-terminatingp flag can be used to
+   make the macro character non-terminating.  The optional readtable
+   argument defaults to the current readtable.  Set-macro-character
+   returns T."
+  (if non-terminatingp
+      (set-cat-entry char (get-secondary-attribute char) rt)
+      (set-cat-entry char #.terminating-macro rt))
+  (set-cmt-entry char function rt)
+  T)
+
+(defun get-macro-character (char &optional (rt *readtable*))
+  "Returns the function associated with the specified char
+   which is a macro character.  The optional readtable argument
+   defaults to the current readtable."
+  ;;check macro syntax, return associated function if it's there.
+  ;;returns a value for all constituents.
+  (cond ((constituentp char)
+	 (values (get-cmt-entry char rt) t))
+	((terminating-macrop char)
+	 (values (get-cmt-entry char rt) nil))
+	(t nil)))
+
+
+
+;;;; These definitions support internal programming conventions.
+
+(defconstant eof-object '(*eof*))
+
+(defmacro eofp (char) `(eq ,char eof-object))
+
+(defun flush-whitespace (stream)
+  ;;This flushes whitespace chars, returning the last char it read (a non-white
+  ;;one).  It always gets an error on end-of-file.
+  (prepare-for-fast-read-char stream
+    (do ((attribute-table (character-attribute-table *readtable*))
+	 (char (fast-read-char t) (fast-read-char t)))
+      ((/= (the fixnum (svref attribute-table (char-int char))) #.whitespace)
+       (done-with-fast-read-char)
+       char))))
+
+
+
+;;;; Temporary initialization hack.
+
+(defun init-std-lisp-readtable ()
+  (setq std-lisp-readtable (make-readtable))
+  ;;all characters default to "constituent" in make-readtable
+  ;;*** un-constituent-ize some of these ***
+  (let ((*readtable* std-lisp-readtable))
+    (set-cat-entry #\tab #.whitespace)
+    (set-cat-entry #\linefeed #.whitespace)  
+    (set-cat-entry #\space #.whitespace)
+    (set-cat-entry #\page #.whitespace)
+    (set-cat-entry #\return #.whitespace)
+    (set-cat-entry #\\ #.escape)
+    (set-cmt-entry #\\ #'read-token)
+    (set-cat-entry #\rubout #.whitespace)
+    (set-cmt-entry #\: #'read-token)
+    (set-cmt-entry #\| #'read-token)
+    ;;macro definitions
+    (set-macro-character #\" #'read-string)
+    ;;* # macro
+    (set-macro-character #\' #'read-quote)
+    (set-macro-character #\( #'read-list)
+    (set-macro-character #\) #'read-right-paren)
+    (set-macro-character #\; #'read-comment)
+    ;;* backquote
+    ;;all constituents
+    (do ((ichar 0 (1+ ichar))
+	 (char))
+	((= ichar #O200))
+      (setq char (int-char ichar))
+      (when (constituentp char std-lisp-readtable)
+	    (set-cat-entry char (get-secondary-attribute char))
+	    (set-cmt-entry char #'read-token)))))
+
+
+
+;;;; read-buffer implementation.
+
+(defvar read-buffer)
+(defvar read-buffer-length)
+
+(defvar inch-ptr)
+(defvar ouch-ptr)
+
+(defmacro reset-read-buffer ()
+  ;;turn read-buffer into an empty read-buffer.
+  ;;ouch-ptr always points to next char to write
+  `(progn
+    ;;next is in case interrupt processor has re-bound read-buffer to nil.
+    (unless (or (boundp 'read-buffer) read-buffer) (init-read-buffer))
+    (setq ouch-ptr 0)
+    ;;inch-ptr always points to next char to read
+    (setq inch-ptr 0)))
+
+(defun init-read-buffer ()
+  (setq read-buffer (make-string 512))			;initial bufsize
+  (setq read-buffer-length 512)
+  (reset-read-buffer))
+
+(defmacro ouch-read-buffer (char)
+  `(progn
+    (if (>= (the fixnum ouch-ptr)
+	    (the fixnum read-buffer-length))
+	;;buffer overflow -- double the size
+	(grow-read-buffer))
+    (setf (elt (the simple-string read-buffer) ouch-ptr) ,char)
+    (setq ouch-ptr (1+ ouch-ptr))))
+;; macro to move ouch-ptr back one.
+(defmacro ouch-unread-buffer ()
+  '(if (> (the fixnum ouch-ptr) (the fixnum inch-ptr))
+       (setq ouch-ptr (1- (the fixnum ouch-ptr)))))
+
+(defun grow-read-buffer ()
+  (let ((rbl (length (the simple-string read-buffer))))
+    (declare (fixnum rbl))
+    (setq read-buffer
+	  (concatenate 'simple-string
+		       (the simple-string read-buffer)
+		       (the simple-string (make-string rbl))))
+    (setq read-buffer-length (* 2 rbl))))
+
+(defun inchpeek-read-buffer ()
+  (if (>= (the fixnum inch-ptr) (the fixnum ouch-ptr))
+      eof-object
+      (elt (the simple-string read-buffer) inch-ptr)))
+
+(defun inch-read-buffer ()
+  (cond ((>= (the fixnum inch-ptr) (the fixnum ouch-ptr))
+	 eof-object)
+	(t (prog1 (elt (the simple-string read-buffer) inch-ptr)
+		  (setq inch-ptr (1+ (the fixnum inch-ptr)))))))
+
+(defmacro unread-buffer ()
+  `(decf (the fixnum inch-ptr)))
+
+(defun read-unwind-read-buffer ()
+  ;;keep contents, but make next (inch..) return first char.
+  (setq inch-ptr 0))
+
+(defun read-buffer-to-string ()
+  (subseq (the simple-string read-buffer) 0 ouch-ptr))
+
+
+
+;;;; READ-PRESERVING-WHITESPACE, READ-DELIMITED-LIST, and READ.
+
+(defvar *real-eof-errorp* ()
+  "Value checked by reader if recursivep is true.")
+(defvar *real-eof-value* ()
+  "Eof-value used for eof-value if recursivep is true.")
+
+(defvar right-paren-whitespace t
+  "Flag that READ uses to tell when it's ok to treat right parens as
+  whitespace.")
+
+;; Alist for sharp-equal. Used to keep track of objects with labels assigned
+;; that have been completly read.
+(defvar sharp-equal-alist ())
+
+;; Alist for sharp-sharp. Assoc's a number with a symbol produced by gensym.
+;; Used by sharp-sharp as an unforgeable label, instead of the number.
+(defvar sharp-sharp-alist ())
+
+(proclaim '(special *standard-input*))
+ 
+;;; READ-PRESERVING-WHITESPACE behaves just like read only it makes sure
+;;; to leave terminating whitespace in the stream.
+;;;
+(defun read-preserving-whitespace
+  (&optional (stream *standard-input*) (eof-errorp t) (eof-value ())
+	     (recursivep ()))
+  "Reads from stream and returns the object read, preserving the whitespace
+  that followed the object."
+  (let ((*real-eof-value* *real-eof-value*)
+	(*real-eof-errorp* *real-eof-errorp*))
+   (if recursivep
+       (setq eof-errorp *real-eof-errorp*
+	     eof-value *real-eof-value*)
+       (setq *real-eof-value* eof-value
+	     *real-eof-errorp* eof-errorp
+	     ;; The scope of these two lists is the top level read, so they
+	     ;; have to be reset here.
+	     sharp-equal-alist nil
+	     sharp-sharp-alist nil))
+   (progn
+    ;;loop for repeating when a macro returns nothing.
+    (do ((char (read-char stream nil eof-object)
+	       (read-char stream nil eof-object)))
+	(())
+	(cond ((eofp char)
+	       (if eof-errorp
+		   (error "Unexpected end-of-file encountered.")
+		   (return eof-value)))
+	      ((whitespacep char))
+	      (t
+	       (let* ((macrofun (get-cmt-entry char *readtable*))
+		      (result (multiple-value-list
+			       (funcall macrofun stream char))))
+		 ;;repeat if macro returned nothing.
+		 (if result (return (car result))))))))))
+
+(defun read-maybe-nothing (stream char)
+  ;;returns nil or a list with one thing, depending.
+  ;;for functions that want comments to return so they can look
+  ;;past them.  Assumes char is not whitespace.
+  (let ((retval (multiple-value-list
+		 (funcall (get-cmt-entry char *readtable*) stream char))))
+    (if retval (rplacd retval nil))))
+
+(defun read (&optional (stream *standard-input*) (eof-errorp t)
+			   (eof-value ()) (recursivep ()))
+  "Reads in the next object in the stream, which defaults to
+  *standard-input*. For details see the I/O chapter of
+  the manual."
+   (prog1
+    (read-preserving-whitespace stream eof-errorp eof-value recursivep)
+    (let ((whitechar (read-char stream nil eof-object)))
+      (if (and (not (eofp whitechar))
+	       (or (not (whitespacep whitechar))
+		   recursivep))
+	  (unread-char whitechar stream)))))
+
+(defun read-delimited-list (endchar &optional
+				    (input-stream *standard-input*)
+				    recursive-p)
+  "Reads objects from input-stream until the next character after an
+   object's representation is endchar.  A list of those objects read
+   is returned."
+  (declare (ignore recursive-p))
+  (do ((char (flush-whitespace input-stream)
+	     (flush-whitespace input-stream))
+       (retlist ()))
+      ((char= char endchar) (nreverse retlist))
+    (setq retlist (nconc (read-maybe-nothing input-stream char) retlist))))
+
+
+
+;;;; Standard ReadMacro definitions to implement the reader.
+
+(defun read-quote (stream ignore)
+  (declare (ignore ignore))
+  (list 'quote (read stream () () t)))
+
+(defun read-comment (stream ignore)
+  (declare (ignore ignore))
+  (prepare-for-fast-read-char stream
+    (do ((char (fast-read-char nil nil)
+	       (fast-read-char nil nil)))
+	((or (not char) (char= char #\newline))
+	 (done-with-fast-read-char))))
+  ;;don't return anything
+  (values))
+
+(defun read-list (stream ignore)
+  (declare (ignore ignore))
+  (let* ((thelist (list nil))
+	 (listtail thelist))
+    (do ((firstchar (flush-whitespace stream) (flush-whitespace stream)))
+	((char= firstchar #\) ) (cdr thelist))
+      (when (char= firstchar #\.)
+	    (let ((nextchar (read-char stream t)))
+	      (cond ((token-delimiterp nextchar)
+		     (cond ((eq listtail thelist)
+			    (error "Nothing appears before . in list."))
+			   ((whitespacep nextchar)
+			    (setq nextchar (flush-whitespace stream))))
+		     (rplacd listtail
+			     ;;return list containing last thing.
+			     (car (read-after-dot stream nextchar)))
+		     (return (cdr thelist)))
+		    ;;put back nextchar so we can read it normally.
+		    (t (unread-char nextchar stream)))))
+      ;;next thing is not an isolated dot.
+      (let ((listobj (read-maybe-nothing stream firstchar)))
+	;;allows the possibility that a comment was read.
+	(when listobj
+	      (rplacd listtail listobj)
+	      (setq listtail listobj))))))
+
+(defun read-after-dot (stream firstchar)
+  ;;firstchar is non-whitespace!
+  (let ((lastobj ()))
+    (do ((char firstchar (flush-whitespace stream)))
+	((char= char #\) )
+	 (error "Nothing appears after . in list."))
+      ;;see if there's something there.
+      (setq lastobj (read-maybe-nothing stream char))
+      (when lastobj (return t)))
+    ;;at least one thing appears after the dot.
+    ;;check for more than one thing following dot.
+    (do ((lastchar (flush-whitespace stream)
+		   (flush-whitespace stream)))
+	((char= lastchar #\) ) lastobj)	;success!
+      ;;try reading virtual whitespace
+      (if (read-maybe-nothing stream lastchar)
+	  (error "More than one object follows . in list.")))))
+
+(defun read-string (stream closech)
+  ;;this accumulates chars until it sees same char that invoked it.
+  ;;for a very long string, this could end up bloating the read buffer.
+  (reset-read-buffer)
+  (prepare-for-fast-read-char stream
+    (do ((char (fast-read-char t) (fast-read-char t)))
+	((char= char closech)
+	 (done-with-fast-read-char))
+      (if (escapep char) (setq char (fast-read-char t)))
+      (ouch-read-buffer char)))
+  (read-buffer-to-string))
+
+(defun read-right-paren (ig1 ig2)
+  (declare (ignore ig1 ig2))
+  (if right-paren-whitespace
+      (values)
+      (error "Unmatched right parenthesis.")))
+
+(defun internal-read-extended-token (stream firstchar
+					    &aux (escape-appearedp nil))
+  ;;read the string up to the next delimiter.  Leaves resulting token
+  ;;in read-buffer, returns a flag that is true if an escape (\\)
+  ;;appeared, meaning that it has to be a symbol.
+  ;;needs to have package hacks added.
+  (reset-read-buffer)
+  (do ((char firstchar (read-char stream nil eof-object)))
+      ;;for now, treat #\: as a constituent:
+      ;; does this cond need same fix as the top-level read did ??
+      ((cond ((eofp char) t)
+	     ((token-delimiterp char)
+	      (unread-char char stream)
+	      t)
+	     (t nil))
+       escape-appearedp)
+    (cond ((escapep char)
+	   ;;it can't be a number, even if it's 1\23.
+	   (setq escape-appearedp t)
+	   ;;read next char here, so it won't be upper-casified.
+	   (let ((nextchar (read-char stream nil eof-object)))
+	     (if (eofp nextchar)
+		 (error "End-of-file after escape character.")
+		 (ouch-read-buffer nextchar))))
+	  (t (ouch-read-buffer (char-upcase char))))))
+
+
+
+;;;; Character classes.
+
+;;; return the character class for a char
+;;;
+(defmacro char-class (char attable)
+  `(let ((att (svref ,attable (char-int ,char))))
+     (declare (fixnum att))
+     (if (<= att #.terminating-macro)
+	 #.delimiter
+	 att)))
+
+;;; return the character class for a char which might be part of a rational
+;;; number
+;;;
+(defmacro char-class2 (char attable)
+  `(let ((att (svref ,attable (char-int ,char))))
+     (declare (fixnum att))
+     (if (<= att #.terminating-macro)
+	 #.delimiter
+	 (if (digit-char-p ,char *read-base*)
+	     constituent-digit
+	     (if (= att constituent-digit)
+		 constituent
+		 att)))))
+
+;;; return the character class for a char which might be part of a rational or
+;;; floating number (assume that it is a digit if it could be)
+;;;
+(defmacro char-class3 (char attable)
+  `(let ((att (svref ,attable (char-int ,char))))
+     (declare (fixnum att))
+     (if possibly-rational
+	 (setq possibly-rational
+	       (or (digit-char-p ,char *read-base*)
+		   (= att constituent-slash))))
+     (if possibly-float
+	 (setq possibly-float
+	       (or (digit-char-p ,char 10)
+		   (= att constituent-dot))))
+     (if (<= att #.terminating-macro)
+	 #.delimiter
+	 (if (digit-char-p ,char (max *read-base* 10))
+	     (if (digit-char-p ,char *read-base*)
+		 constituent-digit
+		 constituent)
+	     att))))
+
+
+
+;;;; Token fetching.
+
+#|
+(defmacro backup-char (char stream)
+  `(if ,char (unread-char ,char ,stream)))
+|#
+
+(defvar *read-suppress* nil 
+  "Suppresses most interpreting of the reader when T")
+
+(defvar *read-base* 10
+  "The radix that Lisp reads numbers in.")
+
+(defun read-token (stream firstchar)
+  "This function is just an fsm that recognizes numbers and symbols."
+  ;;check explicitly whether firstchar has entry for non-terminating
+  ;;in character-attribute-table and read-dot-number-symbol in CMT.
+  ;;Report an error if these are violated (if we called this, we want
+  ;;something that is a legitimate token!).
+  ;;read in the longest possible string satisfying the bnf for
+  ;;"unqualified-token".  Leave the result in the READ-BUFFER.
+  ;;Return next char after token (last char read).
+  (if *read-suppress*
+      (internal-read-extended-token stream firstchar)
+  (let ((attribute-table (character-attribute-table *readtable*))
+	(package *package*)
+	(colons 0)
+	(possibly-rational t)
+	(possibly-float t))
+    (reset-read-buffer)
+    (prog ((char firstchar))
+      (case (char-class3 char attribute-table)
+	(#.constituent-sign (go SIGN))
+	(#.constituent-digit (go LEFTDIGIT))
+	(#.constituent-dot (go FRONTDOT))
+	(#.escape (go ESCAPE))
+	(#.package-delimiter (go COLON))
+	(#.multiple-escape (go MULT-ESCAPE))
+	;;can't have eof, whitespace, or terminating macro as first char!
+	(t (go SYMBOL)))
+     SIGN
+      ;;saw "sign"
+      (ouch-read-buffer char)
+      (setq char (read-char stream nil nil))
+      (unless char (go RETURN-SYMBOL))
+      (setq possibly-rational t
+	    possibly-float t)
+      (case (char-class3 char attribute-table)
+	(#.constituent-digit (go LEFTDIGIT))
+	(#.constituent-dot (go SIGNDOT))
+	(#.escape (go ESCAPE))
+	(#.package-delimiter (go COLON))
+	(#.multiple-escape (go MULT-ESCAPE))	
+	(#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
+	(t (go SYMBOL)))
+     LEFTDIGIT
+      ;;saw "[sign] {digit}+"
+      (ouch-read-buffer (char-upcase char))
+      (setq char (read-char stream nil nil))
+      (unless char (return (make-integer)))
+      (case (char-class3 char attribute-table)
+	(#.constituent-digit (go LEFTDIGIT))
+	(#.constituent-dot (if possibly-float
+			       (go MIDDLEDOT)
+			       (go SYMBOL)))
+	(#.constituent-expt (go EXPONENT))
+	(#.constituent-slash (if possibly-rational
+				 (go RATIO)
+				 (go SYMBOL)))
+	(#.delimiter (unread-char char stream) (return (make-integer)))
+	(#.escape (go ESCAPE))
+	(#.multiple-escape (go MULT-ESCAPE))
+	(#.package-delimiter (go COLON))
+	(t (go SYMBOL)))
+     MIDDLEDOT
+      ;;saw "[sign] {digit}+ dot"
+      (ouch-read-buffer char)
+      (setq char (read-char stream nil nil))
+      (unless char (return (let ((*read-base* 10))
+			     (make-integer))))
+      (case (char-class char attribute-table)
+	(#.constituent-digit (go RIGHTDIGIT))
+	(#.constituent-expt (go EXPONENT))
+	(#.delimiter (unread-char char stream) (return (let ((*read-base* 10))
+							 (make-integer))))
+	(#.escape (go ESCAPE))
+	(#.multiple-escape (go MULT-ESCAPE))
+	(#.package-delimiter (go COLON))
+	(t (go SYMBOL)))
+     RIGHTDIGIT
+      ;;saw "[sign] {digit}* dot {digit}+"
+      (ouch-read-buffer char)
+      (setq char (read-char stream nil nil))
+      (unless char (return (make-float)))
+      (case (char-class char attribute-table)
+	(#.constituent-digit (go RIGHTDIGIT))
+	(#.constituent-expt (go EXPONENT))
+	(#.delimiter (unread-char char stream) (return (make-float)))
+	(#.escape (go ESCAPE))
+	(#.multiple-escape (go MULT-ESCAPE))
+	(#.package-delimiter (go COLON))
+	(t (go SYMBOL)))
+     SIGNDOT
+      ;;saw "[sign] dot"
+      (ouch-read-buffer char)
+      (setq char (read-char stream nil nil))
+      (unless char (go RETURN-SYMBOL))
+      (case (char-class char attribute-table)
+	(#.constituent-digit (go RIGHTDIGIT))
+	(#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
+	(#.escape (go ESCAPE))
+	(#.multiple-escape (go MULT-ESCAPE))
+	(t (go SYMBOL)))
+     FRONTDOT
+      ;;saw "dot"
+      (ouch-read-buffer char)
+      (setq char (read-char stream nil nil))
+      (unless char (error "Dot context error."))
+      (case (char-class char attribute-table)
+	(#.constituent-digit (go RIGHTDIGIT))
+	(#.constituent-dot (go DOTS))
+	(#.delimiter  (error "Dot context error."))
+	(#.escape (go ESCAPE))
+	(#.multiple-escape (go MULT-ESCAPE))
+	(#.package-delimiter (go COLON))
+	(t (go SYMBOL)))
+     EXPONENT
+      (ouch-read-buffer (char-upcase char))
+      (setq char (read-char stream nil nil))
+      (unless char (go RETURN-SYMBOL))
+      (case (char-class char attribute-table)
+	(#.constituent-sign (go EXPTSIGN))
+	(#.constituent-digit (go EXPTDIGIT))
+	(#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
+	(#.escape (go ESCAPE))
+	(#.multiple-escape (go MULT-ESCAPE))
+	(#.package-delimiter (go COLON))
+	(t (go SYMBOL)))
+     EXPTSIGN
+      ;;we got to EXPONENT, and saw a sign character.
+      (ouch-read-buffer char)
+      (setq char (read-char stream nil nil))
+      (unless char (go RETURN-SYMBOL))
+      (case (char-class char attribute-table)
+	(#.constituent-digit (go EXPTDIGIT))
+	(#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
+	(#.escape (go ESCAPE))
+	(#.multiple-escape (go MULT-ESCAPE))
+	(#.package-delimiter (go COLON))
+	(t (go SYMBOL)))
+     EXPTDIGIT
+      ;;got to EXPONENT, saw "[sign] {digit}+"
+      (ouch-read-buffer char)
+      (setq char (read-char stream nil nil))
+      (unless char (return (make-float)))
+      (case (char-class char attribute-table)
+	(#.constituent-digit (go EXPTDIGIT))
+	(#.delimiter (unread-char char stream) (return (make-float)))
+	(#.escape (go ESCAPE))
+	(#.multiple-escape (go MULT-ESCAPE))
+	(#.package-delimiter (go COLON))
+	(t (go SYMBOL)))
+     RATIO
+      ;;saw "[sign] {digit}+ slash"
+      (ouch-read-buffer char)
+      (setq char (read-char stream nil nil))
+      (unless char (go RETURN-SYMBOL))
+      (case (char-class2 char attribute-table)
+	(#.constituent-digit (go RATIODIGIT))
+	(#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
+	(#.escape (go ESCAPE))
+	(#.multiple-escape (go MULT-ESCAPE))
+	(#.package-delimiter (go COLON))
+	(t (go SYMBOL)))
+     RATIODIGIT
+      ;;saw "[sign] {digit}+ slash {digit}+"
+      (ouch-read-buffer (char-upcase char))
+      (setq char (read-char stream nil nil))
+      (unless char (return (make-ratio)))
+      (case (char-class2 char attribute-table)
+	(#.constituent-digit (go RATIODIGIT))
+	(#.delimiter (unread-char char stream) (return (make-ratio)))
+	(#.escape (go ESCAPE))
+	(#.multiple-escape (go MULT-ESCAPE))
+	(#.package-delimiter (go COLON))
+	(t (go SYMBOL)))
+     DOTS
+      ;;saw "dot {dot}+"
+      (ouch-read-buffer char)
+      (setq char (read-char stream nil nil))
+      (unless char (error "Too many dots."))
+      (case (char-class char attribute-table)
+	(#.constituent-dot (go DOTS))
+	(#.delimiter (unread-char char stream) (error "Too many dots."))
+	(#.escape (go ESCAPE))
+	(#.multiple-escape (go MULT-ESCAPE))
+	(#.package-delimiter (go COLON))
+	(t (go SYMBOL)))
+     SYMBOL
+      ;;not a dot, dots, or number.
+      (prepare-for-fast-read-char stream
+	(prog ()
+	 SYMBOL-LOOP
+	  (ouch-read-buffer (char-upcase char))
+	  (setq char (fast-read-char nil nil))
+	  (unless char (go RETURN-SYMBOL))
+	  (case (char-class char attribute-table)
+	    (#.escape (done-with-fast-read-char)
+		      (go ESCAPE))
+	    (#.delimiter (done-with-fast-read-char)
+			 (unread-char char stream)
+			 (go RETURN-SYMBOL))
+	    (#.multiple-escape (done-with-fast-read-char)
+			       (go MULT-ESCAPE))
+	    (#.package-delimiter (done-with-fast-read-char)
+				 (go COLON))
+	    (t (go SYMBOL-LOOP)))))
+     ESCAPE
+      ;;saw an escape.
+      ;;don't put the escape in the read-buffer.
+      ;;read-next char, put in buffer (no case conversion).
+      (let ((nextchar (read-char stream nil nil)))
+	(if nextchar
+	    (ouch-read-buffer nextchar)
+	    (error "End-of-file after escape character.")))
+      (setq char (read-char stream nil nil))
+      (unless char (go RETURN-SYMBOL))
+      (case (char-class char attribute-table)
+	(#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
+	(#.escape (go ESCAPE))
+	(#.multiple-escape (go MULT-ESCAPE))
+	(#.package-delimiter (go COLON))
+	(t (go SYMBOL)))
+      MULT-ESCAPE
+      (do ((char (read-char stream t) (read-char stream t)))
+	  ((multiple-escape-p char))
+	(if (escapep char) (setq char (read-char stream t)))
+	(ouch-read-buffer char))
+      (setq char (read-char stream nil nil))
+      (unless char (go RETURN-SYMBOL))
+      (case (char-class char attribute-table)
+	(#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
+	(#.escape (go ESCAPE))
+	(#.multiple-escape (go MULT-ESCAPE))
+	(#.package-delimiter (go COLON))
+	(t (go SYMBOL)))
+      COLON
+      (cond ((zerop colons)
+	     (setq colons 1)
+	     (setq package (find-package (read-buffer-to-string)))
+	     (unless package (error "Package ~S not found."
+				    (read-buffer-to-string))))
+	    (t (error "Too many colons in ~S" (read-buffer-to-string))))
+      (reset-read-buffer)
+      (setq char (read-char stream nil nil))
+      (unless char (error "End of file encountered after reading a colon."))
+      (case (char-class char attribute-table)
+	(#.delimiter (unread-char char stream)
+		     (error "Illegal terminating character after a colon, ~S."
+			    char))
+	(#.escape (go ESCAPE))
+	(#.multiple-escape (go MULT-ESCAPE))
+	(#.package-delimiter (go INTERN))
+	(t (go SYMBOL)))
+      INTERN
+      (setq colons 2)
+      (setq char (read-char stream nil nil))
+      (unless char (error "End of file encountered after reading a colon."))
+      (case (char-class char attribute-table)
+	(#.delimiter (unread-char char stream)
+		     (error "Illegal terminating character after a colon, ~S"
+			    char))
+	(#.escape (go ESCAPE))
+	(#.multiple-escape (go MULT-ESCAPE))
+	(#.package-delimiter (error "To many colons after ~S:"
+				    (package-name package)))
+	(t (go SYMBOL)))
+      RETURN-SYMBOL
+      (if (or (zerop colons) (= colons 2) (eq package *keyword-package*))
+	  (return (intern* read-buffer ouch-ptr package))
+	  (multiple-value-bind (symbol test)
+			       (find-symbol* read-buffer ouch-ptr package)
+	    (cond ((eq test :external) (return symbol))
+		  ((null test)
+		   (error "Symbol ~S not found in the ~A package."
+			  (read-buffer-to-string) (package-name package)))
+		  (t (cerror "use symbol anyway."
+			     "The symbol ~S is not external in the ~A package."
+			     (read-buffer-to-string) (package-name package))
+		     (return symbol)))))))))
+
+
+(defun read-extended-token (stream &optional (*readtable* *readtable*))
+  ;;for semi-external use: returns 2 values: the string for the token,
+  ;;and a flag for whether there was an escape char.
+  (let ((firstch (read-char stream nil nil t)))
+    (if firstch
+	(let ((escape-appearedp (internal-read-extended-token stream firstch)))
+	  (values (read-buffer-to-string) escape-appearedp))
+	(values "" nil))))
+
+
+
+;;;; Number reading functions.
+
+(defmacro digit* nil
+  `(do ((ch char (inch-read-buffer)))
+       ((or (eofp ch) (not (digit-char-p ch))) (setq char ch))
+     ;;report if at least one digit is seen:
+     (setq one-digit t)))
+
+(defmacro exponent-letterp (letter)
+  `(memq ,letter '(#\E #\S #\F #\L #\D #\e #\s #\f #\l #\d)))
+
+
+(defvar *integer-reader-safe-digits*
+  '#(NIL NIL
+     26 17 13 11 10 9 8 8 8 7 7 7 7 6 6 6 6 6 6 6 6 5 5 5 5 5 5 5 5 5 5 5 5 5 5)
+  "Holds the mapping of base to 'safe' number of digits to read for a fixnum.")
+
+(defvar *integer-reader-base-power* 
+  '#(NIL NIL
+     67108864 129140163 67108864 48828125 60466176 40353607
+     16777216 43046721 100000000 19487171 35831808 62748517 105413504 11390625
+     16777216 24137569 34012224 47045881 64000000 85766121 113379904 6436343
+     7962624 9765625 11881376 14348907 17210368 20511149 24300000 28629151
+     33554432 39135393 45435424 52521875 60466176)
+  "Holds the largest fixnum power of the base for make-integer.")
+
+#|
+(defun init-integer-reader ()
+  (do ((base 2 (1+ base)))
+      ((> base 36))
+    (let ((digits
+	  (do ((fix (truncate most-positive-fixnum base)
+		    (truncate fix base))
+	       (digits 0 (1+ digits)))
+	      ((zerop fix) digits))))	   
+      (setf (aref *integer-reader-safe-digits* base)
+	    digits
+	    (aref *integer-reader-base-power* base)
+	    (expt base digits)))))
+|#
+
+(defun make-integer ()
+  "Minimizes bignum-fixnum multiplies by reading a 'safe' number of digits, 
+  then multiplying by a power of the base and adding."
+  (let* ((base (if (boundp '*read-base*)
+		  (if (and (fixnump *read-base*)
+			   (<= 1 *read-base* 36))
+		      *read-base*
+		      (error "~A not a valid number for *read-base*."
+			     *read-base*))
+		  10.))
+	 (digits-per (aref *integer-reader-safe-digits* base))
+	 (base-power (aref *integer-reader-base-power* base)) 
+	 (negativep nil)
+	 (number 0))
+    (read-unwind-read-buffer)
+    (let ((char (inch-read-buffer)))
+      (cond ((char= char #\-)
+	     (setq negativep t))
+	    ((char= char #\+))
+	    (t (unread-buffer))))
+    (loop
+     (let ((num 0))
+       (dotimes (digit digits-per)
+	 (let* ((ch (inch-read-buffer)))
+	   (cond ((or (eofp ch) (char= ch #\.))
+		  (return-from make-integer
+			       (let ((Res
+				      (if (zerop number) num
+					  (+ num (* number
+						    (expt base digit))))))
+				 (if negativep (- res) res))))
+		 (t (setq num (+ (digit-char-p ch base) (* num base)))))))
+       (setq number (+ num (* number base-power)))))))
+
+
+
+(defun make-float ()
+  ;;assume that the contents of read-buffer are a legal float, with nothing
+  ;;else after it.
+  (read-unwind-read-buffer)
+  (let ((negative-fraction nil)
+	(number 0)
+	(divisor 1)
+	(negative-exponent nil)
+	(exponent 0)
+	(float-char ()) (char (inch-read-buffer)))
+    (if (cond ((char= char #\+) t)
+	      ((char= char #\-) (setq negative-fraction t)))
+	;;flush it
+	(setq char (inch-read-buffer)))
+    ;;read digits before the dot
+    (do* ((ch char (inch-read-buffer))
+	  (dig (digit-char-p ch) (digit-char-p ch)))
+	 ((not dig) (setq char ch))
+      (setq number (+ (* number 10) dig)))
+    ;;deal with the dot, if it's there.
+    (when (char= char #\.)
+      (setq char (inch-read-buffer))
+      ;;read digits after the dot.
+      (do* ((ch char (inch-read-buffer))
+	    (dig (and (not (eofp ch)) (digit-char-p ch))
+		 (and (not (eofp ch)) (digit-char-p ch))))
+	   ((not dig) (setq char ch))
+	(setq divisor (* divisor 10))
+	(setq number (+ (* number 10) dig))))
+    ;;is there an exponent letter?
+    (cond ((eofp char)
+	   ;;if not, we've read the whole number.
+	   (let ((num (make-float-aux number divisor
+				      *read-default-float-format*)))
+	     (return-from make-float (if negative-fraction (- num) num))))
+	  ((exponent-letterp char)
+	   (setq float-char char)
+	   ;;build exponent
+	   (setq char (inch-read-buffer))
+	   ;;check leading sign
+	   (if (cond ((char= char #\+) t)
+		     ((char= char #\-) (setq negative-exponent t)))
+	       ;;flush sign
+	       (setq char (inch-read-buffer)))
+	   ;;read digits for exponent
+	   (do* ((ch char (inch-read-buffer))
+		 (dig (and (not (eofp ch)) (digit-char-p ch))
+		      (and (not (eofp ch)) (digit-char-p ch))))
+	       ((not dig)
+		(setq exponent (if negative-exponent (- exponent) exponent)))
+	       (setq exponent (+ (* exponent 10) dig)))
+	   ;;generate and return the float, depending on float-char:
+	   (let* ((float-format (case float-char
+				  (#\E *read-default-float-format*)
+				  (#\S 'short-float)
+				  (#\F 'single-float)
+				  (#\D 'double-float)
+				  (#\L 'long-float)))
+		  (num (make-float-aux number divisor float-format)))
+	     (setq num (* num (expt 10 exponent)))
+	     (return-from make-float (if negative-fraction (- num) num))))
+	  ;;should never happen:	
+	  (t (error "Internal error in floating point reader.")))))
+
+(defun make-float-aux (number divisor float-format)
+  (let ((fgcd (gcd number divisor)))
+    (when (/= fgcd 1)
+      (setq number (truncate number fgcd))
+      (setq divisor (truncate divisor fgcd))))
+  (when (= divisor 1)
+    (return-from make-float-aux (coerce number float-format)))
+  (let ((float-digits (case float-format
+			((short-float single-float) 37)
+			((double-float long-float) 307)
+			(t 307)))
+	(digits (round (integer-length number) (log 10 2))))
+    (cond ((<= digits float-digits)
+	   (/ (coerce number float-format)
+	      (coerce divisor float-format)))
+	  (T (let ((adj-amount (expt 10 (- digits float-digits))))
+	       (/ (coerce (round number adj-amount) float-format)
+		  (coerce (round divisor adj-amount) float-format)))))))
+
+(defun make-ratio ()
+  ;;assume read-buffer contains a legal ratio.  Build the number from
+  ;;the string.
+  ;;look for optional "+" or "-".
+  (let ((numerator 0) (denominator 0) (char ()) (negative-number nil))
+    (read-unwind-read-buffer)
+    (setq char (inch-read-buffer))
+    (cond ((char= char #\+)
+	   (setq char (inch-read-buffer)))
+	  ((char= char #\-)
+	   (setq char (inch-read-buffer))
+	   (setq negative-number t)))
+    ;;get numerator
+    (do* ((ch char (inch-read-buffer))
+	  (dig (digit-char-p ch *read-base*)
+	       (digit-char-p ch *read-base*)))
+	 ((not dig))
+	 (setq numerator (+ (* numerator *read-base*) dig)))
+    ;;get denominator
+    (do* ((ch (inch-read-buffer) (inch-read-buffer))
+	  (dig ()))
+	 ((or (eofp ch) (not (setq dig (digit-char-p ch *read-base*)))))
+	 (setq denominator (+ (* denominator *read-base*) dig)))
+    (let ((num (/ numerator denominator)))
+      (if negative-number (- num) num))))
+
+       
+
+;;;; dispatching macro cruft
+
+(defun make-char-dispatch-table ()
+  (make-array 128 :initial-element #'dispatch-char-error))
+
+(defun dispatch-char-error (ig1 sub-char ig2)
+  (declare (ignore ig1 ig2))
+  (error "No dispatch function defined for ~S."	sub-char))
+
+(defun make-dispatch-macro-character (char &optional
+					   (non-terminating-p nil)
+					   (rt *readtable*))
+  "Causes char to become a dispatching macro character in readtable
+   (which defaults to the current readtable).  If the non-terminating-p
+   flag is set to T, the char will be non-terminating.  Make-dispatch-
+   macro-character returns T."
+  (set-macro-character char #'read-dispatch-char non-terminating-p rt)
+  (let* ((dalist (dispatch-tables rt))
+	 (dtable (cdr (find char dalist :test #'char= :key #'car))))
+    (cond (dtable
+	   (error "Dispatch character already exists"))
+	  (t
+	   (setf (dispatch-tables rt)
+	    (push (cons char (make-char-dispatch-table)) dalist))))))
+
+(defun set-dispatch-macro-character
+  (disp-char sub-char function &optional (rt *readtable*))
+  "Causes function to be called whenever the reader reads
+   disp-char followed by sub-char. Set-dispatch-macro-character
+   returns T."
+  ;;get the dispatch char for macro (error if not there), diddle
+  ;;entry for sub-char.
+  (let ((dpair (find disp-char (dispatch-tables rt)
+		     :test #'char= :key #'car)))
+    (if dpair
+	(setf (elt (the simple-vector (cdr dpair))
+		   (char-int sub-char))
+	      function)
+	(error "~S is not a dispatch char." disp-char))))
+
+(defun get-dispatch-macro-character (disp-char sub-char
+					       &optional (rt *readtable*))
+  "Returns the macro character function for sub-char under disp-char
+   or nil if there is no associated function."
+  (let ((dpair (find disp-char (dispatch-tables rt)
+		     :test #'char= :key #'car)))
+    (if dpair
+	(elt (the simple-vector (cdr dpair))
+	     (char-int sub-char))
+	(error "~S is not a dispatch char." disp-char))))
+
+(defun read-dispatch-char (stream char)
+  ;;read some digits
+  (let ((numargp nil)
+	(numarg 0)
+	(sub-char ()))
+    (do* ((ch (read-char stream nil eof-object)
+	      (read-char stream nil eof-object))
+	  (dig ()))
+	 ((or (eofp ch)
+	      (not (setq dig (digit-char-p ch))))
+	  ;;take care of the extra char.
+	  (if (eofp ch)
+	      (error "End-of-file inside dispatch character.")
+	      (setq sub-char ch)))
+	 (setq numargp t)
+	 (setq numarg (+ (* numarg 10) dig)))
+    ;;look up the function and call it.
+    (let ((dpair (find char (dispatch-tables *readtable*)
+		       :test #'char= :key #'car)))
+      (if dpair
+	  (funcall (elt (the simple-vector (cdr dpair))
+			(char-int sub-char))
+		   stream sub-char (if numargp numarg nil))
+	  (error "No dispatch table for dispatch char.")))))
+
+
+
+;;;; READ-FROM-STRING.
+
+(defvar read-from-string-spares ()
+  "A resource of string streams for Read-From-String.")
+
+(defun read-from-string (string &optional eof-error-p eof-value
+				&key (start 0) (end (length string))
+				preserve-whitespace)
+  "The characters of string are successively given to the lisp reader
+   and the lisp object built by the reader is returned.  Macro chars
+   will take effect."
+  (declare (string string))
+  (if (null end) (setq end (length string)))
+  (unless read-from-string-spares
+    (push (internal-make-string-input-stream "" 0 0) read-from-string-spares))
+  (let ((stream (pop read-from-string-spares)))
+    (setf (string-input-stream-string stream) (coerce string 'simple-string))
+    (setf (string-input-stream-current stream) start)
+    (setf (string-input-stream-end stream) end)
+    (unwind-protect
+      (values (if preserve-whitespace
+		  (read-preserving-whitespace stream eof-error-p eof-value)
+		  (read stream eof-error-p eof-value))
+	      (string-input-stream-current stream))
+      (push stream read-from-string-spares))))
+
+
+
+;;;; PARSE-INTEGER.
+
+(defun parse-integer (string &key (start 0) (end (length string))
+			     (radix 10) junk-allowed)
+  "Examine the substring of string delimited by start and end
+   (default to the beginning and end of the string)  It skips over
+   whitespace characters and then tries to parse an integer.  The
+   radix parameter must be between 2 and 36."
+  (declare (fixnum end))
+  (if (null end) (setq end (length string)))
+  (let ((index (do ((i start (1+ i)))
+		   ((= i end)
+		    (if junk-allowed
+			(return-from parse-integer (values nil end))
+			(error "No non-whitespace characters in number.")))
+		 (declare (fixnum i))
+		 (unless (whitespacep (char string i)) (return i))))
+	(minusp nil)
+	(found-digit nil)
+	(result 0))
+    (declare (fixnum index))
+    (let ((char (char string index)))
+      (cond ((char= char #\-)
+	     (setq minusp t)
+	     (incf index))
+	    ((char= char #\+)
+	     (incf index))))
+    (loop
+     (when (= index end) (return nil))
+     (let* ((char (char string index))
+	    (weight (digit-char-p char radix)))
+       (cond (weight
+	      (setq result (+ weight (* result radix))
+		    found-digit t))
+	     (junk-allowed (return nil))
+	     ((whitespacep char)
+	      (do ((jndex (1+ index) (1+ jndex)))
+		  ((= jndex end))
+		(declare (fixnum jndex))
+		(unless (whitespacep (char string jndex))
+		  (error "There's junk in this string: ~S." string)))
+	      (return nil))
+	     (t
+	      (error "There's junk in this string: ~S." string))))
+     (incf index))
+    (values
+     (if found-digit
+	 (if minusp (- result) result)
+	 (if junk-allowed
+	     nil
+	     (error "There's no digits in this string: ~S" string)))
+     index)))
+
+
+
+;;;; Reader initialization code.
+
+(defun reader-init ()
+  (init-read-buffer)
+  (init-secondary-attribute-table)
+  (init-std-lisp-readtable)
+; (init-integer-reader)
+  )
diff --git a/code/save.lisp b/code/save.lisp
new file mode 100644
index 000000000..bc6926cb2
--- /dev/null
+++ b/code/save.lisp
@@ -0,0 +1,114 @@
+;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; Spice Lisp is currently incomplete and under active development.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; Spice Lisp routines to suspend a process and create a core file.
+;;; 
+;;; Written David B. McDonald.
+;;;
+;;;**********************************************************************
+;;;
+;;; To see the format of Spice Lisp core files look at the document
+;;; prva:<slisp.docs>core.mss.
+(in-package "LISP")
+
+(in-package "EXTENSIONS")
+(export '(*environment-list*))
+(defvar *environment-list* nil)
+(in-package "LISP")
+
+
+(proclaim '(special *task-self*))
+
+(defconstant save-block-size (* 64 1024)
+  "Amount to write for each call to write.  This is due to RFS limitations.")
+
+(defvar lisp-environment-list)
+(defvar original-lisp-environment)
+
+;;;; Global state:
+
+(defun save (file)
+  "Save the current lisp core image in a core file.  When it returns in
+  the current process, the number of bytes written is returned.
+  When the saved core image is resumed, Nil is returned."
+  (declare (optimize (speed 3) (safety 0)))
+  (format t "~&[Building saved core image: ")
+  (finish-output)
+  (let ((size-to-allocate (* (current-space-usage) 2)))
+    (declare (fixnum size-to-allocate))
+    (let* ((addr (int-sap (gr-call* mach::vm_allocate *task-self*
+				    0 size-to-allocate t)))
+	   (byte-size (%primitive save *current-alien-free-pointer*
+				  NIL addr)))
+      (cond ((null byte-size)
+	     (mach::vm_deallocate *task-self* addr size-to-allocate)
+	     (error "Save failed."))
+	    ((eq byte-size T)
+	     (dolist (f *before-save-initializations*) (funcall f))
+	     (dolist (f *after-save-initializations*) (funcall f))
+	     (reinit)
+	     (setq original-lisp-environment lisp-environment-list)
+	     (let ((result nil))
+	       (dolist (ele lisp-environment-list
+			    (setf *environment-list* result))
+		 (let ((=pos (position #\= (the simple-string ele))))
+		   ;;
+		   ;; This is dubious since all the strings have an =.
+		   ;; What if one doesn't?  What does that mean?
+		   (when =pos
+		     (push (cons (intern (string-upcase (subseq ele 0 =pos))
+					 *keyword-package*)
+				 (subseq ele (1+ =pos)))
+			   result)))))
+	     NIL)
+	    (T
+	     (format t "~D bytes.~%" byte-size)
+	     (format t "Writing to file: ~A~%" file)
+	     (finish-output)
+	     (multiple-value-bind (fd err) (mach:unix-creat file #o644)
+	       (if (null fd)
+		   (error "Failed to open file ~A, unix error: ~A"
+			  file (mach:get-unix-error-msg err)))
+	       
+	       (do ((left byte-size (- left save-block-size))
+		    (index 0 (+ index save-block-size)))
+		   ((< left save-block-size)
+		    (when (> left 0)
+		      (multiple-value-bind (res err)
+					   (mach:unix-write fd addr index left)
+			(if (null res)
+			    (error "Failed to write file ~A, unix error: ~A"
+				   file (mach:get-unix-error-msg err))))))
+		 (declare (fixnum left index))
+		 (multiple-value-bind (res err)
+				      (mach:unix-write fd addr index
+						       save-block-size)
+		   (if (null res)
+		       (error "Failed to write file ~A, unix error: ~A"
+			      file (mach:get-unix-error-msg err)))))
+	       (multiple-value-bind (res err) (mach:unix-close fd)
+		 (if (null res)
+		     (error "Failed to close file ~A, unix error: ~A"
+			    file (mach:get-unix-error-msg err)))))
+	     (format t "done.]~%")
+	     (mach::vm_deallocate *task-self* addr size-to-allocate)
+	     (finish-output)
+	     byte-size)))))
+
+(defun current-space-usage ()
+  (declare (optimize (speed 3) (safety 0)))
+  (do ((sum 0)
+       (type 0 (1+ type)))
+      ((> type %last-pointer-type) sum)
+    (declare (fixnum type sum))
+    (if (not (or (eq type %short-+-float-type) (eq type %short---float-type)))
+	(multiple-value-bind (dyn stat ro) (space-usage type)
+	  (declare (fixnum dyn stat ro))
+	  (setq sum (+ sum dyn stat ro))))))
diff --git a/code/search-list.lisp b/code/search-list.lisp
new file mode 100644
index 000000000..ffa7c6244
--- /dev/null
+++ b/code/search-list.lisp
@@ -0,0 +1,154 @@
+;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; Logical name (search list) hackery for Lisp'ers.
+;;;
+;;; Written by Bill Chiles.
+
+(in-package 'lisp)
+(in-package "EXTENSIONS")
+(export 'search-list)
+(in-package 'lisp)
+
+
+(defvar *search-list-table* (make-hash-table :test #'equal))
+(defvar *rsl-circularity-check* (make-hash-table :test #'equal))
+
+
+(defun search-list (name)
+  "Returns a list of strings that are the of name.
+   This is setf'able.  If any provided string in a setting value
+   does end with a colon or slash, a slash is added.  Also, the
+   list is copied."
+  (let ((dev (pathname-device name)))
+    (unless dev (error "No device in ~S." name))
+    (copy-list (gethash dev *search-list-table*))))
+
+(defun %set-search-list (name new-value)
+  (unless (listp new-value)
+    (error "New value for search-list ~S not a list -- ~S."
+	   name new-value))
+  (let ((dev (pathname-device name)))
+    (unless dev (error "No device in ~S." name))
+    (nstring-downcase dev)
+    (setf (gethash dev *search-list-table*)
+	  (mapcar #'(lambda (x)
+		      (declare (simple-string x))
+		      (let* ((len (length x))
+			     (char (schar x (1- len))))
+			(if (or (char= char #\:) (char= char #\/))
+			    x
+			    (concatenate 'simple-string x "/"))))
+		  new-value)))
+  new-value)
+
+
+(defun resolve-search-list (name first-only-p)
+  "This takes a Sesame search-list name (\"default\") instead of the form
+   taken by SEARCH-LIST (\"default:\").  If first-only-p is non-nil, then
+   only the first complete expansion of name is returned.  If, during the
+   expansion of name, an undefined search list is encountered, an error
+   is signaled."
+  (setf name (string-downcase name))
+  (setf (gethash name *rsl-circularity-check*) t)
+  (unwind-protect
+    (resolve-search-list-aux name first-only-p)
+    (clrhash *rsl-circularity-check*)))
+
+
+;;; RESOLVE-SEARCH-LIST-BODY is used in RESOLVE-SEARCH-LIST-AUX and
+;;; RSL-FIRST.  This means the former is recursive, and the former and
+;;; latter are mutually recursive.  This form first looks at an element of
+;;; a list of expansions for a search list for a colon which means that the
+;;; element needs to be further resolved.  If there is no colon, execute
+;;; the already-form.  If there is a colon, grab the new element to resolve
+;;; recursively.  If this new element has been seen already, we have an
+;;; infinite recursion brewing.  Recursively expand this new element.  If
+;;; there are no expansions, signal an error with the offending search list;
+;;; otherwise, execute the expanded-form if the argument element was only a
+;;; search list, or the concat-form if the argument element was a search
+;;; list followed by a directory sequence.  The locals pos, len, and res
+;;; are meant to be referenced at the call sites.
+;;; 
+(eval-when (compile eval)
+(defmacro resolve-search-list-body (first-only-p element expanded-form
+						 concat-form already-form)
+  `(let ((pos (position #\: ,element :test #'char=))
+	 (len (length ,element)))
+     (declare (fixnum len))
+     (if pos
+	 (let ((dev (nstring-downcase (subseq ,element 0 pos))))
+	   (if (gethash dev *rsl-circularity-check*)
+	       (error "Circularity in search list -- ~S." dev)
+	       (setf (gethash dev *rsl-circularity-check*) t))
+	   (let ((res (resolve-search-list-aux dev ,first-only-p)))
+	     (remhash dev *rsl-circularity-check*)
+	     (if res
+		 (if (= (the fixnum pos) (the fixnum (1- len)))
+		     ,expanded-form
+		     ,concat-form)
+		 (error "Undefined search list -- ~S"
+			(subseq ,element 0 (1+ pos))))))
+	 ,already-form)))
+) ; eval-when
+
+;;; RESOLVE-SEARCH-LIST-AUX takes a device/search-list string (that is,
+;;; without the colon) and whether it should return the first expansion
+;;; found.  If dev is not defined, signal an error with the offending
+;;; search list.  If dev is defined, and first-only-p is non-nil, then just
+;;; resolve the first possible expansion.  Otherwise, we loop over all of
+;;; the possible expansions resolving each one completely, appending the
+;;; results in order as they appear in entry.  If entry is just another
+;;; search list, then append the result (res) of its expansion onto result.
+;;; If entry is a search list followed by a directory spec, then
+;;; concatenate each of the expansions of the search list with the
+;;; directory, appending this to result.  If entry is just a directory
+;;; spec, then append the list of entry to result.
+;;; 
+(defun resolve-search-list-aux (dev first-only-p)
+  (let ((entry (gethash dev *search-list-table*)))
+    (if entry
+	(if first-only-p
+	    (rsl-first (car entry))
+	    (do ((entries entry (cdr entries))
+		 (result (cons nil nil)))
+		((null entries) (cdr result))
+	      (let ((entry (car entries)))
+		(declare (simple-string entry))
+		(resolve-search-list-body
+		 nil entry (nconc result res)
+		 (nconc result (rsl-concat res (subseq entry (1+ pos) len)))
+		 (nconc result (list entry))))))
+	(error "Undefined search list -- ~S" 
+	       (concatenate 'simple-string dev ":")))))
+
+;;; RSL-FIRST takes a possible expansion and resolves it if necessary.
+;;; If first is just another search list, then return the expansions
+;;; of this search list.  If first is another search list followed by
+;;; directory spec, then concatenate each of the expansions of the
+;;; search list with the directory, returning this list.  If first is
+;;; just a directory spec, then return the list of it.
+;;; 
+(defun rsl-first (first)
+  (declare (simple-string first))
+  (resolve-search-list-body t first res
+			    (rsl-concat res (subseq first (1+ pos) len))
+			    (list first)))
+
+;;; RSL-CONCAT takes a list of expansions (prefixes) for a search list
+;;; that was concatenated with a directory spec (suffix).  Each prefix
+;;; is concatenated with the suffix and stored back where the prefix
+;;; was.  The destructively modified prefixes is returned.
+;;; 
+(defun rsl-concat (prefixes suffix)
+  (declare (simple-string suffix))
+  (do ((ptr prefixes (cdr ptr)))
+      ((null ptr) prefixes)
+    (setf (car ptr)
+	  (concatenate 'simple-string (the simple-string (car ptr)) suffix))))
diff --git a/code/seq.lisp b/code/seq.lisp
new file mode 100644
index 000000000..bf6f8deba
--- /dev/null
+++ b/code/seq.lisp
@@ -0,0 +1,2281 @@
+;;; -*- Log: code.log; Package: Lisp -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; Functions to implement generic sequences for Spice Lisp.
+;;; Written by Skef Wholey.
+;;; Fixed up by Jim Muller on Friday the 13th, January, 1984.
+;;; Gone over again by Bill Chiles.  Next?
+;;;
+;;; Be careful when modifying code.  A lot of the structure of the code is
+;;; affected by the fact that compiler transforms use the lower level support
+;;; functions.  If transforms are written for some sequence operation, note
+;;; how the end argument is handled in other operations with transforms.
+
+(in-package 'lisp)
+(export '(elt subseq copy-seq coerce
+	  length reverse nreverse make-sequence concatenate map some every
+	  notany notevery reduce fill replace remove remove-if remove-if-not
+	  delete delete-if delete-if-not remove-duplicates delete-duplicates
+	  substitute substitute-if substitute-if-not nsubstitute nsubstitute-if
+	  nsubstitute-if-not find find-if find-if-not position position-if
+	  position-if-not count count-if count-if-not mismatch search
+          identity)) ; Yep, thet's whar it is.
+
+	  
+;;; Spice-Lisp specific stuff and utilities:
+	  
+(eval-when (compile)
+
+;;; Seq-Dispatch does an efficient type-dispatch on the given Sequence.
+
+(defmacro seq-dispatch (sequence list-form array-form)
+  `(if (listp ,sequence)
+       ,list-form
+       ,array-form))
+
+(defmacro elt-slice (sequences n)
+  "Returns a list of the Nth element of each of the sequences.  Used by MAP
+   and friends."
+  `(mapcar #'(lambda (seq) (elt seq ,n)) ,sequences))
+
+(defmacro make-sequence-like (sequence length)
+  "Returns a sequence of the same type as SEQUENCE and the given LENGTH."
+  `(make-sequence-of-type (type-of ,sequence) ,length))
+
+(defmacro type-specifier (type)
+  "Returns the broad class of which TYPE is a specific subclass."
+  `(if (atom ,type) ,type (car ,type)))
+
+) ; eval-when
+
+
+
+;;; APPLY-KEY saves us a function call sometimes.
+;;;    This is not in and (eval-when (compile eval) ...
+;;;    because this is used in Sort.Lisp
+(defmacro apply-key (key element)
+  `(if ,key
+       (funcall ,key ,element)
+       ,element))
+
+
+(defun identity (thing)
+  "Returns what was passed to it."
+  thing)
+
+
+(defun make-sequence-of-type (type length)
+  "Returns a sequence of the given TYPE and LENGTH."
+  (declare (fixnum length))
+  (case (type-specifier type)
+    (list (make-list length))
+    ((bit-vector simple-bit-vector) (make-array length :element-type '(mod 2)))
+    ((string simple-string) (make-string length))
+    (simple-vector (make-array length))
+    ((array simple-array vector)
+     (if (listp type)
+	 (make-array length :element-type (cadr type))
+	 (make-array length)))
+    ((bit-vector simple-bit-vector)
+     (make-array length :element-type '(mod 2)))
+    (t (error "~S is a bad type specifier for sequence functions." type))))
+
+(defun elt (sequence index)
+  "Returns the element of SEQUENCE specified by INDEX."
+  (if (listp sequence)
+      (if (< index 0)
+	  (error "~S: index too small." index)
+	  (do ((count index (1- count)))
+	      ((= count 0) (car sequence))
+	    (declare (fixnum count))
+	    (if (atom sequence)
+		(error "~S: index too large." index)
+		(setq sequence (cdr sequence)))))
+      (aref sequence index)))
+
+(defun %setelt (sequence index newval)
+  "Store NEWVAL as the component of SEQUENCE specified by INDEX."
+  (if (listp sequence)
+      (if (< index 0)
+	  (error "~S: index too small." index)
+	  (do ((count index (1- count))
+	       (seq sequence))
+	      ((= count 0) (rplaca seq newval) sequence)
+	    (declare (fixnum count))
+	    (if (atom (cdr seq))
+		(error "~S: index too large." index)
+		(setq seq (cdr seq)))))
+      (setf (aref sequence index) newval)))
+
+(defun length (sequence)
+  "Returns an integer that is the length of SEQUENCE."
+  (%primitive length sequence))
+
+(defun list-length* (sequence)
+  (do ((count 0 (1+ count)))
+      ((atom sequence) count)
+    (declare (fixnum count))
+    (setq sequence (cdr sequence))))
+
+(defun make-sequence (type length &key (initial-element NIL iep))
+  "Returns a sequence of the given Type and Length, with elements initialized
+  to :Initial-Element."
+  (declare (fixnum length))
+  (let ((type (type-expand type)))
+    (cond ((subtypep type 'list)
+	   (make-list length :initial-element initial-element))
+	  ((subtypep type 'string)
+	   (if iep
+	       (make-string length :initial-element initial-element)
+	       (make-string length)))
+	  ((subtypep type 'simple-vector)
+	   (make-array length :initial-element initial-element))
+	  ((subtypep type 'bit-vector)
+	   (if iep
+	       (make-array length :element-type '(mod 2)
+			   :initial-element initial-element)
+	       (make-array length :element-type '(mod 2))))
+	  ((subtypep type 'vector)
+	   (if (listp type)
+	       (if iep
+		   (make-array length :element-type (cadr type)
+			       :initial-element initial-element)
+		   (make-array length :element-type (cadr type)
+			       :initial-element
+			       (if (subtypep (cadr type) 'number)
+				   0
+				   NIL)))
+	       (make-array length :initial-element initial-element)))
+	  (t (error "~S is a bad type specifier for sequences." type)))))
+
+
+
+;;; Subseq:
+;;;
+;;; The support routines for SUBSEQ are used by compiler transforms, so we
+;;; worry about dealing with end being supplied as or defaulting to nil
+;;; at this level.
+
+(defun vector-subseq* (sequence start &optional end)
+  (declare (vector sequence) (fixnum start))
+  (when (null end) (setf end (length sequence)))
+  (do ((old-index start (1+ old-index))
+       (new-index 0 (1+ new-index))
+       (copy (make-sequence-like sequence (- end start))))
+      ((= old-index end) copy)
+    (declare (fixnum old-index new-index))
+    (setf (aref copy new-index) (aref sequence old-index))))
+
+(defun list-subseq* (sequence start &optional end)
+  (declare (list sequence) (fixnum start))
+  (if (and end (>= start (the fixnum end)))
+      ()
+      (let* ((groveled (nthcdr start sequence))
+	     (result (list (car groveled))))
+	(if groveled
+	    (do ((list (cdr groveled) (cdr list))
+		 (splice result (cdr (rplacd splice (list (car list)))))
+		 (index (1+ start) (1+ index)))
+		((or (atom list) (and end (= index (the fixnum end))))
+		 result)
+	      (declare (fixnum index)))
+	    ()))))
+
+;;; SUBSEQ cannot default end to the length of sequence since it is not
+;;; an error to supply nil for its value.  We must test for end being nil
+;;; in the body of the function, and this is actually done in the support
+;;; routines for other reasons (see above).
+(defun subseq (sequence start &optional end)
+  "Returns a copy of a subsequence of SEQUENCE starting with element number 
+   START and continuing to the end of SEQUENCE or the optional END."
+  (seq-dispatch sequence
+		(list-subseq* sequence start end)
+		(vector-subseq* sequence start end)))
+
+
+;;; Copy-seq:
+
+(eval-when (compile eval)
+
+(defmacro vector-copy-seq (sequence type)
+  `(let ((length (length (the vector ,sequence))))
+     (declare (fixnum length))
+     (do ((index 0 (1+ index))
+	  (copy (make-sequence-of-type ,type length)))
+	 ((= index length) copy)
+       (declare (fixnum index))
+       (setf (aref copy index) (aref ,sequence index)))))
+
+(defmacro list-copy-seq (list)
+  `(if (atom ,list) '()
+       (let ((result (cons (car ,list) '()) ))
+	 (do ((x (cdr ,list) (cdr x))
+	      (splice result
+		      (cdr (rplacd splice (cons (car x) '() ))) ))
+	     ((atom x) (unless (null x)
+			       (rplacd splice x))
+		       result)))))
+
+)
+
+(defun copy-seq (sequence)
+  "Returns a copy of SEQUENCE which is EQUAL to SEQUENCE but not EQ."
+  (seq-dispatch sequence
+		(list-copy-seq* sequence)
+		(vector-copy-seq* sequence)))
+
+;;; Internal Frobs:
+
+(defun list-copy-seq* (sequence)
+  (list-copy-seq sequence))
+
+(defun vector-copy-seq* (sequence)
+  (vector-copy-seq sequence (type-of sequence)))
+
+
+;;; Fill:
+
+(eval-when (compile eval)
+
+(defmacro vector-fill (sequence item start end)
+  `(do ((index ,start (1+ index)))
+       ((= index (the fixnum ,end)) ,sequence)
+     (declare (fixnum index))
+     (setf (aref ,sequence index) ,item)))
+
+(defmacro list-fill (sequence item start end)
+  `(do ((current (nthcdr ,start ,sequence) (cdr current))
+	(index ,start (1+ index)))
+       ((or (atom current) (and end (= index (the fixnum ,end))))
+	sequence)
+     (declare (fixnum index))
+     (rplaca current ,item)))
+
+)
+
+;;; The support routines for FILL are used by compiler transforms, so we
+;;; worry about dealing with end being supplied as or defaulting to nil
+;;; at this level.
+
+(defun list-fill* (sequence item start end)
+  (declare (list sequence))
+  (list-fill sequence item start end))
+
+(defun vector-fill* (sequence item start end)
+  (declare (vector sequence))
+  (when (null end) (setq end (length sequence)))
+  (vector-fill sequence item start end))
+
+;;; FILL cannot default end to the length of sequence since it is not
+;;; an error to supply nil for its value.  We must test for end being nil
+;;; in the body of the function, and this is actually done in the support
+;;; routines for other reasons (see above).
+(defun fill (sequence item &key (start 0) end)
+  "Replace the specified elements of SEQUENCE with ITEM."
+  (seq-dispatch sequence
+		(list-fill* sequence item start end)
+		(vector-fill* sequence item start end)))
+
+
+
+;;; Replace:
+
+(eval-when (compile eval)
+
+;;; If we are copying around in the same vector, be careful not to copy the
+;;; same elements over repeatedly.  We do this by copying backwards.
+(defmacro mumble-replace-from-mumble ()
+  `(if (and (eq target-sequence source-sequence) (> target-start source-start))
+       (let ((nelts (min (- target-end target-start) (- source-end source-start))))
+	 (do ((target-index (+ (the fixnum target-start) (the fixnum nelts) -1)
+			    (1- target-index))
+	      (source-index (+ (the fixnum source-start) (the fixnum nelts) -1)
+			    (1- source-index)))
+	     ((= target-index (the fixnum (1- target-start))) target-sequence)
+	   (declare (fixnum target-index source-index))
+	   (setf (aref target-sequence target-index)
+		 (aref source-sequence source-index))))
+       (do ((target-index target-start (1+ target-index))
+	    (source-index source-start (1+ source-index)))
+	   ((or (= target-index (the fixnum target-end))
+		(= source-index (the fixnum source-end)))
+	    target-sequence)
+	 (declare (fixnum target-index source-index))
+	 (setf (aref target-sequence target-index)
+	       (aref source-sequence source-index)))))
+
+(defmacro list-replace-from-list ()
+  `(if (and (eq target-sequence source-sequence) (> target-start source-start))
+       (let ((new-elts (subseq source-sequence source-start
+			       (+ (the fixnum source-start)
+				  (the fixnum
+				       (min (- (the fixnum target-end)
+					       (the fixnum target-start))
+					    (- (the fixnum source-end)
+					       (the fixnum source-start))))))))
+	 (do ((n new-elts (cdr n))
+	      (o (nthcdr target-start target-sequence) (cdr o)))
+	     ((null n) target-sequence)
+	   (rplaca o (car n))))
+       (do ((target-index target-start (1+ target-index))
+	    (source-index source-start (1+ source-index))
+	    (target-sequence-ref (nthcdr target-start target-sequence)
+				 (cdr target-sequence-ref))
+	    (source-sequence-ref (nthcdr source-start source-sequence)
+				 (cdr source-sequence-ref)))
+	   ((or (= target-index (the fixnum target-end))
+		(= source-index (the fixnum source-end))
+		(null target-sequence-ref) (null source-sequence-ref))
+	    target-sequence)
+	 (declare (fixnum target-index source-index))
+	 (rplaca target-sequence-ref (car source-sequence-ref)))))
+
+(defmacro list-replace-from-mumble ()
+  `(do ((target-index target-start (1+ target-index))
+	(source-index source-start (1+ source-index))
+	(target-sequence-ref (nthcdr target-start target-sequence)
+			     (cdr target-sequence-ref)))
+       ((or (= target-index (the fixnum target-end))
+	    (= source-index (the fixnum source-end))
+	    (null target-sequence-ref))
+	target-sequence)
+     (declare (fixnum source-index target-index))
+     (rplaca target-sequence-ref (aref source-sequence source-index))))
+
+(defmacro mumble-replace-from-list ()
+  `(do ((target-index target-start (1+ target-index))
+	(source-index source-start (1+ source-index))
+	(source-sequence (nthcdr source-start source-sequence)
+			 (cdr source-sequence)))
+       ((or (= target-index (the fixnum target-end))
+	    (= source-index (the fixnum source-end))
+	    (null source-sequence))
+	target-sequence)
+     (declare (fixnum target-index source-index))
+     (setf (aref target-sequence target-index) (car source-sequence))))
+
+) ; eval-when
+
+;;; The support routines for REPLACE are used by compiler transforms, so we
+;;; worry about dealing with end being supplied as or defaulting to nil
+;;; at this level.
+
+(defun list-replace-from-list* (target-sequence source-sequence target-start
+				target-end source-start source-end)
+  (when (null target-end) (setq target-end (length target-sequence)))
+  (when (null source-end) (setq source-end (length source-sequence)))
+  (list-replace-from-list))
+
+(defun list-replace-from-vector* (target-sequence source-sequence target-start
+				  target-end source-start source-end)
+  (when (null target-end) (setq target-end (length target-sequence)))
+  (when (null source-end) (setq source-end (length source-sequence)))
+  (list-replace-from-mumble))
+
+(defun vector-replace-from-list* (target-sequence source-sequence target-start
+				  target-end source-start source-end)
+  (when (null target-end) (setq target-end (length target-sequence)))
+  (when (null source-end) (setq source-end (length source-sequence)))
+  (mumble-replace-from-list))
+
+(defun vector-replace-from-vector* (target-sequence source-sequence
+				    target-start target-end source-start
+				    source-end)
+  (when (null target-end) (setq target-end (length target-sequence)))
+  (when (null source-end) (setq source-end (length source-sequence)))
+  (mumble-replace-from-mumble))
+
+;;; REPLACE cannot default end arguments to the length of sequence since it
+;;; is not an error to supply nil for their values.  We must test for ends
+;;; being nil in the body of the function.
+(defun replace (target-sequence source-sequence &key
+	        ((:start1 target-start) 0)
+		((:end1 target-end))
+		((:start2 source-start) 0)
+		((:end2 source-end)))
+  "The target sequence is destructively modified by copying successive
+   elements into it from the source sequence."
+  (unless target-end (setq target-end (length target-sequence)))
+  (unless source-end (setq source-end (length source-sequence)))
+  (seq-dispatch target-sequence
+		(seq-dispatch source-sequence
+			      (list-replace-from-list)
+			      (list-replace-from-mumble))
+		(seq-dispatch source-sequence
+			      (mumble-replace-from-list)
+			      (mumble-replace-from-mumble))))
+
+
+;;; Reverse:
+
+(eval-when (compile eval)
+
+(defmacro vector-reverse (sequence type)
+  `(let ((length (length ,sequence)))
+     (declare (fixnum length))
+     (do ((forward-index 0 (1+ forward-index))
+	  (backward-index (1- length) (1- backward-index))
+	  (new-sequence (make-sequence-of-type ,type length)))
+	 ((= forward-index length) new-sequence)
+       (declare (fixnum forward-index backward-index))
+       (setf (aref new-sequence forward-index)
+	     (aref ,sequence backward-index)))))
+
+(defmacro list-reverse-macro (sequence)
+  `(do ((new-list ()))
+       ((atom ,sequence) new-list)
+     (push (pop ,sequence) new-list)))
+
+)
+
+(defun reverse (sequence)
+  "Returns a new sequence containing the same elements but in reverse order."
+  (seq-dispatch sequence
+		(list-reverse* sequence)
+		(vector-reverse* sequence)))
+
+;;; Internal Frobs:
+
+(defun list-reverse* (sequence)
+  (list-reverse-macro sequence))
+
+(defun vector-reverse* (sequence)
+  (vector-reverse sequence (type-of sequence)))
+
+
+;;; Nreverse:
+
+(eval-when (compile eval)
+
+(defmacro vector-nreverse (sequence)
+  `(let ((length (length (the vector ,sequence))))
+     (declare (fixnum length))
+     (do ((left-index 0 (1+ left-index))
+	  (right-index (1- length) (1- right-index))
+	  (half-length (truncate length 2)))
+	 ((= left-index half-length) ,sequence)
+       (declare (fixnum left-index right-index half-length))
+       (rotatef (aref ,sequence left-index)
+		(aref ,sequence right-index)))))
+
+(defmacro list-nreverse-macro (list)
+  `(do ((1st (cdr ,list) (if (atom 1st) 1st (cdr 1st)))
+	(2nd ,list 1st)
+	(3rd '() 2nd))
+       ((atom 2nd) 3rd)
+     (rplacd 2nd 3rd)))
+
+)
+
+
+(defun list-nreverse* (sequence)
+  (list-nreverse-macro sequence))
+
+(defun vector-nreverse* (sequence)
+  (vector-nreverse sequence))
+
+(defun nreverse (sequence)
+  "Returns a sequence of the same elements in reverse order; the argument
+   is destroyed."
+  (seq-dispatch sequence
+		(list-nreverse* sequence)
+		(vector-nreverse* sequence)))
+
+
+;;; Concatenate:
+
+(eval-when (compile eval)
+
+(defmacro concatenate-to-list (sequences)
+  `(let ((result (list nil)))
+     (do ((sequences ,sequences (cdr sequences))
+	  (splice result))
+	 ((null sequences) (cdr result))
+       (let ((sequence (car sequences)))
+	 (seq-dispatch sequence
+		       (do ((sequence sequence (cdr sequence)))
+			   ((atom sequence))
+			 (setq splice
+			       (cdr (rplacd splice (list (car sequence))))))
+		       (do ((index 0 (1+ index))
+			    (length (length sequence)))
+			   ((= index length))
+			 (declare (fixnum index length))
+			 (setq splice
+			       (cdr (rplacd splice
+					    (list (aref sequence index)))))))))))
+
+(defmacro concatenate-to-mumble (output-type-spec sequences)
+  `(do ((seqs ,sequences (cdr seqs))
+	(total-length 0)
+	(lengths ()))
+       ((null seqs)
+	(do ((sequences ,sequences (cdr sequences))
+	     (lengths lengths (cdr lengths))
+	     (index 0)
+	     (result (make-sequence-of-type ,output-type-spec total-length)))
+	    ((= index total-length) result)
+	  (declare (fixnum index))
+	  (let ((sequence (car sequences)))
+	    (seq-dispatch sequence
+			  (do ((sequence sequence (cdr sequence)))
+			      ((atom sequence))
+			    (setf (aref result index) (car sequence))
+			    (setq index (1+ index)))
+			  (do ((jndex 0 (1+ jndex))
+			       (this-length (car lengths)))
+			      ((= jndex this-length))
+			    (declare (fixnum jndex this-length))
+			    (setf (aref result index)
+				  (aref sequence jndex))
+			    (setq index (1+ index)))))))
+     (let ((length (length (car seqs))))
+       (declare (fixnum length))
+       (setq lengths (nconc lengths (list length)))
+       (setq total-length (+ total-length length)))))
+
+)
+
+(defun concatenate (output-type-spec &rest sequences)
+  "Returns a new sequence of all the argument sequences concatenated together
+   which shares no structure with the original argument sequences of the
+   specified OUTPUT-TYPE-SPEC."
+  (case (type-specifier output-type-spec)
+    (list (apply #'concat-to-list* sequences))
+    ((simple-vector simple-string vector string array simple-array
+		    bit-vector simple-bit-vector)
+     (apply #'concat-to-simple* output-type-spec sequences))
+    (t (error "~S: invalid output type specification." output-type-spec))))
+
+;;; Internal Frobs:
+
+(defun concat-to-list* (&rest sequences)
+  (concatenate-to-list sequences))
+
+(defun concat-to-simple* (type &rest sequences)
+  (concatenate-to-mumble type sequences))
+
+
+;;; Map:
+
+(eval-when (compile eval)
+
+(defmacro map-to-list (function sequences)
+  `(do ((seqs more-sequences (cdr seqs))
+	(min-length (length first-sequence)))
+       ((null seqs)
+	(let ((result (list nil)))
+	  (do ((index 0 (1+ index))
+	       (splice result))
+	      ((= index min-length) (cdr result))
+	    (declare (fixnum index))
+	    (setq splice
+		  (cdr (rplacd splice
+			       (list (apply ,function (elt-slice ,sequences
+								 index)))))))))
+     (declare (fixnum min-length))
+     (let ((length (length (car seqs))))
+       (declare (fixnum length))
+       (if (< length min-length)
+	   (setq min-length length)))))
+
+(defmacro map-to-simple (output-type-spec function sequences)
+  `(do ((seqs more-sequences (cdr seqs))
+	(min-length (length first-sequence)))
+       ((null seqs)
+	(do ((index 0 (1+ index))
+	     (result (make-sequence-of-type ,output-type-spec min-length)))
+	    ((= index min-length) result)
+	  (declare (fixnum index))
+	  (setf (aref result index)
+		(apply ,function (elt-slice ,sequences index)))))
+     (declare (fixnum min-length))
+     (let ((length (length (car seqs))))
+       (declare (fixnum length))
+       (if (< length min-length)
+	   (setq min-length length)))))
+
+(defmacro map-for-effect (function sequences)
+  `(do ((seqs more-sequences (cdr seqs))
+	(min-length (length first-sequence)))
+       ((null seqs)
+	(do ((index 0 (1+ index)))
+	    ((= index min-length) nil)
+	  (apply ,function (elt-slice ,sequences index))))
+     (declare (fixnum min-length))
+     (let ((length (length (car seqs))))
+       (declare (fixnum length))
+       (if (< length min-length)
+	   (setq min-length length)))))
+
+
+)
+
+(defun map (output-type-spec function first-sequence &rest more-sequences)
+  "FUNCTION must take as many arguments as there are sequences provided.  The 
+   result is a sequence such that element i is the result of applying FUNCTION
+   to element i of each of the argument sequences."
+  (let ((sequences (cons first-sequence more-sequences)))
+    (case (type-specifier output-type-spec)
+      ((nil) (map-for-effect function sequences))
+      (list (map-to-list function sequences))
+      ((simple-vector simple-string vector string array simple-array
+		    bit-vector simple-bit-vector)
+       (map-to-simple output-type-spec function sequences))
+      (t (error "~S: invalid output type specifier." output-type-spec)))))
+
+
+;;; Quantifiers:
+
+(eval-when (compile eval)
+(defmacro defquantifier (name doc-string every-result abort-sense abort-value)
+  `(defun ,name (predicate first-sequence &rest more-sequences)
+     ,doc-string
+     (do ((seqs more-sequences (cdr seqs))
+	  (length (length first-sequence))
+	  (sequences (cons first-sequence more-sequences)))
+	 ((null seqs)
+	  (do ((index 0 (1+ index)))
+	      ((= index length) ,every-result)
+	    (declare (fixnum index))
+	    (let ((result (apply predicate (elt-slice sequences index))))
+	      (if ,(if abort-sense 'result '(not result))
+		  (return ,abort-value)))))
+       (declare (fixnum length))
+       (let ((this (length (car seqs))))
+	 (declare (fixnum this))
+	 (if (< this length) (setq length this))))))
+) ; eval-when
+
+(defquantifier some
+  "PREDICATE is applied to the elements with index 0 of the sequences, then 
+   possibly to those with index 1, and so on.  SOME returns the first 
+   non-() value encountered, or () if the end of a sequence is reached."
+  nil t result)
+
+(defquantifier every
+  "PREDICATE is applied to the elements with index 0 of the sequences, then
+   possibly to those with index 1, and so on.  EVERY returns () as soon
+   as any invocation of PREDICATE returns (), or T if every invocation
+   is non-()."
+  t nil nil)
+
+(defquantifier notany
+  "PREDICATE is applied to the elements with index 0 of the sequences, then 
+   possibly to those with index 1, and so on.  NOTANY returns () as soon
+   as any invocation of PREDICATE returns a non-() value, or T if the end
+   of a sequence is reached."
+  t t nil)
+
+(defquantifier notevery
+  "PREDICATE is applied to the elements with index 0 of the sequences, then
+   possibly to those with index 1, and so on.  NOTEVERY returns T as soon
+   as any invocation of PREDICATE returns (), or () if every invocation
+   is non-()."
+  nil nil t)
+
+
+
+;;; Reduce:
+
+(eval-when (compile eval)
+
+(defmacro mumble-reduce (function sequence start end initial-value ref)
+  `(do ((index ,start (1+ index))
+	(value ,initial-value))
+       ((= index (the fixnum ,end)) value)
+     (declare (fixnum index))
+     (setq value (funcall ,function value (,ref ,sequence index)))))
+
+(defmacro mumble-reduce-from-end (function sequence start end initial-value ref)
+  `(do ((index (1- ,end) (1- index))
+	(value ,initial-value)
+	(terminus (1- ,start)))
+       ((= index terminus) value)
+     (declare (fixnum index terminus))
+     (setq value (funcall ,function (,ref ,sequence index) value))))
+
+(defmacro list-reduce (function sequence start end initial-value ivp)
+  `(let ((sequence (nthcdr ,start ,sequence)))
+     (do ((count (if ,ivp ,start (1+ (the fixnum ,start)))
+		 (1+ count))
+	  (sequence (if ,ivp sequence (cdr sequence))
+		    (cdr sequence))
+	  (value (if ,ivp ,initial-value (car sequence))
+		 (funcall ,function value (car sequence))))
+	 ((= count (the fixnum ,end)) value)
+       (declare (fixnum count)))))
+
+(defmacro list-reduce-from-end (function sequence start end initial-value ivp)
+  `(let ((sequence (nthcdr (- (the fixnum (length ,sequence)) (the fixnum ,end))
+			   (reverse ,sequence))))
+     (do ((count (if ,ivp ,start (1+ (the fixnum ,start)))
+		 (1+ count))
+	  (sequence (if ,ivp sequence (cdr sequence))
+		    (cdr sequence))
+	  (value (if ,ivp ,initial-value (car sequence))
+		 (funcall ,function (car sequence) value)))
+	 ((= count (the fixnum ,end)) value)
+       (declare (fixnum count)))))
+
+)
+
+(defun reduce (function sequence &key from-end (start 0)
+			end (initial-value nil ivp))
+  "The specified Sequence is ``reduced'' using the given Function.
+  See manual for details."
+  (declare (fixnum start))
+  (when (null end) (setf end (length sequence)))
+  (cond ((= (the fixnum end) start)
+	 (if ivp initial-value (funcall function)))
+	((listp sequence)
+	 (if from-end
+	     (list-reduce-from-end function sequence start end initial-value ivp)
+	     (list-reduce function sequence start end initial-value ivp)))
+	(from-end
+	 (when (not ivp)
+	   (setq end (1- (the fixnum end)))
+	   (setq initial-value (aref sequence end)))
+	 (mumble-reduce-from-end function sequence start end initial-value aref))
+	(t
+	 (when (not ivp)
+	   (setq initial-value (aref sequence start))
+	   (setq start (1+ start)))
+	 (mumble-reduce function sequence start end initial-value aref))))
+
+
+;;; Coerce:
+
+(defun coerce (object output-type-spec)
+  "Coerces the Object to an object of type Output-Type-Spec."
+  (cond
+   ((typep object output-type-spec)
+    object)
+   ((eq output-type-spec 'character)
+    (character object))
+   ((eq output-type-spec 'function)
+    (eval `#',object))
+   ((numberp object)
+    (case output-type-spec
+      (short-float (%primitive float-short object))
+      ((single-float float) (%primitive float-single object))
+      ((double-float long-float) (%primitive float-long object))
+      (complex
+       (complex object))
+      (t
+       (error "~S can't be converted to type ~S." object output-type-spec))))
+   (t
+    (typecase object
+      (list
+       (case (type-specifier output-type-spec)
+	 ((simple-string string) (list-to-string* object))
+	 ((simple-bit-vector bit-vector) (list-to-bit-vector* object))
+	 ((simple-vector vector array simple-array)
+	  (list-to-vector* object output-type-spec))
+	 (t (error "Can't coerce ~S to type ~S." object output-type-spec))))
+      (simple-string
+       (case (type-specifier output-type-spec)
+	 (list (vector-to-list* object))
+	 ;; Can't coerce a string to a bit-vector!
+	 ((simple-vector vector array simple-array)
+	  (vector-to-vector* object output-type-spec))
+	 (t (error "Can't coerce ~S to type ~S." object output-type-spec))))
+      (simple-bit-vector
+       (case (type-specifier output-type-spec)
+	 (list (vector-to-list* object))
+	 ;; Can't coerce a bit-vector to a string!
+	 ((simple-vector vector array simple-array)
+	  (vector-to-vector* object output-type-spec))
+	 (t (error "Can't coerce ~S to type ~S." object output-type-spec))))
+      (simple-vector
+       (case (type-specifier output-type-spec)
+	 (list (vector-to-list* object))
+	 ((simple-string string) (vector-to-string* object))
+	 ((simple-bit-vector bit-vector) (vector-to-bit-vector* object))
+	 ((vector array simple-array) (vector-to-vector* object output-type-spec))
+	 (t (error "Can't coerce ~S to type ~S." object output-type-spec))))
+      (string
+       (case (type-specifier output-type-spec)
+	 (list (vector-to-list* object))
+	 (simple-string (string-to-simple-string* object))
+	 ;; Can't coerce a string to a bit-vector!
+	 ((simple-vector vector simple-array array)
+	  (vector-to-vector* object output-type-spec))
+	 (t (error "Can't coerce ~S to type ~S." object output-type-spec))))
+      (bit-vector
+       (case (type-specifier output-type-spec)
+	 (list (vector-to-list* object))
+	 ;; Can't coerce a bit-vector to a string!
+	 (simple-bit-vector (bit-vector-to-simple-bit-vector* object))
+	 ((simple-vector vector array simple-array)
+	  (vector-to-vector* object output-type-spec))
+	 (t (error "Can't coerce ~S to type ~S." object output-type-spec))))
+      (vector
+       (case (type-specifier output-type-spec)
+	 (list (vector-to-list* object))
+	 ((simple-string string) (vector-to-string* object))
+	 ((simple-bit-vector bit-vector) (vector-to-bit-vector* object))
+	 ((simple-vector vector array simple-array)
+	  (vector-to-vector* object output-type-spec))
+	 (t (error "Can't coerce ~S to type ~S." object output-type-spec))))
+      (t (error "~S is an inappropriate type of object for coerce." object))))))
+
+
+;;; Internal Frobs:
+
+(macrolet ((frob (name result access src-type &optional typep)
+		 `(defun ,name (object ,@(if typep '(type) ()))
+		    (do* ((index 0 (1+ index))
+			  (length (,(case src-type
+				      (:list 'list-length*)
+				      (:vector 'length))
+				   object))
+			  (result ,result))
+			 ((= index length) result)
+		      (declare (fixnum length index))
+		      (setf (,access result index)
+			    ,(case src-type
+			       (:list '(pop object))
+			       (:vector '(aref object index))))))))
+
+  (frob list-to-string* (make-string length) schar :list)
+
+  (frob list-to-bit-vector* (make-array length :element-type '(mod 2))
+	sbit :list)
+
+  (frob list-to-vector* (make-sequence-of-type type length)
+	aref :list t)
+
+  (frob vector-to-vector* (make-sequence-of-type type length)
+	aref :vector t)
+
+  (frob vector-to-string* (make-string length) schar :vector)
+
+  (frob vector-to-bit-vector* (make-array length :element-type '(mod 2))
+	sbit :vector))
+
+(defun vector-to-list* (object)
+  (let ((result (list nil))
+	(length (length object)))
+    (declare (fixnum length))
+    (do ((index 0 (1+ index))
+	 (splice result (cdr splice)))
+	((= index length) (cdr result))
+      (declare (fixnum index))
+      (rplacd splice (list (aref object index))))))
+
+(defun string-to-simple-string* (object)
+  (if (simple-string-p object)
+      object
+      (with-array-data ((data object)
+			(start)
+			(end (%primitive header-ref object
+					 %array-fill-pointer-slot)))
+	(declare (simple-string data))
+	(subseq data start end))))
+
+(defun bit-vector-to-simple-bit-vector* (object)
+  (if (simple-bit-vector-p object)
+      object
+      (with-array-data ((data object)
+			(start)
+			(end (%primitive header-ref object
+					 %array-fill-pointer-slot)))
+	(declare (simple-bit-vector data))
+	(subseq data start end))))
+
+
+;;; Delete:
+
+(eval-when (compile eval)
+
+(defmacro mumble-delete (pred)
+  `(do ((index start (1+ index))
+	(jndex start)
+	(number-zapped 0))
+       ((or (= index (the fixnum end)) (= number-zapped (the fixnum count)))
+	(do ((index index (1+ index))		; copy the rest of the vector
+	     (jndex jndex (1+ jndex)))
+	    ((= index (the fixnum length))
+	     (shrink-vector sequence jndex))
+	  (declare (fixnum index jndex))
+	  (setf (aref sequence jndex) (aref sequence index))))
+     (declare (fixnum index jndex number-zapped))
+     (setf (aref sequence jndex) (aref sequence index))
+     (if ,pred
+	 (setq number-zapped (1+ number-zapped))
+	 (setq jndex (1+ jndex)))))
+
+(defmacro mumble-delete-from-end (pred)
+  `(do ((index (1- (the fixnum end)) (1- index)) ; find the losers
+	(number-zapped 0)
+	(losers ())
+        this-element
+	(terminus (1- start)))
+       ((or (= index terminus) (= number-zapped (the fixnum count)))
+	(do ((losers losers)			 ; delete the losers
+	     (index start (1+ index))
+	     (jndex start))
+	    ((or (null losers) (= index (the fixnum end)))
+	     (do ((index index (1+ index))	 ; copy the rest of the vector
+		  (jndex jndex (1+ jndex)))
+		 ((= index (the fixnum length))
+		  (shrink-vector sequence jndex))
+	       (declare (fixnum index jndex))
+	       (setf (aref sequence jndex) (aref sequence index))))
+	  (declare (fixnum index jndex))
+	  (setf (aref sequence jndex) (aref sequence index))
+	  (if (= index (the fixnum (car losers)))
+	      (pop losers)
+	      (setq jndex (1+ jndex)))))
+     (declare (fixnum index number-zapped terminus))
+     (setq this-element (aref sequence index))
+     (when ,pred
+       (setq number-zapped (1+ number-zapped))
+       (push index losers))))
+
+(defmacro normal-mumble-delete ()
+  `(mumble-delete
+    (if test-not
+	(not (funcall test-not item (apply-key key (aref sequence index))))
+	(funcall test item (apply-key key (aref sequence index))))))
+
+(defmacro normal-mumble-delete-from-end ()
+  `(mumble-delete-from-end
+    (if test-not
+	(not (funcall test-not item (apply-key key this-element)))
+	(funcall test item (apply-key key this-element)))))
+
+(defmacro list-delete (pred)
+  `(let ((handle (cons nil sequence)))
+     (do ((current (nthcdr start sequence) (cdr current))
+	  (previous (nthcdr start handle))
+	  (index start (1+ index))
+	  (number-zapped 0))
+	 ((or (= index (the fixnum end)) (= number-zapped (the fixnum count)))
+	  (cdr handle))
+       (declare (fixnum index number-zapped))
+       (cond (,pred
+	      (rplacd previous (cdr current))
+	      (setq number-zapped (1+ number-zapped)))
+	     (t
+	      (setq previous (cdr previous)))))))
+
+(defmacro list-delete-from-end (pred)
+  `(let* ((reverse (nreverse (the list sequence)))
+	  (handle (cons nil reverse)))
+     (do ((current (nthcdr (- (the fixnum length) (the fixnum end)) reverse)
+		   (cdr current))
+	  (previous (nthcdr (- (the fixnum length) (the fixnum end)) handle))
+	  (index start (1+ index))
+	  (number-zapped 0))
+	 ((or (= index (the fixnum end)) (= number-zapped (the fixnum count)))
+	  (nreverse (cdr handle)))
+       (declare (fixnum index number-zapped))
+       (cond (,pred
+	      (rplacd previous (cdr current))
+	      (setq number-zapped (1+ number-zapped)))
+	     (t
+	      (setq previous (cdr previous)))))))
+
+(defmacro normal-list-delete ()
+  '(list-delete
+    (if test-not
+	(not (funcall test-not item (apply-key key (car current))))
+	(funcall test item (apply-key key (car current))))))
+
+(defmacro normal-list-delete-from-end ()
+  '(list-delete-from-end
+    (if test-not
+	(not (funcall test-not item (apply-key key (car current))))
+	(funcall test item (apply-key key (car current))))))
+)
+
+(defun delete (item sequence &key from-end (test #'eql) test-not (start 0)
+		end (count most-positive-fixnum) key)
+  "Returns a sequence formed by destructively removing the specified Item from
+  the given Sequence."
+  (declare (fixnum start count))
+  (when (null end) (setf end (length sequence)))
+  (let ((length (length sequence)))
+    (declare (fixnum length))
+    (seq-dispatch sequence
+		  (if from-end
+		      (normal-list-delete-from-end)
+		      (normal-list-delete))
+		  (if from-end
+		      (normal-mumble-delete-from-end)
+		      (normal-mumble-delete)))))
+
+(eval-when (compile eval)
+
+(defmacro if-mumble-delete ()
+  `(mumble-delete
+    (funcall predicate (apply-key key (aref sequence index)))))
+
+(defmacro if-mumble-delete-from-end ()
+  `(mumble-delete-from-end
+    (funcall predicate (apply-key key this-element))))
+
+(defmacro if-list-delete ()
+  '(list-delete
+    (funcall predicate (apply-key key (car current)))))
+
+(defmacro if-list-delete-from-end ()
+  '(list-delete-from-end
+    (funcall predicate (apply-key key (car current)))))
+
+)
+
+(defun delete-if (predicate sequence &key from-end (start 0) key
+			    end (count most-positive-fixnum))
+  "Returns a sequence formed by destructively removing the elements satisfying
+  the specified Predicate from the given Sequence."
+  (declare (fixnum start count))
+  (when (null end) (setf end (length sequence)))
+  (let ((length (length sequence)))
+    (declare (fixnum length))
+    (seq-dispatch sequence
+		  (if from-end
+		      (if-list-delete-from-end)
+		      (if-list-delete))
+		  (if from-end
+		      (if-mumble-delete-from-end)
+		      (if-mumble-delete)))))
+
+(eval-when (compile eval)
+
+(defmacro if-not-mumble-delete ()
+  `(mumble-delete
+    (not (funcall predicate (apply-key key (aref sequence index))))))
+
+(defmacro if-not-mumble-delete-from-end ()
+  `(mumble-delete-from-end
+    (not (funcall predicate (apply-key key this-element)))))
+
+(defmacro if-not-list-delete ()
+  '(list-delete
+    (not (funcall predicate (apply-key key (car current))))))
+
+(defmacro if-not-list-delete-from-end ()
+  '(list-delete-from-end
+    (not (funcall predicate (apply-key key (car current))))))
+
+)
+
+(defun delete-if-not (predicate sequence &key from-end (start 0) 
+			end key (count most-positive-fixnum))
+  "Returns a sequence formed by destructively removing the elements not
+  satisfying the specified Predicate from the given Sequence."
+  (declare (fixnum start count))
+  (when (null end) (setf end (length sequence)))
+  (let ((length (length sequence)))
+    (declare (fixnum length))
+    (seq-dispatch sequence
+		  (if from-end
+		      (if-not-list-delete-from-end)
+		      (if-not-list-delete))
+		  (if from-end
+		      (if-not-mumble-delete-from-end)
+		      (if-not-mumble-delete)))))
+
+
+;;; Remove:
+
+(eval-when (compile eval)
+
+;;; MUMBLE-REMOVE-MACRO does not include (removes) each element that
+;;; satisfies the predicate.
+(defmacro mumble-remove-macro (bump left begin finish right pred)
+  `(do ((index ,begin (,bump index))
+	(result
+	 (do ((index ,left (,bump index))
+	      (result (make-sequence-like sequence length)))
+	     ((= index (the fixnum ,begin)) result)
+	   (declare (fixnum index))
+	   (setf (aref result index) (aref sequence index))))
+	(new-index ,begin)
+	(number-zapped 0)
+	(this-element))
+       ((or (= index (the fixnum ,finish)) (= number-zapped (the fixnum count)))
+	(do ((index index (,bump index))
+	     (new-index new-index (,bump new-index)))
+	    ((= index (the fixnum ,right)) (shrink-vector result new-index))
+	  (declare (fixnum index new-index))
+	  (setf (aref result new-index) (aref sequence index))))
+     (declare (fixnum index new-index number-zapped))
+     (setq this-element (aref sequence index))
+     (cond (,pred (setq number-zapped (1+ number-zapped)))
+	   (t (setf (aref result new-index) this-element)
+	      (setq new-index (,bump new-index))))))
+
+(defmacro mumble-remove (pred)
+  `(mumble-remove-macro 1+ 0 start end length ,pred))
+
+(defmacro mumble-remove-from-end (pred)
+  `(let ((sequence (copy-seq sequence)))
+     (mumble-delete-from-end ,pred)))
+
+(defmacro normal-mumble-remove ()
+  `(mumble-remove 
+    (if test-not
+	(not (funcall test-not item (apply-key key this-element)))
+	(funcall test item (apply-key key this-element)))))
+
+(defmacro normal-mumble-remove-from-end ()
+  `(mumble-remove-from-end 
+    (if test-not
+	(not (funcall test-not item (apply-key key this-element)))
+	(funcall test item (apply-key key this-element)))))
+
+(defmacro if-mumble-remove ()
+  `(mumble-remove (funcall predicate (apply-key key this-element))))
+
+(defmacro if-mumble-remove-from-end ()
+  `(mumble-remove-from-end (funcall predicate (apply-key key this-element))))
+
+(defmacro if-not-mumble-remove ()
+  `(mumble-remove (not (funcall predicate (apply-key key this-element)))))
+
+(defmacro if-not-mumble-remove-from-end ()
+  `(mumble-remove-from-end
+    (not (funcall predicate (apply-key key this-element)))))
+
+;;; LIST-REMOVE-MACRO does not include (removes) each element that satisfies
+;;; the predicate.
+(defmacro list-remove-macro (pred reverse?)
+  `(let* (,@(if reverse? '((sequence (reverse (the list sequence)))))
+	  (splice (list nil))
+	  (results (do ((index 0 (1+ index))
+			(before-start splice))
+		       ((= index (the fixnum start)) before-start)
+		     (declare (fixnum index))
+		     (setq splice
+			   (cdr (rplacd splice (list (pop sequence))))))))
+     (do ((index start (1+ index))
+	  (this-element)
+	  (number-zapped 0))
+	 ((or (= index (the fixnum end)) (= number-zapped (the fixnum count)))
+	  (do ((index index (1+ index)))
+	      ((null sequence)
+	       ,(if reverse?
+		    '(nreverse (the list (cdr results)))
+		    '(cdr results)))
+	    (declare (fixnum index))
+	    (setq splice (cdr (rplacd splice (list (pop sequence)))))))
+       (declare (fixnum index number-zapped))
+       (setq this-element (pop sequence))
+       (if ,pred
+	   (setq number-zapped (1+ number-zapped))
+	   (setq splice (cdr (rplacd splice (list this-element))))))))
+
+(defmacro list-remove (pred)
+  `(list-remove-macro ,pred nil))
+
+(defmacro list-remove-from-end (pred)
+  `(list-remove-macro ,pred t))
+
+(defmacro normal-list-remove ()
+  `(list-remove
+    (if test-not
+	(not (funcall test-not item (apply-key key this-element)))
+	(funcall test item (apply-key key this-element)))))
+
+(defmacro normal-list-remove-from-end ()
+  `(list-remove-from-end
+    (if test-not
+	(not (funcall test-not item (apply-key key this-element)))
+	(funcall test item (apply-key key this-element)))))
+
+(defmacro if-list-remove ()
+  `(list-remove
+    (funcall predicate (apply-key key this-element))))
+
+(defmacro if-list-remove-from-end ()
+  `(list-remove-from-end
+    (funcall predicate (apply-key key this-element))))
+
+(defmacro if-not-list-remove ()
+  `(list-remove
+    (not (funcall predicate (apply-key key this-element)))))
+
+(defmacro if-not-list-remove-from-end ()
+  `(list-remove-from-end
+    (not (funcall predicate (apply-key key this-element)))))
+
+)
+
+(defun remove (item sequence &key from-end (test #'eql) test-not (start 0)
+		end (count most-positive-fixnum) key)
+  "Returns a copy of SEQUENCE with elements satisfying the test (default is
+   EQL) with ITEM removed."
+  (declare (fixnum start count))
+  (when (null end) (setf end (length sequence)))
+  (let ((length (length sequence)))
+    (declare (fixnum length))
+    (seq-dispatch sequence
+		  (if from-end
+		      (normal-list-remove-from-end)
+		      (normal-list-remove))
+		  (if from-end
+		      (normal-mumble-remove-from-end)
+		      (normal-mumble-remove)))))
+
+(defun remove-if (predicate sequence &key from-end (start 0)
+		    end (count most-positive-fixnum) key)
+  "Returns a copy of sequence with elements such that predicate(element)
+   is non-null are removed"
+  (declare (fixnum start count))
+  (when (null end) (setf end (length sequence)))
+  (let ((length (length sequence)))
+    (declare (fixnum length))
+    (seq-dispatch sequence
+		  (if from-end
+		      (if-list-remove-from-end)
+		      (if-list-remove))
+		  (if from-end
+		      (if-mumble-remove-from-end)
+		      (if-mumble-remove)))))
+
+(defun remove-if-not (predicate sequence &key
+				from-end (start 0) end
+				(count most-positive-fixnum) key)
+  "Returns a copy of sequence with elements such that predicate(element)
+   is null are removed"
+  (declare (fixnum start count))
+  (when (null end) (setf end (length sequence)))
+  (let ((length (length sequence)))
+    (declare (fixnum length))
+    (seq-dispatch sequence
+		  (if from-end
+		      (if-not-list-remove-from-end)
+		      (if-not-list-remove))
+		  (if from-end
+		      (if-not-mumble-remove-from-end)
+		      (if-not-mumble-remove)))))
+
+
+;;; Remove-Duplicates:
+     
+;;; Remove duplicates from a list. If from-end, remove the later duplicates,
+;;; not the earlier ones. Thus if we check from-end we don't copy an item
+;;; if we look into the already copied structure (from after :start) and see
+;;; the item. If we check from beginning we check into the rest of the 
+;;; original list up to the :end marker (this we have to do by running a
+;;; do loop down the list that far and using our test.
+(defun list-remove-duplicates* (list test test-not start end key from-end)
+  (declare (fixnum start))
+  (let* ((result (list ())) ; Put a marker on the beginning to splice with.
+	 (splice result)
+	 (current list))
+    (do ((index 0 (1+ index)))
+	((= index start))
+      (declare (fixnum index))
+      (setq splice (cdr (rplacd splice (list (car current)))))
+      (setq current (cdr current)))
+    (do ((index 0 (1+ index)))
+	((or (and end (= index (the fixnum end)))
+	     (atom current)))
+      (declare (fixnum index))
+      (if (or (and from-end 
+	           (not (member (apply-key key (car current))
+				(nthcdr start result)
+				:test test
+				:test-not test-not
+				:key (if key key #'identity))))
+	      (and (not from-end)
+		   (not (do ((it (apply-key key (car current)))
+			     (l (cdr current) (cdr l))
+			     (i (1+ index) (1+ i)))
+			    ((or (atom l) (and end (= i (the fixnum end))))
+			     ())
+			  (declare (fixnum i))
+			  (if (if test-not
+				  (not (funcall test-not (apply-key key (car l)) it))
+				  (funcall test (apply-key key (car l)) it))
+			      (return t))))))
+	  (setq splice (cdr (rplacd splice (list (car current))))))
+      (setq current (cdr current)))
+    (do ()
+	((atom current))
+      (setq splice (cdr (rplacd splice (list (car current)))))
+      (setq current (cdr current)))
+    (cdr result)))
+
+
+
+(defun vector-remove-duplicates* (vector test test-not start end key from-end
+					 &optional (length (length vector)))
+  (declare (vector vector) (fixnum start length))
+  (when (null end) (setf end (length vector)))
+  (let ((result (make-sequence-like vector length))
+	(index 0)
+	(jndex start))
+    (declare (fixnum index jndex))
+    (do ()
+	((= index start))
+      (setf (aref result index) (aref vector index))
+      (setq index (1+ index)))
+    (do ((elt))
+	((= index end))
+      (setq elt (aref vector index))
+      (unless (or (and from-end
+		        (position (apply-key key elt) result :start start
+			   :end jndex :test test :test-not test-not :key key))
+		  (and (not from-end)
+		        (position (apply-key key elt) vector :start (1+ index)
+			   :end end :test test :test-not test-not :key key)))
+	(setf (aref result jndex) elt)
+	(setq jndex (1+ jndex)))
+      (setq index (1+ index)))
+    (do ()
+	((= index length))
+      (setf (aref result jndex) (aref vector index))
+      (setq index (1+ index))
+      (setq jndex (1+ jndex)))
+    (shrink-vector result jndex)))
+
+
+(defun remove-duplicates (sequence &key (test #'eql) test-not (start 0) from-end
+				   end key)
+  "The elements of Sequence are examined, and if any two match, one is
+   discarded.  The resulting sequence is returned."
+  (declare (fixnum start))
+  (seq-dispatch sequence
+		(if sequence
+		    (list-remove-duplicates* sequence test test-not
+					      start end key from-end))
+		(vector-remove-duplicates* sequence test test-not
+					    start end key from-end)))
+
+
+
+;;; Delete-Duplicates:
+
+
+(defun list-delete-duplicates* (list test test-not key from-end start end)
+  (declare (fixnum start))
+  (let ((handle (cons nil list)))
+    (do ((current (nthcdr start list) (cdr current))
+	 (previous (nthcdr start handle))
+	 (index start (1+ index)))
+	((or (and end (= index (the fixnum end))) (null current))
+	 (cdr handle))
+      (declare (fixnum index))
+      (if (do ((x (if from-end 
+		      (nthcdr (1+ start) handle)
+		      (cdr current))
+		  (cdr x))
+	       (i (1+ index) (1+ i)))
+	      ((or (null x)
+		   (and (not from-end) end (= i (the fixnum end)))
+		   (eq x current))
+	       nil)
+	    (declare (fixnum i))
+	    (if (if test-not
+		    (not (funcall test-not 
+				  (apply-key key (car current))
+				  (apply-key key (car x))))
+		    (funcall test 
+			     (apply-key key (car current)) 
+			     (apply-key key (car x))))
+		(return t)))
+	  (rplacd previous (cdr current))
+	  (setq previous (cdr previous))))))
+
+
+(defun vector-delete-duplicates* (vector test test-not key from-end start end 
+					 &optional (length (length vector)))
+  (declare (vector vector) (fixnum start length))
+  (when (null end) (setf end (length vector)))
+  (do ((index start (1+ index))
+       (jndex start))
+      ((= index end)
+       (do ((index index (1+ index))		; copy the rest of the vector
+	    (jndex jndex (1+ jndex)))
+	   ((= index length)
+	    (shrink-vector vector jndex)
+	    vector)
+	 (setf (aref vector jndex) (aref vector index))))
+    (declare (fixnum index jndex))
+    (setf (aref vector jndex) (aref vector index))
+    (unless (position (apply-key key (aref vector index)) vector :key key
+		      :start (if from-end start (1+ index)) :test test
+		      :end (if from-end jndex end) :test-not test-not)
+      (setq jndex (1+ jndex)))))
+
+
+(defun delete-duplicates (sequence &key (test #'eql) test-not (start 0) from-end
+			    end key)
+  "The elements of Sequence are examined, and if any two match, one is
+   discarded.  The resulting sequence, which may be formed by destroying the
+   given sequence, is returned."
+  (seq-dispatch sequence
+    (if sequence
+	(list-delete-duplicates* sequence test test-not key from-end start end))
+  (vector-delete-duplicates* sequence test test-not key from-end start end)))
+
+(defun list-substitute* (pred new list start end count key test test-not old)
+  (declare (fixnum start end count))
+  (let* ((result (list nil))
+	 elt
+	 (splice result)
+	 (list list))           ; Get a local list for a stepper.
+    (do ((index 0 (1+ index)))
+	((= index start))
+      (declare (fixnum index))
+      (setq splice (cdr (rplacd splice (list (car list)))))
+      (setq list (cdr list)))
+    (do ((index start (1+ index)))
+	((or (= index end) (null list) (= count 0)))
+      (declare (fixnum index))
+      (setq elt (car list))
+      (setq splice
+	    (cdr (rplacd splice
+			 (list
+			  (cond
+			   ((case pred
+				   (normal
+				    (if test-not
+					(not 
+					 (funcall test-not (apply-key key elt) old))
+					(funcall test (apply-key key elt) old)))
+				   (if (funcall test (apply-key key elt)))
+				   (if-not (not (funcall test (apply-key key elt)))))
+			    (setq count (1- count))
+			    new)
+				(t elt))))))
+      (setq list (cdr list)))
+    (do ()
+	((null list))
+      (setq splice (cdr (rplacd splice (list (car list)))))
+      (setq list (cdr list)))
+    (cdr result)))
+
+;;; Replace old with new in sequence moving from left to right by incrementer
+;;; on each pass through the loop. Called by all three substitute functions.
+(defun vector-substitute* (pred new sequence incrementer left right length
+			   start end count key test test-not old)
+  (declare (fixnum start count end incrementer right))
+  (let ((result (make-sequence-like sequence length))
+	(index left))
+    (declare (fixnum index))
+    (do ()
+	((= index start))
+      (setf (aref result index) (aref sequence index))
+      (setq index (+ index incrementer)))
+    (do ((elt))
+	((or (= index end) (= count 0)))
+      (setq elt (aref sequence index))
+      (setf (aref result index) 
+	    (cond ((case pred
+			  (normal
+			    (if test-not
+				(not (funcall test-not (apply-key key elt) old))
+				(funcall test (apply-key key elt) old)))
+			  (if (funcall test (apply-key key elt)))
+			  (if-not (not (funcall test (apply-key key elt)))))
+		   (setq count (1- count))
+		   new)
+		  (t elt)))
+      (setq index (+ index incrementer)))
+    (do ()
+	((= index right))
+      (setf (aref result index) (aref sequence index))
+      (setq index (+ index incrementer)))
+    result))
+
+(eval-when (compile eval)
+
+
+(defmacro subst-dispatch (pred)
+ `(if (listp sequence)
+      (if from-end
+	  (nreverse (list-substitute* ,pred new (reverse sequence)
+				      (- (the fixnum length) (the fixnum end))
+				      (- (the fixnum length) (the fixnum start))
+				      count key test test-not old))
+	  (list-substitute* ,pred new sequence start end count key test test-not
+			    old))
+      (if from-end
+	  (vector-substitute* ,pred new sequence -1 (1- (the fixnum length))
+			      -1 length (1- (the fixnum end))
+			      (1- (the fixnum start)) count key test test-not old)
+	  (vector-substitute* ,pred new sequence 1 0 length length
+	   start end count key test test-not old))))
+
+)
+
+
+;;; Substitute:
+
+(defun substitute (new old sequence &key from-end (test #'eql) test-not
+		   (start 0) (count most-positive-fixnum)
+		   end key)
+  "Returns a sequence of the same kind as Sequence with the same elements
+  except that all elements equal to Old are replaced with New.  See manual
+  for details."
+  (declare (fixnum start count))
+  (when (null end) (setf end (length sequence)))
+  (let ((length (length sequence))
+	(old (apply-key key old)))
+    (declare (fixnum length))
+    (subst-dispatch 'normal)))
+
+
+;;; Substitute-If:
+
+(defun substitute-if (new test sequence &key from-end (start 0)
+		       end (count most-positive-fixnum) key)
+  "Returns a sequence of the same kind as Sequence with the same elements
+  except that all elements satisfying the Test are replaced with New.  See
+  manual for details."
+  (declare (fixnum start count))
+  (when (null end) (setf end (length sequence)))
+  (let ((length (length sequence))
+	test-not
+	old)
+    (declare (fixnum length))
+    (subst-dispatch 'if)))
+  
+
+;;; Substitute-If-Not:
+
+(defun substitute-if-not (new test sequence &key from-end (start 0)
+			   end (count most-positive-fixnum) key)
+  "Returns a sequence of the same kind as Sequence with the same elements
+  except that all elements not satisfying the Test are replaced with New.
+  See manual for details."
+  (declare (fixnum start count))
+  (when (null end) (setf end (length sequence)))
+  (let ((length (length sequence))
+	test-not
+	old)
+    (declare (fixnum length))
+    (subst-dispatch 'if-not)))
+
+
+
+;;; NSubstitute:
+
+(defun nsubstitute (new old sequence &key from-end (test #'eql) test-not 
+		     end (count most-positive-fixnum) key (start 0))
+  "Returns a sequence of the same kind as Sequence with the same elements
+  except that all elements equal to Old are replaced with New.  The Sequence
+  may be destroyed.  See manual for details."
+  (declare (fixnum count start))
+  (when (null end) (setf end (length sequence)))
+  (let ((incrementer 1))
+    (declare (fixnum incrementer))
+    (if from-end
+	(psetq start (1- end)
+	       end (1- start)
+	       incrementer -1))
+    (if (listp sequence)
+	(if from-end
+	    (nreverse (nlist-substitute*
+		       new old (nreverse (the list sequence))
+		       test test-not start end count key))
+	    (nlist-substitute* new old sequence
+			       test test-not start end count key))
+	(nvector-substitute* new old sequence incrementer
+			     test test-not start end count key))))
+
+(defun nlist-substitute* (new old sequence test test-not start end count key)
+  (declare (fixnum start count end))
+  (do ((list (nthcdr start sequence) (cdr list))
+       (index start (1+ index)))
+      ((or (= index end) (null list) (= count 0)) sequence)
+    (declare (fixnum index))
+    (when (if test-not
+	      (not (funcall test-not (apply-key key (car list)) old))
+	      (funcall test (apply-key key (car list)) old))
+      (rplaca list new)
+      (setq count (1- count)))))
+
+(defun nvector-substitute* (new old sequence incrementer
+			    test test-not start end count key)
+  (declare (fixnum start incrementer count end))
+  (do ((index start (+ index incrementer)))
+      ((or (= index end) (= count 0)) sequence)
+    (declare (fixnum index))
+    (when (if test-not
+	      (not (funcall test-not (apply-key key (aref sequence index)) old))
+	      (funcall test (apply-key key (aref sequence index)) old))
+      (setf (aref sequence index) new)
+      (setq count (1- count)))))
+
+
+;;; NSubstitute-If:
+
+(defun nsubstitute-if (new test sequence &key from-end (start 0)
+			end (count most-positive-fixnum) key)
+  "Returns a sequence of the same kind as Sequence with the same elements
+  except that all elements satisfying the Test are replaced with New.  The
+  Sequence may be destroyed.  See manual for details."
+  (declare (fixnum start count))
+  (when (null end) (setf end (length sequence)))
+  (let ((incrementer 1))
+    (declare (fixnum incrementer))
+    (if from-end
+	(psetq start (1- end)
+	       end (1- start)
+	       incrementer -1))
+    (if (listp sequence)
+	(if from-end
+	    (nreverse (nlist-substitute-if*
+		       new test (nreverse (the list sequence))
+		       start end count key))
+	    (nlist-substitute-if* new test sequence
+				  start end count key))
+	(nvector-substitute-if* new test sequence incrementer
+				start end count key))))
+
+(defun nlist-substitute-if* (new test sequence start end count key)
+  (declare (fixnum end))
+  (do ((list (nthcdr start sequence) (cdr list))
+       (index start (1+ index)))
+      ((or (= index end) (null list) (= count 0)) sequence)
+    (when (funcall test (apply-key key (car list)))
+      (rplaca list new)
+      (setq count (1- count)))))
+
+(defun nvector-substitute-if* (new test sequence incrementer
+			       start end count key)
+  (do ((index start (+ index incrementer)))
+      ((or (= index end) (= count 0)) sequence)
+    (when (funcall test (apply-key key (aref sequence index)))
+      (setf (aref sequence index) new)
+      (setq count (1- count)))))
+
+
+;;; NSubstitute-If-Not:
+
+(defun nsubstitute-if-not (new test sequence &key from-end (start 0)
+			    end (count most-positive-fixnum) key)
+  "Returns a sequence of the same kind as Sequence with the same elements
+  except that all elements not satisfying the Test are replaced with New.
+  The Sequence may be destroyed.  See manual for details."
+  (declare (fixnum start end count))
+  (when (null end) (setf end (length sequence)))
+  (let ((incrementer 1))
+    (if from-end
+	(psetq start (1- end)
+	       end (1- start)
+	       incrementer -1))
+    (if (listp sequence)
+	(if from-end
+	    (nreverse (nlist-substitute-if-not*
+		       new test (nreverse (the list sequence))
+		       start end count key))
+	    (nlist-substitute-if-not* new test sequence
+				      start end count key))
+	(nvector-substitute-if-not* new test sequence incrementer
+				    start end count key))))
+
+(defun nlist-substitute-if-not* (new test sequence start end count key)
+  (declare (fixnum end))
+  (do ((list (nthcdr start sequence) (cdr list))
+       (index start (1+ index)))
+      ((or (= index end) (null list) (= count 0)) sequence)
+    (when (not (funcall test (apply-key key (car list))))
+      (rplaca list new)
+      (setq count (1- count)))))
+
+(defun nvector-substitute-if-not* (new test sequence incrementer
+				   start end count key)
+  (do ((index start (+ index incrementer)))
+      ((or (= index end) (= count 0)) sequence)
+    (when (not (funcall test (apply-key key (aref sequence index))))
+      (setf (aref sequence index) new)
+      (setq count (1- count)))))
+
+
+;;; Locater macros used by FIND and POSITION.
+
+(eval-when (compile eval)
+
+(defmacro vector-locater-macro (sequence body-form return-type)
+  `(let ((incrementer (if from-end -1 1))
+	 (start (if from-end (1- (the fixnum end)) start))
+	 (end (if from-end (1- (the fixnum start)) end)))
+     (declare (fixnum start end incrementer))
+     (do ((index start (+ index incrementer))
+	  ,@(case return-type (:position nil) (:element '(current))))
+	 ((= index end) ())
+       (declare (fixnum index))
+       ,@(case return-type
+	   (:position nil)
+	   (:element `((setf current (aref ,sequence index)))))
+       ,body-form)))
+
+(defmacro locater-test-not (item sequence seq-type return-type)
+  (let ((seq-ref (case return-type
+		   (:position
+		    (case seq-type
+		      (:vector `(aref ,sequence index))
+		      (:list `(pop ,sequence))))
+		   (:element 'current)))
+	(return (case return-type
+		  (:position 'index)
+		  (:element 'current))))
+    `(if test-not
+	 (if (not (funcall test-not ,item (apply-key key ,seq-ref)))
+	     (return ,return))
+	 (if (funcall test ,item (apply-key key ,seq-ref))
+	     (return ,return)))))
+
+(defmacro vector-locater (item sequence return-type)
+  `(vector-locater-macro ,sequence
+			 (locater-test-not ,item ,sequence :vector ,return-type)
+			 ,return-type))
+
+(defmacro locater-if-test (test sequence seq-type return-type sense)
+  (let ((seq-ref (case return-type
+		   (:position
+		    (case seq-type
+		      (:vector `(aref ,sequence index))
+		      (:list `(pop ,sequence))))
+		   (:element 'current)))
+	(return (case return-type
+		  (:position 'index)
+		  (:element 'current))))
+    (if sense
+	`(if (funcall ,test (apply-key key ,seq-ref))
+	     (return ,return))
+	`(if (not (funcall ,test (apply-key key ,seq-ref)))
+	     (return ,return)))))
+
+(defmacro vector-locater-if-macro (test sequence return-type sense)
+  `(vector-locater-macro ,sequence
+			 (locater-if-test ,test ,sequence :vector ,return-type ,sense)
+			 ,return-type))
+
+(defmacro vector-locater-if (test sequence return-type)
+  `(vector-locater-if-macro ,test ,sequence ,return-type t))
+
+(defmacro vector-locater-if-not (test sequence return-type)
+  `(vector-locater-if-macro ,test ,sequence ,return-type nil))
+
+
+(defmacro list-locater-macro (sequence body-form return-type)
+  `(if from-end
+       (do ((sequence (nthcdr (- (the fixnum (length sequence))
+				 (the fixnum end))
+			      (reverse (the list ,sequence))))
+	    (index (1- (the fixnum end)) (1- index))
+	    (terminus (1- (the fixnum start)))
+	    ,@(case return-type (:position nil) (:element '(current))))
+	   ((or (= index terminus) (null sequence)) ())
+	 (declare (fixnum index terminus))
+	 ,@(case return-type
+	     (:position nil)
+	     (:element `((setf current (pop ,sequence)))))
+	 ,body-form)
+       (do ((sequence (nthcdr start ,sequence))
+	    (index start (1+ index))
+	    ,@(case return-type (:position nil) (:element '(current))))
+	   ((or (= index (the fixnum end)) (null sequence)) ())
+	 (declare (fixnum index))
+	 ,@(case return-type
+	     (:position nil)
+	     (:element `((setf current (pop ,sequence)))))
+	 ,body-form)))
+
+(defmacro list-locater (item sequence return-type)
+  `(list-locater-macro ,sequence
+		       (locater-test-not ,item ,sequence :list ,return-type)
+		       ,return-type))
+
+(defmacro list-locater-if-macro (test sequence return-type sense)
+  `(list-locater-macro ,sequence
+		       (locater-if-test ,test ,sequence :list ,return-type ,sense)
+		       ,return-type))
+
+(defmacro list-locater-if (test sequence return-type)
+  `(list-locater-if-macro ,test ,sequence ,return-type t))
+
+(defmacro list-locater-if-not (test sequence return-type)
+  `(list-locater-if-macro ,test ,sequence ,return-type nil))
+
+) ; eval-when
+
+
+;;; Position:
+
+(eval-when (compile eval)
+
+(defmacro vector-position (item sequence)
+  `(vector-locater ,item ,sequence :position))
+
+(defmacro list-position (item sequence)
+  `(list-locater ,item ,sequence :position))
+
+) ; eval-when
+
+
+;;; POSITION cannot default end to the length of sequence since it is not
+;;; an error to supply nil for its value.  We must test for end being nil
+;;; in the body of the function, and this is actually done in the support
+;;; routines for other reasons (see below).
+(defun position (item sequence &key from-end (test #'eql) test-not (start 0)
+		  end key)
+  "Returns the zero-origin index of the first element in SEQUENCE
+   satisfying the test (default is EQL) with the given ITEM"
+  (seq-dispatch sequence
+    (list-position* item sequence from-end test test-not start end key)
+    (vector-position* item sequence from-end test test-not start end key)))
+
+
+;;; The support routines for SUBSEQ are used by compiler transforms, so we
+;;; worry about dealing with end being supplied as or defaulting to nil
+;;; at this level.
+
+(defun list-position* (item sequence from-end test test-not start end key)
+  (declare (fixnum start))
+  (when (null end) (setf end (length sequence)))
+  (list-position item sequence))
+
+(defun vector-position* (item sequence from-end test test-not start end key)
+  (declare (fixnum start))
+  (when (null end) (setf end (length sequence)))
+  (vector-position item sequence))
+
+
+;;; Position-if:
+
+(eval-when (compile eval)
+
+(defmacro vector-position-if (test sequence)
+  `(vector-locater-if ,test ,sequence :position))
+
+
+(defmacro list-position-if (test sequence)
+  `(list-locater-if ,test ,sequence :position))
+
+)
+
+(defun position-if (test sequence &key from-end (start 0) key end)
+  "Returns the zero-origin index of the first element satisfying test(el)"
+  (declare (fixnum start))
+  (when (null end) (setf end (length sequence)))
+  (seq-dispatch sequence
+		(list-position-if test sequence)
+		(vector-position-if test sequence)))
+
+
+;;; Position-if-not:
+
+(eval-when (compile eval)
+
+(defmacro vector-position-if-not (test sequence)
+  `(vector-locater-if-not ,test ,sequence :position))
+
+(defmacro list-position-if-not (test sequence)
+  `(list-locater-if-not ,test ,sequence :position))
+
+)
+
+(defun position-if-not (test sequence &key from-end (start 0) key end)
+  "Returns the zero-origin index of the first element not satisfying test(el)"
+  (declare (fixnum start))
+  (when (null end) (setf end (length sequence)))
+  (seq-dispatch sequence
+		(list-position-if-not test sequence)
+		(vector-position-if-not test sequence)))
+
+
+;;; Find:
+
+(eval-when (compile eval)
+
+(defmacro vector-find (item sequence)
+  `(vector-locater ,item ,sequence :element))
+
+(defmacro list-find (item sequence)
+  `(list-locater ,item ,sequence :element))
+
+)
+
+;;; FIND cannot default end to the length of sequence since it is not
+;;; an error to supply nil for its value.  We must test for end being nil
+;;; in the body of the function, and this is actually done in the support
+;;; routines for other reasons (see above).
+(defun find (item sequence &key from-end (test #'eql) test-not (start 0)
+	       end key)
+  "Returns the first element in SEQUENCE satisfying the test (default
+   is EQL) with the given ITEM"
+  (declare (fixnum start))
+  (seq-dispatch sequence
+    (list-find* item sequence from-end test test-not start end key)
+    (vector-find* item sequence from-end test test-not start end key))))
+
+
+;;; The support routines for FIND are used by compiler transforms, so we
+;;; worry about dealing with end being supplied as or defaulting to nil
+;;; at this level.
+
+(defun list-find* (item sequence from-end test test-not start end key)
+  (when (null end) (setf end (length sequence)))
+  (list-find item sequence))
+
+(defun vector-find* (item sequence from-end test test-not start end key)
+  (when (null end) (setf end (length sequence)))
+  (vector-find item sequence))
+
+
+;;; Find-if:
+
+(eval-when (compile eval)
+
+(defmacro vector-find-if (test sequence)
+  `(vector-locater-if ,test ,sequence :element))
+
+(defmacro list-find-if (test sequence)
+  `(list-locater-if ,test ,sequence :element))
+
+)
+
+(defun find-if (test sequence &key from-end (start 0) end key)
+  "Returns the zero-origin index of the first element satisfying the test."
+  (declare (fixnum start))
+  (when (null end) (setf end (length sequence)))
+  (seq-dispatch sequence
+		(list-find-if test sequence)
+		(vector-find-if test sequence)))
+
+
+;;; Find-if-not:
+
+(eval-when (compile eval)
+
+(defmacro vector-find-if-not (test sequence)
+  `(vector-locater-if-not ,test ,sequence :element))
+
+(defmacro list-find-if-not (test sequence)
+  `(list-locater-if-not ,test ,sequence :element))
+
+)
+
+(defun find-if-not (test sequence &key from-end (start 0) end key)
+  "Returns the zero-origin index of the first element not satisfying the test."
+  (declare (fixnum start))
+  (when (null end) (setf end (length sequence)))
+  (seq-dispatch sequence
+		(list-find-if-not test sequence)
+		(vector-find-if-not test sequence)))
+
+
+;;; Count:
+
+(eval-when (compile eval)
+
+(defmacro vector-count (item sequence)
+  `(do ((index start (1+ index))
+	(count 0))
+       ((= index (the fixnum end)) count)
+     (declare (fixnum index count))
+     (if test-not
+	 (if (funcall test-not ,item (apply-key key (aref ,sequence index)))
+	     (setq count (1+ count)))
+	 (if (funcall test ,item (apply-key key (aref ,sequence index)))
+	     (setq count (1+ count))))))
+
+(defmacro list-count (item sequence)
+  `(do ((sequence (nthcdr start ,sequence))
+	(index start (1+ index))
+	(count 0))
+       ((or (= index (the fixnum end)) (null sequence)) count)
+     (declare (fixnum index count))
+     (if test-not
+	 (if (funcall test-not ,item (apply-key key (pop sequence)))
+	     (setq count (1+ count)))
+	 (if (funcall test ,item (apply-key key (pop sequence)))
+	     (setq count (1+ count))))))
+
+)
+
+(defun count (item sequence &key from-end (test #'eql) test-not (start 0)
+		end key)
+  "Returns the number of elements in SEQUENCE satisfying a test with ITEM,
+   which defaults to EQL."
+  (declare (ignore from-end) (fixnum start))
+  (when (null end) (setf end (length sequence)))
+  (seq-dispatch sequence
+		(list-count item sequence)
+		(vector-count item sequence)))
+
+
+;;; Count-if:
+
+(eval-when (compile eval)
+
+(defmacro vector-count-if (predicate sequence)
+  `(do ((index start (1+ index))
+	(count 0))
+       ((= index (the fixnum end)) count)
+     (declare (fixnum index count))
+     (if (funcall ,predicate (apply-key key (aref ,sequence index)))
+	 (setq count (1+ count)))))
+
+(defmacro list-count-if (predicate sequence)
+  `(do ((sequence (nthcdr start ,sequence))
+	(index start (1+ index))
+	(count 0))
+       ((or (= index (the fixnum end)) (null sequence)) count)
+     (declare (fixnum index count))
+     (if (funcall ,predicate (apply-key key (pop sequence)))
+	 (setq count (1+ count)))))
+
+)
+
+(defun count-if (test sequence &key from-end (start 0) end key)
+  "Returns the number of elements in SEQUENCE satisfying TEST(el)."
+  (declare (ignore from-end) (fixnum start))
+  (when (null end) (setf end (length sequence)))
+  (seq-dispatch sequence
+		(list-count-if test sequence)
+		(vector-count-if test sequence)))
+
+
+;;; Count-if-not:
+
+(eval-when (compile eval)
+
+(defmacro vector-count-if-not (predicate sequence)
+  `(do ((index start (1+ index))
+	(count 0))
+       ((= index (the fixnum end)) count)
+     (declare (fixnum index count))
+     (if (not (funcall ,predicate (apply-key key (aref ,sequence index))))
+	 (setq count (1+ count)))))
+
+(defmacro list-count-if-not (predicate sequence)
+  `(do ((sequence (nthcdr start ,sequence))
+	(index start (1+ index))
+	(count 0))
+       ((or (= index (the fixnum end)) (null sequence)) count)
+     (declare (fixnum index count))
+     (if (not (funcall ,predicate (apply-key key (pop sequence))))
+	 (setq count (1+ count)))))
+
+)
+
+(defun count-if-not (test sequence &key from-end (start 0) end key)
+  "Returns the number of elements in SEQUENCE not satisfying TEST(el)."
+  (declare (ignore from-end) (fixnum start))
+  (when (null end) (setf end (length sequence)))
+  (seq-dispatch sequence
+		(list-count-if-not test sequence)
+		(vector-count-if-not test sequence)))
+
+
+;;; Mismatch utilities:
+
+(eval-when (compile eval)
+
+
+(defmacro match-vars (&rest body)
+  `(let ((inc (if from-end -1 1))
+	 (start1 (if from-end (1- (the fixnum end1)) start1))
+	 (start2 (if from-end (1- (the fixnum end2)) start2))
+	 (end1 (if from-end (1- (the fixnum start1)) end1))
+	 (end2 (if from-end (1- (the fixnum start2)) end2)))
+     (declare (fixnum inc start1 start2 end1 end2))
+     ,@body))
+
+(defmacro matchify-list (sequence start length end)
+  `(setq ,sequence
+	 (if from-end
+	     (nthcdr (- (the fixnum ,length) (the fixnum ,start) 1)
+		     (reverse (the list ,sequence)))
+	     (nthcdr ,start ,sequence))))
+
+)
+
+;;; Mismatch:
+
+(eval-when (compile eval)
+
+(defmacro if-mismatch (elt1 elt2)
+  `(cond ((= (the fixnum index1) (the fixnum end1))
+	  (return (if (= (the fixnum index2) (the fixnum end2))
+		      nil
+		      (if from-end
+			  (1+ (the fixnum index1))
+			  (the fixnum index1)))))
+	 ((= (the fixnum index2) (the fixnum end2))
+	  (return (if from-end (1+ (the fixnum index1)) index1)))
+	 (test-not
+	  (if (funcall test-not (apply-key key ,elt1) (apply-key key ,elt2))
+	      (return (if from-end (1+ (the fixnum index1)) index1))))
+	 (t (if (not (funcall test (apply-key key ,elt1) (apply-key key ,elt2)))
+		(return (if from-end (1+ (the fixnum index1)) index1))))))
+
+(defmacro mumble-mumble-mismatch ()
+  `(do ((index1 start1 (+ index1 (the fixnum inc)))
+	(index2 start2 (+ index2 (the fixnum inc))))
+       (())
+     (declare (fixnum index1 index2))
+     (if-mismatch (aref sequence1 index1) (aref sequence2 index2))))
+
+(defmacro mumble-list-mismatch ()
+  `(do ((index1 start1 (+ index1 (the fixnum inc)))
+	(index2 start2 (+ index2 (the fixnum inc))))
+       (())
+     (declare (fixnum index1 index2))
+     (if-mismatch (aref sequence1 index1) (pop sequence2))))
+
+(defmacro list-mumble-mismatch ()
+  `(do ((index1 start1 (+ index1 (the fixnum inc)))
+	(index2 start2 (+ index2 (the fixnum inc))))
+       (())
+     (declare (fixnum index1 index2))
+     (if-mismatch (pop sequence1) (aref sequence2 index2))))
+
+(defmacro list-list-mismatch ()
+  `(do ((index1 start1 (+ index1 (the fixnum inc)))
+	(index2 start2 (+ index2 (the fixnum inc))))
+       (())
+     (declare (fixnum index1 index2))
+     (if-mismatch (pop sequence1) (pop sequence2))))
+
+)
+
+(defun mismatch (sequence1 sequence2 &key from-end (test #'eql) test-not 
+			   (start1 0) end1 (start2 0) end2 key)
+  "The specified subsequences of Sequence1 and Sequence2 are compared
+  element-wise.  If they are of equal length and match in every element, the
+  result is Nil.  Otherwise, the result is a non-negative integer, the index
+  within Sequence1 of the leftmost position at which they fail to match; or, if
+  one is shorter than and a matching prefix of the other, the index within
+  Sequence1 beyond the last position tested is returned.  If a non-Nil :From-End
+  keyword argument is given, then one plus the index of the rightmost position in
+  which the sequences differ is returned."
+  (declare (fixnum start1 start2))
+  (when (null end1) (setf end1 (length sequence1)))
+  (when (null end2) (setf end2 (length sequence2)))
+  (let ((length1 (length sequence1))
+	(length2 (length sequence2)))
+    (declare (fixnum length1 length2))
+    (match-vars
+     (seq-dispatch sequence1
+      (progn (matchify-list sequence1 start1 length1 end1)
+	     (seq-dispatch sequence2
+			   (progn (matchify-list sequence2 start2 length2 end2)
+				  (list-list-mismatch))
+			   (list-mumble-mismatch)))
+      (seq-dispatch sequence2
+		    (progn (matchify-list sequence2 start2 length2 end2)
+			   (mumble-list-mismatch))
+		    (mumble-mumble-mismatch))))))
+
+
+;;; Search comparison functions:
+
+(eval-when (compile eval)
+
+;;; Compare two elements and return if they don't match:
+
+(defmacro compare-elements (elt1 elt2)
+  `(if test-not
+       (if (funcall test-not (apply-key key ,elt1) (apply-key key ,elt2))
+	   (return nil)
+	   t)
+       (if (not (funcall test (apply-key key ,elt1) (apply-key key ,elt2)))
+	   (return nil)
+	   t)))
+
+(defmacro search-compare-list-list (main sub)
+  `(do ((main ,main (cdr main))
+	(jndex start1 (1+ jndex))
+	(sub (nthcdr start1 ,sub) (cdr sub)))
+       ((or (null main) (null sub) (= (the fixnum end1) jndex))
+	t)
+     (declare (fixnum jndex))
+     (compare-elements (car main) (car sub))))
+
+(defmacro search-compare-list-vector (main sub)
+  `(do ((main ,main (cdr main))
+	(index start1 (1+ index)))
+       ((or (null main) (= index (the fixnum end1))) t)
+     (declare (fixnum index))
+     (compare-elements (car main) (aref ,sub index))))
+
+(defmacro search-compare-vector-list (main sub index)
+  `(do ((sub (nthcdr start1 ,sub) (cdr sub))
+	(jndex start1 (1+ jndex))
+	(index ,index (1+ index)))
+       ((or (= (the fixnum end1) jndex) (null sub)) t)
+     (declare (fixnum jndex index))
+     (compare-elements (aref ,main index) (car sub))))
+
+(defmacro search-compare-vector-vector (main sub index)
+  `(do ((index ,index (1+ index))
+	(sub-index start1 (1+ sub-index)))
+       ((= sub-index (the fixnum end1)) t)
+     (declare (fixnum sub-index index))
+     (compare-elements (aref ,main index) (aref ,sub sub-index))))
+
+(defmacro search-compare (main-type main sub index)
+  (if (eq main-type 'list)
+      `(seq-dispatch ,sub
+		     (search-compare-list-list ,main ,sub)
+		     (search-compare-list-vector ,main ,sub))
+      `(seq-dispatch ,sub
+		     (search-compare-vector-list ,main ,sub ,index)
+		     (search-compare-vector-vector ,main ,sub ,index))))
+
+)
+
+(eval-when (compile eval)
+ 
+(defmacro list-search (main sub)
+  `(do ((main (nthcdr start2 ,main) (cdr main))
+	(index2 start2 (1+ index2))
+	(terminus (- (the fixnum end2)
+		     (the fixnum (- (the fixnum end1)
+				    (the fixnum start1)))))
+	(last-match ()))
+       ((> index2 terminus) last-match)
+     (declare (fixnum index2 terminus))
+     (if (search-compare list main ,sub index2)
+	 (if from-end
+	     (setq last-match index2)
+	     (return index2)))))
+
+
+(defmacro vector-search (main sub)
+  `(do ((index2 start2 (1+ index2))
+	(terminus (- (the fixnum end2)
+		     (the fixnum (- (the fixnum end1)
+				    (the fixnum start1)))))
+	(last-match ()))
+       ((> index2 terminus) last-match)
+     (declare (fixnum index2 terminus))
+     (if (search-compare vector ,main ,sub index2)
+	 (if from-end
+	     (setq last-match index2)
+	     (return index2)))))
+
+)
+
+
+(defun search (sequence1 sequence2 &key from-end (test #'eql) test-not 
+		(start1 0) end1 (start2 0) end2 key)
+  "A search is conducted using EQL for the first subsequence of sequence2 
+   which element-wise matches sequence1.  If there is such a subsequence in 
+   sequence2, the index of the its leftmost element is returned; 
+   otherwise () is returned."
+  (declare (fixnum start1 start2))
+  (when (null end1) (setf end1 (length sequence1)))
+  (when (null end2) (setf end2 (length sequence2)))
+  (seq-dispatch sequence2
+    (list-search sequence2 sequence1)
+    (vector-search sequence2 sequence1)))
diff --git a/code/sharpm.lisp b/code/sharpm.lisp
new file mode 100644
index 000000000..c24253b5f
--- /dev/null
+++ b/code/sharpm.lisp
@@ -0,0 +1,456 @@
+;;; -*- Log: code.log; Package: Lisp -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; Spice Lisp Interim Sharp Macro
+;;; Written by David Dill
+;;; Runs in the standard Spice Lisp environment.
+;;; This uses the special std-lisp-readtable, which is internal to READER.LISP
+;;;
+;;; ****************************************************************
+(in-package 'lisp)
+
+
+;;; declared in READ.LISP
+
+(proclaim '(special *read-suppress* std-lisp-readtable *bq-vector-flag*))
+
+(defun sharp-backslash (stream backslash font)
+  (unread-char backslash stream)
+  (let* ((*readtable* std-lisp-readtable)
+	 (bitnames ())
+	 (charstring (read-extended-token stream)))
+    (declare (simple-string charstring))
+    (when *read-suppress* (return-from sharp-backslash nil))
+    ;;find bit name prefixes
+    (do ((i (position #\- charstring) (position #\- charstring)))
+	((or (null i) (zerop (the fixnum i))))
+      (let ((bitname (string-upcase (subseq charstring 0 i))))
+	(setq charstring (subseq charstring (1+ (the fixnum i))))
+	;;* symbols in alist are a kludge to circumvent xc bogosity.
+	(let ((expansion (cdr (assoc bitname '(("C" . CONTROL)
+					       ("M" . META)
+					       ("H" . HYPER)
+					       ("S" . SUPER))
+				     :test #'equal))))
+	  (if expansion (setq bitname (symbol-name expansion)))
+	  (cond ((member bitname '("CONTROL" "META" "HYPER" "SUPER")
+			 :test #'EQUAL)
+		 (if (not (member bitname bitnames :test #'EQUAL))
+		     (push bitname bitnames)
+		     (error
+			     "Redundant bit name in character name: ~A"
+			     bitname)))
+		(t (error
+			   "Meaningless bit name in character name: ~A"
+			   bitname))))))
+    ;;build un-hyphenated char, add specified bits:
+    (let ((char (if (= (the fixnum (length charstring)) 1)
+		    (char charstring 0)
+		    (name-char charstring))))
+      (cond (char
+	     (if font
+		 (setq char (make-char char 0 font)))
+	     (if (member "CONTROL" bitnames :test #'EQUAL)
+		 (setq char (set-char-bit char :control t)))
+	     (if (member "META" bitnames :test #'EQUAL)
+		 (setq char (set-char-bit char :meta t)))
+	     (if (member "HYPER" bitnames :test #'EQUAL)
+		 (setq char (set-char-bit char :hyper t)))
+	     (if (member "SUPER" bitnames :test #'EQUAL)
+		 (setq char (set-char-bit char :super t)))
+	     char)
+	    (t (error "Meaningless character name ~A"
+		       charstring))))))
+
+(defun sharp-quote (stream ignore1 ignore2)
+  (declare (ignore ignore1 ignore2))
+  ;; 4th arg tells read that this is a recrusive call.
+  `(function ,(read stream () () t)))
+
+(defun sharp-left-paren (stream ignore length)
+  (declare (ignore ignore))
+  (declare (special *backquote-count*))
+  (let* ((list (read-list stream nil))
+	 (listlength (length list)))
+    (declare (list list)
+	     (fixnum listlength))
+    (cond (*read-suppress*)
+	  ((zerop *backquote-count*)
+	   (if length
+	       (cond ((> listlength (the fixnum length))
+		      (error
+		       "Vector longer than specified length: #~S~S"
+		       length list))
+		     (t
+		      (fill (the simple-vector
+				 (replace (the simple-vector (make-array length))
+					  list))
+			    (car (last list))
+			    :start listlength)))
+	       (coerce list 'vector)))
+	  (t (cons *bq-vector-flag* list)))))
+
+(defun sharp-star (stream ignore numarg)
+  (declare (ignore ignore))
+  (multiple-value-bind (bstring escape-appearedp)
+		       (read-extended-token stream)
+    (declare (simple-string bstring))
+    (cond (*read-suppress*)
+	  (escape-appearedp
+	   (error "Escape character appeared after #*"))
+	  ((and numarg (zerop (length bstring)) (not (zerop numarg)))
+	   (error "You have to give a little bit for non-zero #* bit-vectors."))
+	  ((or (null numarg) (>= (the fixnum numarg) (length bstring)))
+	   (let* ((len1 (length bstring))
+		  (last1 (1- len1))
+		  (len2 (or numarg len1))
+		  (bvec (make-array len2 :element-type 'bit
+				    :initial-element 0)))
+	     (declare (fixnum len1 last1 len2))
+	     (do ((i 0 (1+ i))
+		  (char ()))
+		 ((= i len2))
+	       (declare (fixnum i))
+	       (setq char (elt bstring (if (< i len1) i last1)))
+	       (setf (elt bvec i)
+		     (cond ((char= char #\0) 0)
+			   ((char= char #\1) 1)
+			   (t
+			    (error "Illegal element given for ~
+					  bitvector #~A*~A"
+				    numarg bstring)))))
+	     bvec))
+	  (t
+	   (error "Bit vector is longer than specified length #~A*~A"
+		   numarg bstring)))))
+
+
+(defun sharp-colon (stream ignore1 ignore2)
+  (declare (ignore ignore1 ignore2))
+  (when *read-suppress*
+	(read stream () () t)
+	(return-from sharp-colon nil))
+  (let ((token (read-extended-token stream)))
+    (declare (simple-string token))
+    (cond (*read-suppress*)
+	  ((find #\: token)
+	   (error "Symbol following #: contains a #\: ~S" token))
+	  ((eql (length token) 0)
+	   (let ((ch (read-char stream nil nil t)))
+	     (if ch
+		 (error "Illegal terminating character after a colon, ~S." ch)
+		 (error "Illegal terminating character after a colon."))))
+	  (T (make-symbol token)))))
+
+(defun sharp-dot (stream ignore1 ignore2)
+  (declare (ignore ignore1 ignore2))
+  (let ((token (read stream () () t)))
+    (unless *read-suppress*  (eval token))))
+
+(defun sharp-comma (stream ignore1 ignore2)
+  (declare (ignore ignore1 ignore2))
+  (let ((token (read stream () () t)))
+    (unless *read-suppress*  (eval token))))
+
+(defun sharp-R (stream ignore radix)
+  (declare (ignore ignore))
+  (multiple-value-bind (token escape-appearedp)
+		       (read-extended-token stream)
+    (declare (simple-string token))
+    (when *read-suppress* (return-from sharp-R nil))
+    (let ((numval 0) (denval 0) (resttok 0) (toklength (length token))
+	  (sign 1))
+      (declare (fixnum toklength))
+      (if escape-appearedp
+	  (error "Escape character appears in number."))
+      ;;look for leading sign
+      (let ((firstchar (elt token 0)))
+	(cond ((char= firstchar #\-)
+	       (setq sign -1)
+	       (setq resttok 1))
+	      ((char= firstchar #\+)
+	       (setq resttok 1))))
+      ;;read numerator
+      (do ((position resttok (1+ position))
+	   (dig ()))
+	  ((or (>= position toklength)
+	       (not (setq dig (digit-char-p (elt token position) radix))))
+	   (setq resttok position))
+	(setq numval (+ (* numval radix) dig)))
+      ;;see if we're at the end.
+      (cond ((>= resttok toklength)
+	     ;;just return numerator -- that's all there is.
+	     (* numval sign))
+	    ((char= (elt token resttok) #\/)
+	     ;;it's a ratio.
+	     (do ((position (1+ resttok) (1+ position))
+		  (dig ())
+		  (retval ()))
+		 ((cond ((>= position toklength)
+			 (setq retval (/ (* numval sign) denval)))
+			((not (setq dig (digit-char-p (elt token position)
+						     radix)))
+			 ;;there's bogus stuff at the end
+			 (error
+				 "Illegal digits ~S for radix ~S" token radix)
+			 (setq retval (/ (* numval sign) denval)))
+			;;continue looping
+			(t nil))
+		  retval)
+	       (setq denval (+ (* denval radix) dig))))
+	    ;;it's bogus
+	    (t (error
+		       "Illegal digits ~S for radix ~S" token radix)))))))
+
+(defun sharp-B (stream ignore1 ignore2)
+  (declare (ignore ignore1 ignore2))
+  (sharp-r stream nil 2))
+
+(defun sharp-O (stream ignore1 ignore2)
+  (declare (ignore ignore1 ignore2))
+  (sharp-r stream nil 8))
+
+(defun sharp-X (stream ignore1 ignore2)
+  (declare (ignore ignore1 ignore2))
+  (sharp-r stream nil 16))
+
+(defun sharp-A (stream ignore dimensions)
+  (declare (ignore ignore))
+  (when *read-suppress*
+    (read stream () () t)
+    (return-from sharp-A nil))
+  (unless dimensions (error "No dimensions argument to #A."))
+  (unless (and (integerp dimensions) (>= dimensions 0))
+    (error "Dimensions argument to #A not a non-negative integer: ~S"
+	   dimensions))
+  (if (> dimensions 0)
+      (let ((dlist (make-list dimensions))
+	    (init-list
+	     (if (char= (read-char stream t) #\( #|)|#)
+		 (read-list stream nil)
+		 (error "Array values must be a list."))))
+	(do ((dl dlist (cdr dl))
+	     (il init-list (car il)))
+	    ;; I think the nreverse is causing the problem.
+	    ((null dl))
+	    (if (listp il)
+		(rplaca dl (length il))
+		(error
+		 "Initial contents for #A is inconsistent with ~
+		 dimensions: #~SA~S" dimensions init-list)))
+	(make-array dlist :initial-contents init-list))
+      (make-array nil :initial-element (read stream t nil t))))
+
+
+(defun sharp-S (stream ignore1 ignore2)
+  (declare (ignore ignore1 ignore2))
+  ;;this needs to know about defstruct implementation
+  (when *read-suppress*
+	(read stream () () t)
+	(return-from sharp-S nil))
+  (let ((body
+	 (if (char= (read-char stream t) #\( )
+	     (read-list stream nil)
+	     (error "Non-list following #S"))))
+    (cond ((listp body)
+	   (unless (symbolp (car body))
+	     (error "Structure type is not a symbol: ~S" (car body)))
+	   (let ((defstruct (info type structure-info (car body))))
+	     (unless defstruct
+	       (error "~S is not a defined structure type." (car body)))
+	     (unless (c::dd-constructor defstruct)
+	       (error "The ~S structure does not have a default constructor." (car body)))
+	     (do ((arg (cdr body) (cddr arg))
+		  (res ()))
+		 ((endp arg) (apply (c::dd-constructor defstruct) res))
+	       (push (cadr arg) res)
+	       (push (intern (string (car arg)) *keyword-package*) res))))
+	  (t (error "Non-list following #S: ~S" body))))))
+
+(defmacro int-subst-array (new old array rank var-list)
+  (if (> rank (array-rank array))
+      (let ((new-list (nreverse var-list)))
+       `(if (eq ,old (aref ,array ,@new-list))
+	    (setf (aref ,array ,@new-list) ,new)))
+       (let ((newvar (gensym)))
+	   `(dotimes (,newvar (array-dimension ,array ,rank))
+	      (int-subst-array ,new ,old ,array (1+ ,rank)
+			       (push ,newvar ,var-list))))))
+
+(defmacro subst-array (new old array)
+  `(int-subst-array ,new ,old ,array 0 nil))
+
+(defvar sharp-cons-table ()
+  "Holds the cons cells seen already by circle-subst")
+
+;; This function is the same as nsubst, except that it checks for circular
+;; lists. the first arg is an alist of the things to be replaced assoc'd with
+;; the things to replace them.
+(defun circle-subst (old-new-alist tree)
+  (cond ((and (atom tree)
+	      (not (and (arrayp tree)
+			(eq (array-element-type tree) t))))
+	 (let ((pair (assq tree old-new-alist)))
+	   (if pair (cdr pair) tree)))
+	((null (gethash tree sharp-cons-table))
+	 (setf (gethash tree sharp-cons-table) t)
+	 (cond ((simple-vector-p tree)
+		(do ((i 0 (1+ i))
+		     (len (length tree)))
+		    ((>= i len))
+		  (declare (fixnum i len))
+		  (setf (svref tree i)
+			(circle-subst old-new-alist (svref tree i))))
+		tree)
+	       ((arrayp tree)
+		(with-array-data ((data tree) (start) (end))
+		  (declare (fixnum start end))
+		  (do ((i start (1+ i)))
+		      ((>= i end))
+		    (setf (aref data i)
+			  (circle-subst old-new-alist (aref data i)))))
+		tree)
+	       (T (let ((a (circle-subst old-new-alist (car tree)))
+			(d (circle-subst old-new-alist (cdr tree))))
+		    (if (eq a (car tree))
+			tree
+			(rplaca tree a))
+		    (if (eq d (cdr tree))
+			tree
+			(rplacd tree d)))
+		  tree)))
+	(t tree)))
+
+;; Sharp-equal works as follows.  When a label is assigned
+;; (ie when #= is called) a symbol (ref) is gensym'd and
+;; a cons cell whose car is the label, and cdr is the symbol
+;; is put on the sharp-sharp alist.  When sharp-sharp encounters
+;; a reference to a label it returns the symbol assoc'd with the label.
+;; When an object has been read then a cons cell whose car is the symbol
+;; and cdr is the object is pushed onto the sharp-sharp-alist.  Then
+;; for each cons cell on the sharp-sharp-alist, the current object is searched
+;; and where a symbol eq to the car of the current cons cell is found,
+;; the object is substituted in.
+(defun sharp-equal (stream ignore label &aux (ref (gensym)))
+  (declare (ignore ignore))
+  (declare (special sharp-equal-alist sharp-sharp-alist))
+  (when *read-suppress* (return-from sharp-equal (values)))
+  (unless (integerp label)
+	  (error "non-integer label #~S=" label))
+  (push (cons label ref) sharp-sharp-alist)
+  (let ((obj (read stream () () t)))
+    (push (cons ref obj) sharp-equal-alist)
+    (clrhash sharp-cons-table)
+    (circle-subst sharp-equal-alist obj)))
+
+(defun sharp-sharp (ignore1 ignore2 label)
+  (declare (ignore ignore1 ignore2))
+  (declare (special sharp-equal-alist sharp-sharp-alist))
+  (when *read-suppress* (return-from sharp-sharp nil))
+  (if (integerp label)
+      (let ((pair (assoc label sharp-sharp-alist)))
+	(if pair
+	    (let ((ret-obj (cdr (assoc (cdr pair) sharp-equal-alist))))
+	      (if ret-obj ret-obj
+		  (cdr pair)))
+	    (error "Object is not labelled #~S#" label)))
+      (error "Non-integer label #~S#" label)))
+
+(defun sharp-plus (stream ignore1 ignore2)
+  (declare (ignore ignore1 ignore2))
+  (cond (*read-suppress*
+	 (read stream () () t)
+	 (values))
+	((featurep (let ((*package* *keyword-package*))
+		     (read stream () () t)))
+	 (read stream () () t))
+	(t (let ((*read-suppress* t))
+	     (read stream () () t)
+	     (values)))))
+
+(defun sharp-minus (stream ignore1 ignore2)
+  (declare (ignore ignore1 ignore2))
+  (cond (*read-suppress*
+	 (read stream () () t)
+	 (values))
+	((not (featurep (let ((*package* *keyword-package*))
+			  (read stream () () t))))
+	 (read stream () () t))
+	(t (let ((*read-suppress* t))      
+	     (read stream () () t)
+	     (values)))))
+
+(defun sharp-C (stream ignore1 ignore2)
+  (declare (ignore ignore1 ignore2))
+  ;;next thing better be a list of two numbers.
+  (let ((cnum (read stream () () t)))
+    (when *read-suppress* (return-from sharp-c nil))
+    (if (= (length cnum) 2)
+	(complex (car cnum) (cadr cnum))
+	(error "Illegal complex number format" cnum))))
+
+(defun sharp-vertical-bar (stream ignore1 ignore2)
+  (declare (ignore ignore1 ignore2))
+  (prepare-for-fast-read-char stream
+    (do ((level 1)
+	 (prev (fast-read-char) char)
+	 (char (fast-read-char) (fast-read-char)))
+	(())
+      (cond ((and (char= prev #\|) (char= char #\#))
+	     (setq level (1- level))
+	     (when (zerop level)
+	       (done-with-fast-read-char)
+	       (return (values)))
+	     (setq char (fast-read-char)))
+	    ((and (char= prev #\#) (char= char #\|))
+	     (setq char (fast-read-char))
+	     (setq level (1+ level)))))))
+
+(defun sharp-illegal (ignore1 sub-char ignore2)
+  (declare (ignore ignore1 ignore2))
+  (error "Illegal sharp character ~S" sub-char))
+
+
+(defun sharp-init ()
+  (declare (special std-lisp-readtable))
+  (setq sharp-cons-table (make-hash-table :size 50))
+  (let ((*readtable* std-lisp-readtable))
+    (make-dispatch-macro-character #\#)
+    (set-dispatch-macro-character #\# #\\ #'sharp-backslash)
+    (set-dispatch-macro-character #\# #\' #'sharp-quote)
+    (set-dispatch-macro-character #\# #\( #'sharp-left-paren)
+    (set-dispatch-macro-character #\# #\* #'sharp-star)
+    (set-dispatch-macro-character #\# #\: #'sharp-colon)
+    (set-dispatch-macro-character #\# #\. #'sharp-dot)
+    (set-dispatch-macro-character #\# #\, #'sharp-comma)
+    (set-dispatch-macro-character #\# #\R #'sharp-R)
+    (set-dispatch-macro-character #\# #\r #'sharp-R)
+    (set-dispatch-macro-character #\# #\B #'sharp-B)
+    (set-dispatch-macro-character #\# #\b #'sharp-B)
+    (set-dispatch-macro-character #\# #\O #'sharp-O)
+    (set-dispatch-macro-character #\# #\o #'sharp-O)
+    (set-dispatch-macro-character #\# #\X #'sharp-X)
+    (set-dispatch-macro-character #\# #\x #'sharp-X)
+    (set-dispatch-macro-character #\# #\A #'sharp-A)
+    (set-dispatch-macro-character #\# #\a #'sharp-A)
+    (set-dispatch-macro-character #\# #\S #'sharp-S)
+    (set-dispatch-macro-character #\# #\s #'sharp-S)
+    (set-dispatch-macro-character #\# #\= #'sharp-equal)
+    (set-dispatch-macro-character #\# #\# #'sharp-sharp)
+    (set-dispatch-macro-character #\# #\+ #'sharp-plus)
+    (set-dispatch-macro-character #\# #\- #'sharp-minus)
+    (set-dispatch-macro-character #\# #\C #'sharp-C)
+    (set-dispatch-macro-character #\# #\c #'sharp-C)
+    (set-dispatch-macro-character #\# #\| #'sharp-vertical-bar)
+    (set-dispatch-macro-character #\# #\tab #'sharp-illegal)
+    (set-dispatch-macro-character #\# #\  #'sharp-illegal)
+    (set-dispatch-macro-character #\# #\) #'sharp-illegal)
+    (set-dispatch-macro-character #\# #\< #'sharp-illegal)
+    (set-dispatch-macro-character #\# #\form #'sharp-illegal)
+    (set-dispatch-macro-character #\# #\return #'sharp-illegal)))
diff --git a/code/sort.lisp b/code/sort.lisp
new file mode 100644
index 000000000..c1183a566
--- /dev/null
+++ b/code/sort.lisp
@@ -0,0 +1,442 @@
+;;; -*- Log: code.log; Package: Lisp -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at 
+;;; Carnegie-Mellon University, and has been placed in the public domain.  
+;;; If you want to use this code or any part of Spice Lisp, please contact 
+;;; Scott Fahlman (FAHLMAN@CMUC).  
+;;; ********************************************************************** 
+;;;
+;;; Sort functions for Spice Lisp 
+;;;   these functions are part of the standard spice lisp environment.  
+;;; 
+;;; Written by Jim Large 
+;;; Hacked on and maintained by Skef Wholey 
+;;; Rewritten by Bill Chiles
+;;;
+;;; *******************************************************************
+
+(in-package 'lisp)
+
+(export '(sort stable-sort merge))
+
+
+
+(defun sort (sequence predicate &key key)
+  "Destructively sorts sequence.  Predicate should returns non-Nil if
+   Arg1 is to precede Arg2."
+  (typecase sequence
+    (simple-vector
+     (if (> (the fixnum (length (the simple-vector sequence))) 0)
+	 (sort-simple-vector sequence predicate key)
+	 sequence))
+    (list
+     (sort-list sequence predicate key))
+    (vector
+     (if (> (the fixnum (length sequence)) 0)
+	 (sort-vector sequence predicate key)
+	 sequence))
+    (t
+     (error "~S is not a sequence." sequence))))
+
+
+
+;;; Sorting Vectors
+
+;;; Sorting is done with a heap sort.
+
+(eval-when (compile eval)
+
+;;; HEAPIFY, assuming both sons of root are heaps, percolates the root element
+;;; through the sons to form a heap at root.  Root and max are zero based
+;;; coordinates, but the heap algorithm only works on arrays indexed from 1
+;;; through N (not 0 through N-1); This is because a root at I has sons at 2*I
+;;; and 2*I+1 which does not work for a root at 0.  Because of this, boundaries,
+;;; roots, and termination are computed using 1..N indexes.
+
+(defmacro heapify (seq vector-ref root max pred key)
+  (let ((heap-root (gensym))   (heap-max (gensym))     (root-ele (gensym))
+	(root-key (gensym))    (heap-max/2 (gensym))   (heap-l-son (gensym))
+	(one-son (gensym))     (one-son-ele (gensym))  (one-son-key (gensym))
+	(r-son-ele (gensym))   (r-son-key (gensym))    (var-root (gensym)))
+    `(let* ((,var-root ,root) ; necessary to not clobber calling root var.
+	    (,heap-root (1+ ,root))
+	    (,heap-max (1+ ,max))
+	    (,root-ele (,vector-ref ,seq ,root))
+	    (,root-key (apply-key ,key ,root-ele))
+	    (,heap-max/2 (ash ,heap-max -1))) ; (floor heap-max 2)
+       (declare (fixnum ,var-root ,heap-root ,heap-max ,heap-max/2))
+       (loop
+	(if (> ,heap-root ,heap-max/2) (return))
+	(let* ((,heap-l-son (ash ,heap-root 1)) ; (* 2 heap-root)
+	       ;; l-son index in seq (0..N-1) is one less than heap computation
+	       (,one-son (1- ,heap-l-son))
+	       (,one-son-ele (,vector-ref ,seq ,one-son))
+	       (,one-son-key (apply-key ,key ,one-son-ele)))
+	  (declare (fixnum ,heap-l-son ,one-son))
+	  (if (< ,heap-l-son ,heap-max)
+	      ;; there is a right son.
+	      (let* ((,r-son-ele (,vector-ref ,seq ,heap-l-son))
+		     (,r-son-key (apply-key ,key ,r-son-ele)))
+		;; choose the greater of the two sons.
+		(when (funcall ,pred ,one-son-key ,r-son-key)
+		  (setf ,one-son ,heap-l-son)
+		  (setf ,one-son-ele ,r-son-ele)
+		  (setf ,one-son-key ,r-son-key))))
+	  ;; if greater son is less than root, then we've formed a heap again.
+	  (if (funcall ,pred ,one-son-key ,root-key) (return))
+	  ;; else put greater son at root and make greater son node be the root.
+	  (setf (,vector-ref ,seq ,var-root) ,one-son-ele)
+	  (setf ,heap-root (1+ ,one-son)) ; one plus to be in heap coordinates.
+	  (setf ,var-root ,one-son)))     ; actual index into vector for root ele.
+       ;; now really put percolated value into heap at the appropriate root node.
+       (setf (,vector-ref ,seq ,var-root) ,root-ele))))
+
+
+;;; BUILD-HEAP rearranges seq elements into a heap to start heap sorting.
+(defmacro build-heap (seq type len-1 pred key)
+  (let ((i (gensym)))
+    `(do ((,i (floor ,len-1 2) (1- ,i)))
+	 ((minusp ,i) ,seq)
+       (declare (fixnum ,i))
+       (heapify ,seq ,type ,i ,len-1 ,pred ,key))))
+
+) ; eval-when
+
+
+;;; Make simple-vector and miscellaneous vector sorting functions.
+(macrolet ((frob-rob (fun-name vector-ref)
+	     `(defun ,fun-name (seq pred key)
+		(let ((len-1 (1- (length (the vector seq)))))
+		  (declare (fixnum len-1))
+		  (build-heap seq ,vector-ref len-1 pred key)
+		  (do* ((i len-1 i-1)
+			(i-1 (1- i) (1- i-1)))
+		       ((zerop i) seq)
+		    (declare (fixnum i i-1))
+		    (rotatef (,vector-ref seq 0) (,vector-ref seq i))
+		    (heapify seq ,vector-ref 0 i-1 pred key))))))
+
+  (frob-rob sort-vector aref)
+
+  (frob-rob sort-simple-vector svref))
+
+
+
+;;;; Stable Sorting
+
+(defun stable-sort (sequence predicate &key key)
+  "Destructively sorts sequence.  Predicate should returns non-Nil if
+   Arg1 is to precede Arg2."
+  (typecase sequence
+    (simple-vector
+     (stable-sort-simple-vector sequence predicate key))
+    (list
+     (sort-list sequence predicate key))
+    (vector
+     (stable-sort-vector sequence predicate key))
+    (t
+     (error "~S is not a sequence." sequence))))
+
+
+;;; Stable Sorting Lists
+
+
+;;; SORT-LIST uses a bottom up merge sort.  First a pass is made over
+;;; the list grabbing one element at a time and merging it with the next one
+;;; form pairs of sorted elements.  Then n is doubled, and elements are taken
+;;; in runs of two, merging one run with the next to form quadruples of sorted
+;;; elements.  This continues until n is large enough that the inner loop only
+;;; runs for one iteration; that is, there are only two runs that can be merged,
+;;; the first run starting at the beginning of the list, and the second being
+;;; the remaining elements.
+
+(defun sort-list (list pred key)
+  (let ((head (cons :header list))  ; head holds on to everything
+	(n 1)                       ; bottom-up size of lists to be merged
+	unsorted		    ; unsorted is the remaining list to be
+				    ;   broken into n size lists and merged
+	list-1			    ; list-1 is one length n list to be merged
+	last)			    ; last points to the last visited cell
+    (declare (fixnum n))
+    (loop
+     ;; start collecting runs of n at the first element
+     (setf unsorted (cdr head))
+     ;; tack on the first merge of two n-runs to the head holder
+     (setf last head)
+     (let ((n-1 (1- n)))
+       (declare (fixnum n-1))
+       (loop
+	(setf list-1 unsorted)
+	(let ((temp (nthcdr n-1 list-1))
+	      list-2)
+	  (cond (temp
+		 ;; there are enough elements for a second run
+		 (setf list-2 (cdr temp))
+		 (setf (cdr temp) nil)
+		 (setf temp (nthcdr n-1 list-2))
+		 (cond (temp
+			(setf unsorted (cdr temp))
+			(setf (cdr temp) nil))
+		       ;; the second run goes off the end of the list
+		       (t (setf unsorted nil)))
+		 (multiple-value-bind (merged-head merged-last)
+				      (merge-lists* list-1 list-2 pred key)
+		   (setf (cdr last) merged-head)
+		   (setf last merged-last))
+		 (if (null unsorted) (return)))
+		;; if there is only one run, then tack it on to the end
+		(t (setf (cdr last) list-1)
+		   (return)))))
+       (setf n (ash n 1)) ; (+ n n)
+       ;; If the inner loop only executed once, then there were only enough
+       ;; elements for two runs given n, so all the elements have been merged
+       ;; into one list.  This may waste one outer iteration to realize.
+       (if (eq list-1 (cdr head))
+	   (return list-1))))))
+
+
+;;; APPLY-PRED saves us a function call sometimes.
+(eval-when (compile eval)
+  (defmacro apply-pred (one two pred key)
+    `(if ,key
+	 (funcall ,pred (funcall ,key ,one)
+		  (funcall ,key  ,two))
+	 (funcall ,pred ,one ,two)))
+) ; eval-when
+
+(defvar *merge-lists-header* (list :header))
+
+;;; MERGE-LISTS*   originally written by Jim Large.
+;;; 		   modified to return a pointer to the end of the result
+;;; 		      and to not cons header each time its called.
+;;; It destructively merges list-1 with list-2.  In the resulting
+;;; list, elements of list-2 are guaranteed to come after equal elements
+;;; of list-1.
+(defun merge-lists* (list-1 list-2 pred key)
+  (do* ((result *merge-lists-header*)
+	(P result))                            ; P points to last cell of result
+       ((or (null list-1) (null list-2))       ; done when either list used up	
+	(if (null list-1)                      ; in which case, append the
+	    (rplacd p list-2)                  ;   other list
+	    (rplacd p list-1))
+	(do ((drag p lead)
+	     (lead (cdr p) (cdr lead)))
+	    ((null lead)
+	     (values (prog1 (cdr result)       ; return the result sans header
+			    (rplacd result nil)) ; (free memory, be careful)
+		     drag))))		       ; and return pointer to last element
+    (cond ((apply-pred (car list-2) (car list-1) pred key)
+	   (rplacd p list-2)           ; append the lesser list to last cell of
+	   (setq p (cdr p))            ;   result.  Note: test must bo done for
+	   (pop list-2))               ;   list-2 < list-1 so merge will be
+	  (T (rplacd p list-1)         ;   stable for list-1
+	     (setq p (cdr p))
+	     (pop list-1)))))
+
+
+
+;;; Stable Sort Vectors
+
+;;; Stable sorting vectors is done with the same algorithm used for lists,
+;;; using a temporary vector to merge back and forth between it and the
+;;; given vector to sort.
+
+
+(eval-when (compile eval)
+
+;;; STABLE-SORT-MERGE-VECTORS* takes a source vector with subsequences,
+;;;    start-1 (inclusive) ... end-1 (exclusive) and
+;;;    end-1 (inclusive) ... end-2 (exclusive),
+;;; and merges them into a target vector starting at index start-1.
+
+(defmacro stable-sort-merge-vectors* (source target start-1 end-1 end-2
+					     pred key source-ref target-ref)
+  (let ((i (gensym))
+	(j (gensym))
+	(target-i (gensym)))
+    `(let ((,i ,start-1)
+	   (,j ,end-1) ; start-2
+	   (,target-i ,start-1))
+       (declare (fixnum ,i ,j ,target-i))
+       (loop
+	(cond ((= ,i ,end-1)
+	       (loop (if (= ,j ,end-2) (return))
+		     (setf (,target-ref ,target ,target-i)
+			   (,source-ref ,source ,j))
+		     (incf ,target-i)
+		     (incf ,j))
+	       (return))
+	      ((= ,j ,end-2)
+	       (loop (if (= ,i ,end-1) (return))
+		     (setf (,target-ref ,target ,target-i)
+			   (,source-ref ,source ,i))
+		     (incf ,target-i)
+		     (incf ,i))
+	       (return))
+	      ((apply-pred (,source-ref ,source ,j)
+			   (,source-ref ,source ,i)
+			   ,pred ,key)
+	       (setf (,target-ref ,target ,target-i)
+		     (,source-ref ,source ,j))
+	       (incf ,j))
+	      (t (setf (,target-ref ,target ,target-i)
+		       (,source-ref ,source ,i))
+		 (incf ,i)))
+	(incf ,target-i)))))
+
+
+;;; VECTOR-MERGE-SORT is the same algorithm used to stable sort lists, but
+;;; it uses a temporary vector.  Direction determines whether we are merging
+;;; into the temporary (T) or back into the given vector (NIL).
+
+(defmacro vector-merge-sort (vector pred key vector-ref)
+  (let ((vector-len (gensym)) 		(n (gensym))
+	(direction (gensym)) 		(unsorted (gensym))
+	(start-1 (gensym)) 		(end-1 (gensym))
+	(end-2 (gensym)) 		(temp-len (gensym))
+	(i (gensym)))
+    `(let ((,vector-len (length (the vector ,vector)))
+	   (,n 1)         ; bottom-up size of contiguous runs to be merged
+	   (,direction t) ; t vector --> temp    nil temp --> vector
+	   (,temp-len (length (the simple-vector *merge-sort-temp-vector*)))
+	   (,unsorted 0)  ; unsorted..vector-len are the elements that need
+			  ; to be merged for a given n
+	   (,start-1 0))  ; one n-len subsequence to be merged with the next
+       (declare (fixnum ,vector-len ,n ,temp-len ,unsorted ,start-1))
+       (if (> ,vector-len ,temp-len)
+	   (setf *merge-sort-temp-vector*
+		 (make-array (max ,vector-len (+ ,temp-len ,temp-len)))))
+       (loop
+	;; for each n, we start taking n-runs from the start of the vector
+	(setf ,unsorted 0)
+	(loop
+	 (setf ,start-1 ,unsorted)
+	 (let ((,end-1 (+ ,start-1 ,n)))
+	   (declare (fixnum ,end-1))
+	   (cond ((< ,end-1 ,vector-len)
+		  ;; there are enough elements for a second run
+		  (let ((,end-2 (+ ,end-1 ,n)))
+		    (declare (fixnum ,end-2))
+		    (if (> ,end-2 ,vector-len) (setf ,end-2 ,vector-len))
+		    (setf ,unsorted ,end-2)
+		    (if ,direction
+			(stable-sort-merge-vectors*
+			 ,vector *merge-sort-temp-vector*
+			 ,start-1 ,end-1 ,end-2 ,pred ,key ,vector-ref svref)
+			(stable-sort-merge-vectors*
+			 *merge-sort-temp-vector* ,vector
+			 ,start-1 ,end-1 ,end-2 ,pred ,key svref ,vector-ref))
+		    (if (= ,unsorted ,vector-len) (return))))
+		 ;; if there is only one run, copy those elements to the end
+		 (t (if ,direction
+			(do ((,i ,start-1 (1+ ,i)))
+			    ((= ,i ,vector-len))
+			  (declare (fixnum ,i))
+			  (setf (svref *merge-sort-temp-vector* ,i)
+				(,vector-ref ,vector ,i)))
+			(do ((,i ,start-1 (1+ ,i)))
+			    ((= ,i ,vector-len))
+			  (declare (fixnum ,i))
+			  (setf (,vector-ref ,vector ,i)
+				(svref *merge-sort-temp-vector* ,i))))
+		    (return)))))
+	;; If the inner loop only executed once, then there were only enough
+	;; elements for two subsequences given n, so all the elements have
+	;; been merged into one list.  Start-1 will have remained 0 upon exit.
+	(when (zerop ,start-1)
+	  (if ,direction
+	      ;; if we just merged into the temporary, copy it all back
+	      ;; to the given vector.
+	      (dotimes (,i ,vector-len)
+		(setf (,vector-ref ,vector ,i)
+		      (svref *merge-sort-temp-vector* ,i))))
+	  (return ,vector))
+	(setf ,n (ash ,n 1)) ; (* 2 n)
+	(setf ,direction (not ,direction))))))
+
+) ; eval-when
+
+
+;;; Temporary vector for stable sorting vectors.
+(defvar *merge-sort-temp-vector*
+  (make-array 50))
+
+(proclaim '(simple-vector *merge-sort-temp-vector*))
+
+(defun stable-sort-simple-vector (vector pred key)
+  (declare (simple-vector vector))
+  (vector-merge-sort vector pred key svref))
+
+(defun stable-sort-vector (vector pred key)
+  (vector-merge-sort vector pred key aref))
+
+
+
+;;;; Merge
+
+(eval-when (compile eval)
+
+;;; MERGE-VECTORS returns a new vector which contains an interleaving
+;;; of the elements of vector-1 and vector-2.  Elements from vector-2 are
+;;; chosen only if they are strictly less than elements of vector-1,
+;;; (pred elt-2 elt-1), as specified in the manual.
+
+(defmacro merge-vectors (vector-1 length-1 vector-2 length-2
+			 result-vector pred key access)
+  (let ((result-i (gensym))
+	(i (gensym))
+	(j (gensym)))
+    `(let* ((,result-i 0)
+	    (,i 0)
+	    (,j 0))
+       (declare (fixnum ,result-i ,i ,j))
+       (loop
+	(cond ((= ,i ,length-1)
+	       (loop (if (= ,j ,length-2) (return))
+		     (setf (,access ,result-vector ,result-i)
+			   (,access ,vector-2 ,j))
+		     (incf ,result-i)
+		     (incf ,j))
+	       (return ,result-vector))
+	      ((= ,j ,length-2)
+	       (loop (if (= ,i ,length-1) (return))
+		     (setf (,access ,result-vector ,result-i)
+			   (,access ,vector-1 ,i))
+		     (incf ,result-i)
+		     (incf ,i))
+	       (return ,result-vector))
+	      ((apply-pred (,access ,vector-2 ,j) (,access ,vector-1 ,i)
+			   ,pred ,key)
+	       (setf (,access ,result-vector ,result-i)
+		     (,access ,vector-2 ,j))
+	       (incf ,j))
+	      (t (setf (,access ,result-vector ,result-i)
+		       (,access ,vector-1 ,i))
+		 (incf ,i)))
+	(incf ,result-i)))))
+
+) ; eval-when
+
+(defun merge (result-type sequence1 sequence2 predicate &key key)
+  "The sequences Sequence1 and Sequence2 are destructively merged into
+   a sequence of type Result-Type using the Predicate to order the elements."
+  (if (eq result-type 'list)
+      (let ((result (merge-lists* (coerce sequence1 'list)
+				  (coerce sequence2 'list)
+				  predicate key)))
+	result)
+      (let* ((vector-1 (coerce sequence1 'vector))
+	     (vector-2 (coerce sequence2 'vector))
+	     (length-1 (length vector-1))
+	     (length-2 (length vector-2))
+	     (result (make-sequence-of-type result-type (+ length-1 length-2))))
+	(declare (vector vector-1 vector-2)
+		 (fixnum length-1 length-2))
+	(if (and (simple-vector-p result)
+		 (simple-vector-p vector-1)
+		 (simple-vector-p vector-2))
+	    (merge-vectors vector-1 length-1 vector-2 length-2
+			   result predicate key svref)
+	    (merge-vectors vector-1 length-1 vector-2 length-2
+			   result predicate key aref)))))
diff --git a/code/stream.lisp b/code/stream.lisp
new file mode 100644
index 000000000..c340d64d3
--- /dev/null
+++ b/code/stream.lisp
@@ -0,0 +1,1043 @@
+;;; -*- Log: code.log; Package: Lisp -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; Stream functions for Spice Lisp.
+;;; Written by Skef Wholey and Rob MacLachlan.
+;;;
+;;; This file contains the machine-independent stream functions.  Another
+;;; file (VAXIO, SPIO, or VMIO) contains functions used by this file for
+;;; a specific machine.
+;;;
+(in-package 'lisp)
+
+(export '(make-broadcast-stream make-synonym-stream
+	  make-broadcast-stream make-concatenated-stream make-two-way-stream
+	  make-echo-stream make-string-input-stream make-string-output-stream
+	  get-output-stream-string stream-element-type input-stream-p
+	  output-stream-p close read-line read-char
+	  unread-char peek-char listen read-char-no-hang clear-input read-byte
+	  write-char write-string write-line terpri fresh-line
+	  finish-output force-output clear-output write-byte
+          stream streamp *standard-input* *standard-output*
+          *error-output* *query-io* *debug-io* *terminal-io* *trace-output*))
+
+(in-package 'system)
+(export '(make-indenting-stream read-n-bytes))
+(in-package 'lisp)
+
+;;;; Standard streams:
+;;;
+;;; The initialization of these streams is performed by Stream-Init,
+;;; which lives in the file of machine-specific stream functions.
+;;;
+(defvar *terminal-io* () "Terminal I/O stream.")
+(defvar *standard-input* () "Default input stream.")
+(defvar *standard-output* () "Default output stream.")
+(defvar *error-output* () "Error output stream.")
+(defvar *query-io* () "Query I/O stream.")
+(defvar *trace-output* () "Trace output stream.")
+(defvar *debug-io* () "Interactive debugging stream.")
+
+(defun ill-in (stream &rest ignore)
+  (declare (ignore ignore))
+  (error "~S is not a character input stream." stream))
+(defun ill-out (stream &rest ignore)
+  (declare (ignore ignore))
+  (error "~S is not a character output stream." stream))
+(defun ill-bin (stream &rest ignore)
+  (declare (ignore ignore))
+  (error "~S is not a binary input stream." stream))
+(defun ill-bout (stream &rest ignore)
+  (declare (ignore ignore))
+  (error "~S is not a binary output stream." stream))
+(defun closed-flame (stream &rest ignore)
+  (declare (ignore ignore))
+  (error "~S is closed." stream))
+(defun do-nothing (&rest ignore)
+  (declare (ignore ignore)))
+
+(defun %print-stream (structure stream d)
+  (declare (ignore d structure))
+  (write-string "#<Bare Stream>" stream))
+
+;;; HOW THE STREAM STRUCTURE IS USED:
+;;;
+;;;    Many of the slots of the stream structure contain functions
+;;; which are called to perform some operation on the stream.  Closed
+;;; streams have #'Closed-Flame in all of their function slots.  If
+;;; one side of an I/O or echo stream is closed, the whole stream is
+;;; considered closed.  The functions in the operation slots take
+;;; arguments as follows:
+;;;
+;;; In:			Stream, Eof-Errorp, Eof-Value
+;;; Bin:		Stream, Eof-Errorp, Eof-Value
+;;; N-Bin:		Stream, Buffer, Start, Numbytes, Eof-Errorp
+;;; Out:		Stream, Character
+;;; Bout:		Stream, Integer
+;;; Sout:		Stream, String, Start, End
+;;; Misc:		Stream, Operation, &Optional Arg1, Arg2
+;;;
+;;;    In order to save space, some of the less common stream operations
+;;; are handled by just one function, the Misc method.  This function
+;;; is passed a keyword which indicates the operation to perform.
+;;; The following keywords are used:
+;;;  :read-line		- Do a read-line.
+;;;  :listen 		- Return true if any input waiting.
+;;;  :unread		- Unread the character Arg.
+;;;  :close		- Do any stream specific stuff to close the stream.
+;;;			  The methods are set to closed-flame by the close
+;;;			  function, so that need not be done by this
+;;;			  function.
+;;;  :clear-input 	- Clear any unread input
+;;;  :finish-output,
+;;;  :force-output	- Cause output to happen
+;;;  :clear-output	- Clear any undone output
+;;;  :element-type 	- Return the type of element the stream deals with.
+;;;  :line-length	- Return the length of a line of output.
+;;;  :charpos		- Return current output position on the line.
+;;;  :file-length	- Return the file length of a file stream.
+;;;  :file-position	- Return or change the current position of a file stream.
+;;;  :file-name		- Return the name of an associated file.
+;;;
+;;;    In order to do almost anything useful, it is necessary to
+;;; define a new type of structure that includes stream, so that the
+;;; stream can have some state information.
+;;;
+;;; THE STREAM IN-BUFFER:
+;;;
+;;;    The In-Buffer in the stream holds characters or bytes that
+;;; are ready to be read by some input function.  If there is any
+;;; stuff in the In-Buffer, then the reading function can use it
+;;; without calling any stream method.  Any stream may put stuff in
+;;; the In-Buffer, and may also assume that any input in the In-Buffer
+;;; has been consumed before any in-method is called.  If a text
+;;; stream has in In-Buffer, then the first character should not be
+;;; used to buffer normal input so that it is free for unreading into.
+;;;
+;;;    The In-Buffer slot is a vector In-Buffer-Length long.  The
+;;; In-Index is the index in the In-Buffer of the first available
+;;; object.  The available objects are thus between In-Index and the
+;;; length of the In-Buffer.
+;;;
+;;;    When this buffer is only accessed by the normal stream
+;;; functions, the number of function calls is halved, thus
+;;; potentially doubling the speed of simple operations.  If the
+;;; Fast-Read-Char and Fast-Read-Byte macros are used, nearly all
+;;; function call overhead is removed, vastly speeding up these
+;;; important operations.
+;;;
+;;;    If a stream does not have an In-Buffer, then the In-Buffer slot
+;;; must be nil, and the In-Index must be In-Buffer-Length.  These are
+;;; the default values for the slots. 
+
+;;; Stream manipulation functions.
+
+(defun input-stream-p (stream)
+  "Returns non-nil if the given Stream can perform input operations."
+  (and (streamp stream)
+       (not (eq (stream-in stream) #'closed-flame))
+       (or (not (eq (stream-in stream) #'ill-in))
+	   (not (eq (stream-bin stream) #'ill-bin)))))
+
+(defun output-stream-p (stream)
+  "Returns non-nil if the given Stream can perform output operations."
+  (and (streamp stream)
+       (not (eq (stream-in stream) #'closed-flame))
+       (or (not (eq (stream-out stream) #'ill-out))
+	   (not (eq (stream-bout stream) #'ill-bout)))))
+
+(defun stream-element-type (stream)
+  "Returns a type specifier for the kind of object returned by the Stream."
+  (if (streamp stream)
+      (funcall (stream-misc stream) stream :element-type)
+      (error "~S is not a stream." stream)))
+
+(defun close (stream &key abort)
+  "Closes the given Stream.  No more I/O may be performed, but inquiries
+  may still be made.  If :Abort is non-nil, an attempt is made to clean
+  up the side effects of having created the stream."
+  (if (streamp stream)
+      (unless (eq (stream-in stream) #'closed-flame)
+	(funcall (stream-misc stream) stream :close abort))
+      (error "~S is not a stream." stream))
+  t)
+
+(defun set-closed-flame (stream)
+  (setf (stream-in stream) #'closed-flame)
+  (setf (stream-bin stream) #'closed-flame)
+  (setf (stream-n-bin stream) #'closed-flame)
+  (setf (stream-in stream) #'closed-flame)
+  (setf (stream-out stream) #'closed-flame)
+  (setf (stream-bout stream) #'closed-flame)
+  (setf (stream-sout stream) #'closed-flame)
+  (setf (stream-misc stream) #'closed-flame))
+
+;;; Input functions:
+
+(defun read-line (&optional (stream *standard-input*) (eof-errorp t) eof-value
+			    recursive-p)
+  "Returns a line of text read from the Stream as a string, discarding the
+  newline character."
+  (declare (ignore recursive-p))
+  (let* ((stream (in-synonym-of stream))
+	 (buffer (stream-in-buffer stream))
+	 (index (stream-in-index stream)))
+    (declare (fixnum index))
+    (if (simple-string-p buffer)
+	(let ((nl (%primitive find-character buffer index in-buffer-length
+			      #\newline)))
+	  (if nl
+	      (values (prog1 (subseq (the simple-string buffer) index nl)
+			     (setf (stream-in-index stream) (1+ (the fixnum nl))))
+		      nil)
+	      (multiple-value-bind (str eofp)
+				   (funcall (stream-misc stream) stream
+					    :read-line eof-errorp eof-value)
+		(declare (simple-string str))
+		(if (= index in-buffer-length)
+		    (values str eofp)
+		    (values (prog1
+			     (concatenate 'simple-string
+					  (subseq buffer index in-buffer-length)
+					  str)
+			     (setf (stream-in-index stream) in-buffer-length))
+			    eofp)))))
+	(funcall (stream-misc stream) stream :read-line eof-errorp eof-value))))
+
+;;; We proclaim them inline here, then proclaim them notinline at EOF,
+;;; so, except in this file, they are not inline by default, but they can be.
+;;;
+(proclaim '(inline read-char unread-char read-byte listen))
+(defun read-char (&optional (stream *standard-input*) (eof-errorp t) eof-value
+			    recursive-p)
+  "Inputs a character from Stream and returns it."
+  (declare (ignore recursive-p))
+  (let* ((stream (in-synonym-of stream))
+	 (index (stream-in-index stream)))
+    (declare (fixnum index))
+    (if (eql index in-buffer-length)
+	(funcall (stream-in stream) stream eof-errorp eof-value)
+	(prog1 (aref (stream-in-buffer stream) index)
+	       (setf (stream-in-index stream) (1+ index))))))
+
+(defun unread-char (character &optional (stream *standard-input*))
+  "Puts the Character back on the front of the input Stream."
+  (let* ((stream (in-synonym-of stream))
+	 (index (1- (the fixnum (stream-in-index stream))))
+	 (buffer (stream-in-buffer stream)))
+    (declare (fixnum index))
+    (when (minusp index) (error "Nothing to unread."))
+    (if buffer
+	(setf (aref (the simple-array buffer) index) character
+	      (stream-in-index stream) index)
+	(funcall (stream-misc stream) stream :unread character)))
+  nil)
+
+(defun peek-char (&optional (peek-type nil) (stream *standard-input*)
+			    (eof-errorp t) eof-value recursive-p)
+  "Peeks at the next character in the input Stream.  See manual for details."
+  (declare (ignore recursive-p))
+  (let* ((stream (in-synonym-of stream))
+	 (char (read-char stream eof-errorp eof-value)))
+    (cond ((eq char eof-value) char)
+	  ((characterp peek-type)
+	   (do ((char char (read-char stream eof-errorp eof-value)))
+	       ((or (eq char eof-value) (char= char peek-type))
+		(unless (eq char eof-value)
+		  (unread-char char stream))
+		char)))
+	  ((eq peek-type t)
+	   (do ((char char (read-char stream eof-errorp eof-value)))
+	       ((or (eq char eof-value) (not (whitespace-char-p char)))
+		(unless (eq char eof-value)
+		  (unread-char char stream))
+		char)))
+	  (t
+	   (unread-char char stream)
+	   char))))
+
+(defun listen (&optional (stream *standard-input*))
+  "Returns T if a character is availible on the given Stream."
+  (let ((stream (in-synonym-of stream)))
+    (or (/= (the fixnum (stream-in-index stream)) in-buffer-length)
+	(funcall (stream-misc stream) stream :listen))))
+
+(defun read-char-no-hang (&optional (stream *standard-input*)
+				    (eof-errorp t) eof-value recursive-p)
+  "Returns the next character from the Stream if one is availible, or nil."
+  (declare (ignore recursive-p))
+  (if (listen stream) (read-char stream eof-errorp eof-value) nil))
+
+(defun clear-input (&optional (stream *standard-input*))
+  "Clears any buffered input associated with the Stream."
+  (let ((stream (in-synonym-of stream)))
+    (setf (stream-in-index stream) in-buffer-length)
+    (funcall (stream-misc stream) stream :clear-input)))
+
+(defun read-byte (stream &optional (eof-errorp t) eof-value)
+  "Returns the next byte of the Stream."
+  (let* ((stream (in-synonym-of stream))
+	 (index (stream-in-index stream)))
+    (declare (fixnum index))
+    (if (eql index in-buffer-length)
+	(funcall (stream-bin stream) stream eof-errorp eof-value)
+	(prog1 (aref (stream-in-buffer stream) index)
+	       (setf (stream-in-index stream) (1+ index))))))
+
+(defun read-n-bytes (stream buffer start numbytes &optional (eof-errorp t))
+  "Reads Numbytes bytes into the Buffer starting at Start, and returns
+  the number of bytes actually read if the end of file was hit before Numbytes
+  bytes were read (and Eof-Errorp is false)."
+  (declare (fixnum numbytes))
+  (let* ((stream (in-synonym-of stream))
+	 (in-buffer (stream-in-buffer stream))
+	 (index (stream-in-index stream))
+	 (num-buffered (- in-buffer-length index)))
+    (declare (fixnum index num-buffered))
+    (cond
+     ((not buffer)
+      (with-in-stream stream stream-n-bin buffer start numbytes eof-errorp))
+     ((not (eql (%primitive get-vector-access-code in-buffer) 3))
+      (error "N-Bin only works on 8-bit-like streams."))
+     ((<= numbytes num-buffered)
+      (%primitive byte-blt in-buffer index buffer start (+ start numbytes))
+      (setf (stream-in-index stream) (+ index numbytes))
+      numbytes)
+     (t
+      (let ((end (+ start num-buffered)))
+	(%primitive byte-blt in-buffer index buffer start end)
+	(setf (stream-in-index stream) in-buffer-length)
+	(+ (with-in-stream stream stream-n-bin buffer end
+				   (- numbytes num-buffered)
+				   eof-errorp)
+	   num-buffered))))))
+
+;;; Output functions:
+
+(defun write-char (character &optional (stream *standard-output*))
+  "Outputs the Character to the Stream."
+  (with-out-stream stream stream-out character)
+  character)
+
+(defun terpri (&optional (stream *standard-output*))
+  "Outputs a new line to the Stream."
+  (with-out-stream stream stream-out #\newline)
+  nil)
+
+(defun fresh-line (&optional (stream *standard-output*))
+  "Outputs a new line to the Stream if it is not positioned at the begining of
+   a line.  Returns T if it output a new line, nil otherwise."
+  (let ((stream (out-synonym-of stream)))
+    (when (/= (or (charpos stream) 1) 0)
+      (funcall (stream-out stream) stream #\newline)
+      t)))
+
+(defun write-string (string &optional (stream *standard-output*)
+			    &key (start 0) (end (length (the vector string))))
+  "Outputs the String to the given Stream."
+  (write-string* string stream start end))
+
+(defun write-string* (string &optional (stream *standard-output*)
+			     (start 0) (end (length (the vector string))))
+  (declare (fixnum start end))
+  (if (array-header-p string)
+      (with-array-data ((data string) (offset-start start) (offset-end end))
+	(with-out-stream stream stream-sout data offset-start offset-end))
+      (with-out-stream stream stream-sout string start end))
+  string)
+
+(defun write-line (string &optional (stream *standard-output*)
+			  &key (start 0) (end (length string)))
+  "Outputs the String to the given Stream, followed by a newline character."
+  (write-line* string stream start end))
+
+(defun write-line* (string &optional (stream *standard-output*)
+			   (start 0) (end (length string)))
+  (declare (fixnum start end))
+  (let ((stream (out-synonym-of stream)))
+    (if (array-header-p string)
+	(with-array-data ((data string) (offset-start start) (offset-end end))
+	  (with-out-stream stream stream-sout data offset-start offset-end))
+	(with-out-stream stream stream-sout string start end))
+    (funcall (stream-out stream) stream #\newline))
+  string)
+
+(defun charpos (&optional (stream *standard-output*))
+  "Returns the number of characters on the current line of output of the given
+  Stream, or Nil if that information is not availible."
+  (with-out-stream stream stream-misc :charpos))
+
+(defun line-length (&optional (stream *standard-output*))
+  "Returns the number of characters that will fit on a line of output on the
+  given Stream, or Nil if that information is not available."
+  (with-out-stream stream stream-misc :line-length))
+
+(defun finish-output (&optional (stream *standard-output*))
+  "Attempts to ensure that all output sent to the the Stream has reached its
+   destination, and only then returns."
+  (with-out-stream stream stream-misc :finish-output)
+  nil)
+
+(defun force-output (&optional (stream *standard-output*))
+  "Attempts to force any buffered output to be sent."
+  (with-out-stream stream stream-misc :force-output)
+  nil)
+
+(defun clear-output (&optional (stream *standard-output*))
+  "Clears the given output Stream."
+  (with-out-stream stream stream-misc :clear-output)
+  nil)
+
+(defun write-byte (integer stream)
+  "Outputs the Integer to the binary Stream."
+  (with-out-stream stream stream-bout integer)
+  integer)
+
+;;;; Broadcast streams:
+
+(defstruct (broadcast-stream (:include stream
+				       (out #'broadcast-out)
+				       (bout #'broadcast-bout)
+				       (sout #'broadcast-sout)
+				       (misc #'broadcast-misc))
+			     (:print-function %print-broadcast-stream)
+			     (:constructor make-broadcast-stream (&rest streams)))
+  ;; This is a list of all the streams we broadcast to.
+  streams)
+
+(setf (documentation 'make-broadcast-stream 'function)
+ "Returns an ouput stream which sends its output to all of the given streams.")
+
+(defun %print-broadcast-stream (s stream d)
+  (declare (ignore s d))
+  (write-string "#<Broadcast Stream>" stream))
+
+(macrolet ((out-fun (fun method &rest args)
+	     `(defun ,fun (stream ,@args)
+		(dolist (stream (broadcast-stream-streams stream))
+		  (funcall (,method stream) stream ,@args)))))
+  (out-fun broadcast-out stream-out char)
+  (out-fun broadcast-bout stream-bout byte)
+  (out-fun broadcast-sout stream-sout string start end))
+
+(defun broadcast-misc (stream operation &optional arg1 arg2)
+  (let ((streams (broadcast-stream-streams stream)))
+    (case operation
+      (:charpos
+       (dolist (stream streams)
+	 (let ((charpos (funcall (stream-misc stream) stream :charpos)))
+	   (if charpos (return charpos)))))
+      (:line-length
+       (let ((min nil))
+	 (dolist (stream streams min)
+	   (let ((res (funcall (stream-misc stream) stream :line-length)))
+	     (when res (setq min (if min (min res min) res)))))))
+      (:element-type
+       (let (res)
+	 (dolist (stream streams (if (> (length res) 1) `(and ,@res) res))
+	   (pushnew (funcall (stream-misc stream) stream :element-type) res
+		    :test #'equal))))
+      (t
+       (let ((res nil))
+	 (dolist (stream streams res)
+	   (setq res (funcall (stream-misc stream) stream operation
+			      arg1 arg2))))))))
+
+;;;; Synonym Streams:
+
+(defstruct (synonym-stream (:include stream
+				     (in #'synonym-in)
+				     (bin #'synonym-bin)
+				     (n-bin #'synonym-n-bin)
+				     (out #'synonym-out)
+				     (bout #'synonym-bout)
+				     (sout #'synonym-sout)
+				     (misc #'synonym-misc))
+			   (:print-function %print-synonym-stream)
+			   (:constructor make-synonym-stream (symbol)))
+  ;; This is the symbol, the value of which is the stream we are synonym to.
+  symbol)
+
+(defun %print-synonym-stream (s stream d)
+  (declare (ignore d))
+  (format stream "#<Synonym Stream to ~S>" (synonym-stream-symbol s)))
+
+(setf (documentation 'make-synonym-stream 'function)
+  "Returns a stream which performs its operations on the stream which is the
+   value of the dynamic variable named by Symbol.")
+
+;;; The output simple output methods just call the corresponding method
+;;; in the synonymed stream.
+;;;
+(macrolet ((out-fun (name slot &rest args)
+	     `(defun ,name (stream ,@args)
+		(let ((syn (symbol-value (synonym-stream-symbol stream))))
+		  (funcall (,slot syn) syn ,@args)))))
+  (out-fun synonym-out stream-out ch)
+  (out-fun synonym-bout stream-bout n)
+  (out-fun synonym-sout stream-sout string start end))
+
+
+;;; Bind synonym stream to this so that SPIO can turn on the right frob in
+;;; the icon when we are in a terminal input wait.
+;;;
+(defvar *previous-stream* nil)
+
+;;; For the input methods, we just call the corresponding function on the
+;;; synonymed stream.  These functions deal with getting input out of
+;;; the In-Buffer if there is any.
+;;;
+(macrolet ((in-fun (name fun &rest args)
+	     `(defun ,name (stream ,@args)
+		(let ((*previous-stream* stream))
+		  (,fun (symbol-value (synonym-stream-symbol stream)) ,@args)))))
+  (in-fun synonym-in read-char eof-errorp eof-value)
+  (in-fun synonym-bin read-byte eof-errorp eof-value)
+  (in-fun synonym-n-bin read-n-bytes buffer start numbytes eof-errorp))
+
+
+;;; Synonym-Misc  --  Internal
+;;;
+;;;    We have to special-case the operations which could look at stuff in
+;;; the in-buffer.
+;;;
+(defun synonym-misc (stream operation &optional arg1 arg2)
+  (let ((syn (symbol-value (synonym-stream-symbol stream)))
+	(*previous-stream* stream))
+    (case operation
+      (:read-line (read-line syn))
+      (:listen (or (/= (the fixnum (stream-in-index syn)) in-buffer-length)
+		   (funcall (stream-misc syn) syn :listen)))
+      (t
+       (funcall (stream-misc syn) syn operation arg1 arg2)))))
+
+;;;; Two-Way streams:
+
+(defstruct (two-way-stream
+	    (:include stream
+		      (in #'two-way-in)
+		      (bin #'two-way-bin)
+		      (n-bin #'two-way-n-bin)
+		      (out #'two-way-out)
+		      (bout #'two-way-bout)
+		      (sout #'two-way-sout)
+		      (misc #'two-way-misc))
+	    (:print-function %print-two-way-stream)
+	    (:constructor make-two-way-stream (input-stream output-stream)))
+  ;; We read from this stream...
+  input-stream
+  ;; And write to this one
+  output-stream)
+
+(defun %print-two-way-stream (s stream d)
+  (declare (ignore d))
+  (format stream "#<Two-Way Stream, Input = ~S, Output = ~S>"
+	  (two-way-stream-input-stream s)
+	  (two-way-stream-output-stream s)))
+
+(setf (documentation 'make-two-way-stream 'function)
+  "Returns a bidirectional stream which gets its input from Input-Stream and
+   sends its output to Output-Stream.")
+
+(macrolet ((out-fun (name slot &rest args)
+	     `(defun ,name (stream ,@args)
+		(let ((syn (two-way-stream-output-stream stream)))
+		  (funcall (,slot syn) syn ,@args)))))
+  (out-fun two-way-out stream-out ch)
+  (out-fun two-way-bout stream-bout n)
+  (out-fun two-way-sout stream-sout string start end))
+
+(macrolet ((in-fun (name fun &rest args)
+	     `(defun ,name (stream ,@args)
+		(,fun (two-way-stream-input-stream stream) ,@args))))
+  (in-fun two-way-in read-char eof-errorp eof-value)
+  (in-fun two-way-bin read-byte eof-errorp eof-value)
+  (in-fun two-way-n-bin read-n-bytes buffer start numbytes eof-errorp))
+
+(defun two-way-misc (stream operation &optional arg1 arg2)
+  (let* ((in (two-way-stream-input-stream stream))
+	 (in-method (stream-misc in))
+	 (out (two-way-stream-output-stream stream))
+	 (out-method (stream-misc out)))
+    (case operation
+      (:listen (or (/= (the fixnum (stream-in-index in)) in-buffer-length)
+		   (funcall in-method in :listen)))
+      (:read-line (read-line in arg1 arg2))
+      ((:finish-output :force-output :clear-output)
+       (funcall out-method out operation arg1 arg2))
+      ((:clear-input :unread)
+       (funcall in-method in operation arg1 arg2))
+      (:element-type
+       (let ((in-type (funcall in-method in :element-type))
+	     (out-type (funcall out-method out :element-type)))
+	 (if (equal in-type out-type)
+	     in-type `(and ,in-type ,out-type))))
+      (:close 
+       (funcall in-method in :close arg1)
+       (funcall out-method out :close arg1)
+       (set-closed-flame stream))
+      (t
+       (or (funcall in-method in operation arg1 arg2)
+	   (funcall out-method out operation arg1 arg2))))))
+
+;;;; Concatenated Streams:
+
+(defstruct (concatenated-stream
+	    (:include stream
+		      (in #'concatenated-in)
+		      (bin #'concatenated-bin)
+		      (misc #'concatenated-misc))
+	    (:print-function %print-concatenated-stream)
+	    (:constructor
+	     make-concatenated-stream (&rest streams &aux (current streams))))
+  ;; The car of this is the stream we are reading from now.
+  current
+  ;; This is a list of all the streams.  We need to remember them so that
+  ;; we can close them.
+  streams)
+
+(defun %print-concatenated-stream (s stream d)
+  (declare (ignore d))
+  (format stream "#<Concatenated Stream, Streams = ~S>"
+	  (concatenated-stream-streams s)))
+
+(setf (documentation 'make-concatenated-stream 'function)
+  "Returns a stream which takes its input from each of the Streams in turn,
+   going on to the next at EOF.")
+
+(macrolet ((in-fun (name fun)
+	     `(defun ,name (stream eof-errorp eof-value)
+		(do ((current (concatenated-stream-current stream) (cdr current)))
+		    ((null current)
+		     (eof-or-lose stream eof-errorp eof-value))
+		  (let* ((stream (car current))
+			 (result (,fun stream nil nil)))
+		    (when result (return result)))
+		  (setf (concatenated-stream-current stream) current)))))
+  (in-fun concatenated-in read-char)
+  (in-fun concatenated-bin read-byte))
+
+;;;    Concatenated-Readline is somewhat hairy, since we may need to
+;;; do several readlines and concatenate the result if the lines are
+;;; terminated by eof.
+;;;
+(defun concatenated-readline (stream eof-errorp eof-value)
+  ;; Loop until we find a stream that will give us something or we error
+  ;; out.
+  (do ((current (concatenated-stream-current stream) (cdr current)))
+      ((null current)
+       (eof-or-lose stream eof-errorp eof-value))
+    (setf (concatenated-stream-current stream) current)
+    (let ((this (car current)))
+      (multiple-value-bind (result eofp)
+			   (read-line this nil nil)
+	(declare (simple-string result))
+	;; Once we have found some input, we loop until we either find a 
+	;; line not terminated by eof or hit eof on the last stream.
+	(when result
+	  (do ((current (cdr current) (cdr current))
+	       (new ""))
+	      ((or (not eofp) (null current))
+	       (return-from concatenated-readline (values result eofp)))
+	    (declare (simple-string new))
+	    (setf (concatenated-stream-current stream) current)
+	    (let ((this (car current)))
+	      (multiple-value-setq (new eofp)
+		(read-line this nil nil))
+	      (if new
+		  (setq result (concatenate 'simple-string result new))
+		  (setq eofp t)))))))))
+
+(defun concatenated-misc (stream operation &optional arg1 arg2)
+  (if (eq operation :read-line)
+      (concatenated-readline stream arg1 arg2)
+      (let ((left (concatenated-stream-current stream)))
+	(when left
+	  (let* ((current (car left))
+		 (misc (stream-misc current)))
+	    (case operation
+	      (:listen (or (/= (the fixnum (stream-in-index current)) in-buffer-length)
+			   (funcall misc current :listen)))
+	      (:close
+	       (dolist (stream (concatenated-stream-streams stream))
+		 (funcall (stream-misc stream) stream :close arg1))
+	       (set-closed-flame stream))
+	      (t
+	       (funcall misc current operation arg1 arg2))))))))
+
+;;;; Echo Streams:
+
+(defstruct (echo-stream
+	    (:include two-way-stream
+		      (in #'echo-in)
+		      (bin #'echo-bin)
+		      (misc #'echo-misc)
+		      (n-bin #'ill-bin))
+	    (:print-function %print-echo-stream)
+	    (:constructor make-echo-stream (input-stream output-stream))))
+
+
+(macrolet ((in-fun (name fun out-slot &rest args)
+	     `(defun ,name (stream ,@args)
+		(let* ((in (two-way-stream-input-stream stream))
+		       (out (two-way-stream-output-stream stream))
+		       (result (,fun in ,@args)))
+		  (funcall (,out-slot out) out result)
+		  result))))
+  (in-fun echo-in read-char stream-out eof-errorp eof-value)
+  (in-fun echo-bin read-byte stream-bout eof-errorp eof-value))
+
+(defun echo-misc (stream operation &optional arg1 arg2)
+  (let* ((in (two-way-stream-input-stream stream))
+	 (in-method (stream-misc in))
+	 (out (two-way-stream-output-stream stream))
+	 (out-method (stream-misc out)))
+    (case operation
+      (:listen (or (/= (the fixnum (stream-in-index in)) in-buffer-length)
+		   (funcall in-method in :listen)))
+      (:read-line
+       (multiple-value-bind (result eofp)
+			    (read-line in arg1 arg2)
+	 (if eofp
+	     (write-string result out)
+	     (write-line result out))
+	 (values result eofp)))
+      (:element-type
+       (let ((in-type (funcall in-method in :element-type))
+	     (out-type (funcall out-method out :element-type)))
+	 (if (equal in-type out-type)
+	     in-type `(and ,in-type ,out-type))))
+      (:close
+       (funcall in-method in :close arg1)
+       (funcall out-method out :close arg1)
+       (set-closed-flame stream))
+      (t
+       (or (funcall in-method in operation arg1 arg2)
+	   (funcall out-method out operation arg1 arg2))))))
+
+(defun %print-echo-stream (s stream d)
+  (declare (ignore d))
+  (format stream "#<Echo Stream, Input = ~S, Output = ~S>"
+	  (two-way-stream-input-stream s)
+	  (two-way-stream-output-stream s)))
+
+(setf (documentation 'make-echo-stream 'function)
+  "Returns a bidirectional stream which gets its input from Input-Stream and
+   sends its output to Output-Stream.  In addition, all input is echoed to
+   the output stream")
+
+;;;; String Input Streams:
+
+(defstruct (string-input-stream
+	    (:include stream
+		      (in #'string-inch)
+		      (misc #'string-in-misc))
+	    (:print-function %print-string-input-stream)
+	    (:constructor nil)
+	    (:constructor internal-make-string-input-stream
+			  (string current end)))
+  (string nil :type simple-string)
+  (current nil :type fixnum)
+  (end nil :type fixnum))
+
+(defun %print-string-input-stream (s stream d)
+  (declare (ignore s d))
+  (write-string "#<String-Input Stream>" stream))
+  
+(defun string-inch (stream eof-errorp eof-value)
+  (let ((string (string-input-stream-string stream))
+	(index (string-input-stream-current stream)))
+    (declare (simple-string string) (fixnum index))
+    (cond ((= index (the fixnum (string-input-stream-end stream)))
+	   (eof-or-lose stream eof-errorp eof-value))
+	  (t
+	   (setf (string-input-stream-current stream) (1+ index))
+	   (aref string index)))))
+
+(defun string-in-misc (stream operation &optional arg1 arg2)
+  (case operation
+    (:read-line
+     (let ((string (string-input-stream-string stream))
+	   (current (string-input-stream-current stream))
+	   (end (string-input-stream-end stream)))
+       (declare (simple-string string) (fixnum current end))
+       (if (= current end)
+	   (eof-or-lose stream arg1 arg2)
+	   (let ((pos (%primitive find-character string current end #\newline)))
+	     (if pos
+		 (let* ((res-length (- (the fixnum pos) current))
+			(result (make-string res-length)))
+		   (%primitive byte-blt string current result 0 res-length)
+		   (setf (string-input-stream-current stream)
+			 (1+ (the fixnum pos)))
+		   (values result nil))
+		 (let* ((res-length (- end current))
+			(result (make-string res-length)))
+		   (%primitive byte-blt string current result 0 res-length)
+		   (setf (string-input-stream-current stream) end)
+		   (values result t)))))))
+    (:unread (decf (string-input-stream-current stream)))
+    (:listen (not (= (the fixnum (string-input-stream-current stream))
+		     (the fixnum (string-input-stream-end stream)))))
+    (:element-type 'string-char)))
+  
+(defun make-string-input-stream (string &optional
+					(start 0) (end (length string)))
+  "Returns an input stream which will supply the characters of String between
+  Start and End in order."
+  (if (stringp string)
+      (internal-make-string-input-stream (coerce string 'simple-string)
+					 start end)
+      (error "~S is not a string." string)))
+
+;;;; String Output Streams:
+
+(defstruct (string-output-stream
+	    (:include stream
+		      (out #'string-ouch)
+		      (sout #'string-sout)
+		      (misc #'string-out-misc))
+	    (:print-function %print-string-output-stream)
+	    (:constructor make-string-output-stream ()))
+  ;; The string we throw stuff in.
+  (string (make-string 40) :type simple-string)
+  ;; Index of the next location to use.
+  (index 0 :type fixnum))
+
+(defun %print-string-output-stream (s stream d)
+  (declare (ignore s d))
+  (write-string "#<String-Output Stream>" stream))
+
+(setf (documentation 'make-string-output-stream 'function)
+  "Returns an Output stream which will accumulate all output given it for
+   the benefit of the function Get-Output-Stream-String.")
+
+(defun string-ouch (stream character)
+  (let ((current (string-output-stream-index stream))
+	(workspace (string-output-stream-string stream)))
+    (declare (simple-string workspace) (fixnum current))
+    (if (= current (the fixnum (length workspace)))
+	(let ((new-workspace (make-string (* current 2))))
+	  (%primitive byte-blt workspace 0 new-workspace 0 current)
+	  (setf (aref new-workspace current) character)
+	  (setf (string-output-stream-string stream) new-workspace))
+	(setf (aref workspace current) character))
+    (setf (string-output-stream-index stream) (1+ current))))
+
+(defun string-sout (stream string start end)
+  (declare (simple-string string) (fixnum start end))
+  (let* ((current (string-output-stream-index stream))
+	 (length (- end start))
+	 (dst-end (+ length current))
+	 (workspace (string-output-stream-string stream)))
+    (declare (simple-string workspace)
+	     (fixnum current length dst-end))
+    (if (> dst-end (the fixnum (length workspace)))
+	(let ((new-workspace (make-string (+ (* current 2) length))))
+	  (%primitive byte-blt workspace 0 new-workspace 0 current)
+	  (%primitive byte-blt string start new-workspace current dst-end)
+	  (setf (string-output-stream-string stream) new-workspace))
+	(%primitive byte-blt string start workspace current dst-end))
+    (setf (string-output-stream-index stream) dst-end)))
+
+(defun string-out-misc (stream operation &optional arg1 arg2)
+  (declare (ignore arg1 arg2))
+  (case operation
+    (:charpos
+     (do ((index (1- (the fixnum (string-output-stream-index stream)))
+		 (1- index))
+	  (count 0 (1+ count))
+	  (string (string-output-stream-string stream)))
+	 ((< index 0) count)
+       (declare (simple-string string)
+		(fixnum index count))
+       (if (char= (schar string index) #\newline)
+	   (return count))))
+    (:element-type 'string-char)))
+
+(defun get-output-stream-string (stream)
+  "Returns a string of all the characters sent to a stream made by
+   Make-String-Output-Stream since the last call to this function."
+  (if (streamp stream)
+      (let* ((length (string-output-stream-index stream))
+	     (result (make-string length)))
+	(%primitive byte-blt (string-output-stream-string stream) 0
+		      result 0 length)
+	(setf (string-output-stream-index stream) 0)
+	result)
+      (error "~S is not a string stream.")))
+
+(defun dump-output-stream-string (in-stream out-stream)
+  "Dumps the characters buffer up in the In-Stream to the Out-Stream as
+  Get-Output-Stream-String would return them."
+  (write-string (string-output-stream-string in-stream) out-stream
+		:start 0 :end (string-output-stream-index in-stream))
+  (setf (string-output-stream-index in-stream) 0))
+
+;;;; Fill-pointer streams:
+;;;
+;;;    Fill pointer string output streams are not explicitly mentioned in
+;;; the CLM, but they are required for the implementation of With-Output-To-String.
+
+(defstruct (fill-pointer-output-stream
+ 	    (:include stream
+		      (out #'fill-pointer-ouch)
+		      (sout #'fill-pointer-sout)
+		      (misc #'fill-pointer-misc))
+	    (:print-function
+	     (lambda (s stream d)
+	       (declare (ignore s d))
+	       (write-string "#<Fill-Pointer String Output Stream>" stream)))
+	    (:constructor make-fill-pointer-output-stream (string)))
+  ;; The string we throw stuff in.
+  string)
+
+ 
+(defun fill-pointer-ouch (stream character)
+  (let* ((buffer (fill-pointer-output-stream-string stream))
+	 (current (%primitive header-ref buffer %array-fill-pointer-slot))
+	 (current+1 (1+ current)))
+    (declare (fixnum current))
+    (with-array-data ((workspace buffer) (start) (end))
+      (declare (simple-string workspace))
+      (let ((offset-current (+ start current)))
+	(declare (fixnum offset-current))
+	(if (= offset-current end)
+	    (let* ((new-length (* current 2))
+		   (new-workspace (make-string new-length)))
+	      (declare (simple-string new-workspace))
+	      (%primitive byte-blt workspace start new-workspace 0 current)
+	      (setf workspace new-workspace)
+	      (setf offset-current current)
+	      (set-array-header buffer workspace new-length
+				current+1 0 new-length nil))
+	    (%primitive header-set buffer %array-fill-pointer-slot current+1))
+	(setf (schar workspace offset-current) character)))
+    current+1))
+
+
+(defun fill-pointer-sout (stream string start end)
+  (declare (simple-string string) (fixnum start end))
+  (let* ((buffer (fill-pointer-output-stream-string stream))
+	 (current (%primitive header-ref buffer %array-fill-pointer-slot))
+	 (string-len (- end start))
+	 (dst-end (+ string-len current)))
+    (declare (fixnum current dst-end string-len))
+    (with-array-data ((workspace buffer) (dst-start) (dst-length))
+      (declare (simple-string workspace))
+      (let ((offset-dst-end (+ dst-start dst-end))
+	    (offset-current (+ dst-start current)))
+	(declare (fixnum offset-dst-end offset-current))
+	(if (> offset-dst-end dst-length)
+	    (let* ((new-length (+ (the fixnum (* current 2)) string-len))
+		   (new-workspace (make-string new-length)))
+	      (declare (simple-string new-workspace))
+	      (%primitive byte-blt workspace dst-start new-workspace 0 current)
+	      (setf workspace new-workspace)
+	      (setf offset-current current)
+	      (setf offset-dst-end dst-end)
+	      (set-array-header buffer workspace new-length
+				dst-end 0 new-length nil))
+	    (%primitive header-set buffer %array-fill-pointer-slot dst-end))
+	(%primitive byte-blt string start
+		    workspace offset-current offset-dst-end)))
+    dst-end))
+
+
+(defun fill-pointer-misc (stream operation &optional arg1 arg2)
+  (declare (ignore arg1 arg2))
+  (case operation
+    (:charpos
+     (let* ((buffer (fill-pointer-output-stream-string stream))
+	    (current (%primitive header-ref buffer %array-fill-pointer-slot)))
+       (with-array-data ((string buffer) (start) (end current))
+	 (declare (simple-string string) (ignore start))
+	 (let ((found (position #\newline string :test #'char=
+				:end end :from-end t)))
+	   (if found
+	       (- end (the fixnum found))
+	       current)))))
+     (:element-type 'string-char)))
+
+;;;; Indenting streams:
+
+(defstruct (indenting-stream (:include stream
+				       (out #'indenting-out)
+				       (sout #'indenting-sout)
+				       (misc #'indenting-misc))
+			     (:print-function %print-indenting-stream)
+			     (:constructor make-indenting-stream (stream)))
+  ;; The stream we're based on:
+  stream
+  ;; How much we indent on each line:
+  (indentation 0))
+
+(setf (documentation 'make-indenting-stream 'function)
+ "Returns an ouput stream which indents its output by some amount.")
+
+(defun %print-indenting-stream (s stream d)
+  (declare (ignore s d))
+  (write-string "#<Indenting Stream>" stream))
+
+;;; Indenting-Indent writes the right number of spaces needed to indent output on
+;;; the given Stream based on the specified Sub-Stream.
+
+(defmacro indenting-indent (stream sub-stream)
+  `(do ((i 0 (+ i 60))
+	(indentation (indenting-stream-indentation ,stream)))
+       ((>= i indentation))
+     (funcall (stream-sout ,sub-stream) ,sub-stream
+	      "                                                            "
+	      0 (min 60 (- indentation i)))))
+
+;;; Indenting-Out writes a character to an indenting stream.
+
+(defun indenting-out (stream char)
+  (let ((sub-stream (indenting-stream-stream stream)))
+    (funcall (stream-out sub-stream) sub-stream char)
+    (if (char= char #\newline)
+	(indenting-indent stream sub-stream))))
+
+;;; Indenting-Sout writes a string to an indenting stream.
+
+(defun indenting-sout (stream string start end)
+  (declare (simple-string string) (fixnum start end))
+  (do ((i start)
+       (sub-stream (indenting-stream-stream stream)))
+      ((= i end))
+    (let ((newline (position #\newline string :start i :end end)))
+      (cond (newline
+	     (funcall (stream-sout sub-stream) sub-stream string i (1+ newline))
+	     (indenting-indent stream sub-stream)
+	     (setq i (+ newline 1)))
+	    (t
+	     (funcall (stream-sout sub-stream) sub-stream string i end)
+	     (setq i end))))))
+
+;;; Indenting-Misc just treats just the :Line-Length message differently.
+;;; Indenting-Charpos says the charpos is the charpos of the base stream minus
+;;; the stream's indentation.
+
+(defun indenting-misc (stream operation &optional arg1 arg2)
+  (let* ((sub-stream (indenting-stream-stream stream))
+	 (method (stream-misc sub-stream)))
+    (case operation
+      (:line-length
+       (let ((line-length (funcall method sub-stream operation)))
+	 (if line-length
+	     (- line-length (indenting-stream-indentation stream)))))
+      (:charpos
+       (let* ((sub-stream (indenting-stream-stream stream))
+	      (charpos (funcall method sub-stream operation)))
+	 (if charpos
+	     (- charpos (indenting-stream-indentation stream)))))       
+      (t
+       (funcall method sub-stream operation arg1 arg2)))))
+
+(proclaim '(notinline read-char unread-char read-byte listen))
diff --git a/code/string.lisp b/code/string.lisp
new file mode 100644
index 000000000..c9c960880
--- /dev/null
+++ b/code/string.lisp
@@ -0,0 +1,608 @@
+;;; -*- Log: code.log; Package: Lisp -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; Functions to implement strings for Spice Lisp
+;;; Written by David Dill
+;;; Rewritten and currently maintained by Skef Wholey
+;;;
+;;; Runs in the standard Spice Lisp environment.
+;;;
+;;; ****************************************************************
+;;;
+(in-package 'lisp)
+(export '(char schar string
+	  string= string-equal string< string> string<= string>= string/=
+	  string-lessp string-greaterp string-not-lessp string-not-greaterp
+	  string-not-equal
+	  make-string
+	  string-trim string-left-trim string-right-trim
+	  string-upcase
+	  string-downcase string-capitalize nstring-upcase nstring-downcase
+	  nstring-capitalize))
+
+(eval-when (compile)
+
+;;; %String returns its arg if it is a string, otherwise calls String.
+;;;
+(defmacro %string (thing)
+  `(if (stringp ,thing) ,thing (string ,thing)))
+)
+
+(defun string (X)
+  "Coerces X into a string.  If X is a string, X is returned.  If X is a
+   symbol, X's pname is returned.  If X is a character then a one element
+   string containing that character is returned.  If X cannot be coerced
+   into a string, an error occurs."
+  (cond ((stringp x) x)
+	((symbolp x) (symbol-name x))
+	((characterp x)
+	 (let ((res (make-string 1)))
+	   (setf (schar res 0) x) res))
+	(t
+	 (error "~S cannot be coerced to a string." x))))
+
+
+;;; With-One-String is used to set up some string hacking things.  The keywords
+;;; are parsed, and the string is hacked into a simple-string.
+
+(eval-when (compile)
+
+(defmacro with-one-string (string start end cum-offset &rest forms)
+  (let ((data (gensym))
+	(data-start (gensym))
+	(data-end (gensym))
+	(offset (gensym)))
+    `(progn
+      (if (symbolp ,string) (setq ,string (symbol-name ,string)))
+      (if (array-header-p ,string)
+	  (with-array-data ((,data ,string :offset-var ,offset)
+			    (,data-start ,start)
+			    (,data-end (or ,end
+					   (%primitive header-ref ,string
+						       %array-fill-pointer-slot))))
+			   (psetq ,string ,data
+				  ,cum-offset ,offset
+				  ,start ,data-start
+				  ,end ,data-end))
+	  (if (not ,end) (setq ,end (length (the simple-string ,string)))))
+      ,@forms)))
+
+)
+
+;;; With-String is like With-One-String, but doesn't parse keywords.
+
+(eval-when (compile)
+
+(defmacro with-string (string &rest forms)
+  `(let ((start 0)
+	 (end ()))
+     (if (symbolp ,string) (setq ,string (symbol-name ,string)))
+     (if (array-header-p ,string)
+	 (with-array-data ((data ,string)
+			   (data-start start)
+			   (data-end (%primitive header-ref ,string
+						 %array-fill-pointer-slot)))
+	   (psetq ,string data
+		  start data-start
+		  end data-end))
+	 (setq end (length (the simple-string ,string))))
+     ,@forms))
+
+)
+
+;;; With-Two-Strings is used to set up string comparison operations.  The
+;;; keywords are parsed, and the strings are hacked into simple-strings.
+
+(eval-when (compile)
+
+(defmacro with-two-strings (string1 string2 start1 end1 cum-offset-1
+				    start2 end2 &rest forms)
+  (let ((data (gensym))
+	(data-start (gensym))
+	(data-end (gensym))
+	(offset (gensym)))
+    `(progn
+      (if (symbolp ,string1) (setq ,string1 (symbol-name ,string1)))
+      (if (symbolp ,string2) (setq ,string2 (symbol-name ,string2)))
+      (if (array-header-p ,string1)
+	  (with-array-data ((,data ,string1 :offset-var ,offset)
+			    (,data-start ,start1)
+			    (,data-end (or ,end1
+					   (%primitive header-ref ,string1
+						       %array-fill-pointer-slot))))
+			   (psetq ,string1 ,data
+				  ,cum-offset-1 ,offset
+				  ,start1 ,data-start
+				  ,end1 ,data-end))
+	  (if (not ,end1) (setq ,end1 (length (the simple-string ,string1)))))
+      (if (array-header-p ,string2)
+	  (with-array-data ((,data ,string2)
+			    (,data-start ,start2)
+			    (,data-end (or ,end2
+					   (%primitive header-ref ,string2
+						       %array-fill-pointer-slot))))
+			   (psetq ,string2 ,data
+				  ,start2 ,data-start
+				  ,end2 ,data-end))
+	  (if (not ,end2) (setq ,end2 (length (the simple-string ,string2)))))
+      ,@forms)))
+
+)
+
+(defun char (string index)
+  "Given a string and a non-negative integer index less than the length of
+  the string, returns the character object representing the character at
+  that position in the string."
+  (char string index))
+
+(defun %charset (string index new-el)
+  (setf (char string index) new-el))
+
+(defun schar (string index)
+  "SCHAR returns the character object at an indexed position in a string
+   just as CHAR does, except the string must be a simple-string."
+  (schar string index))
+
+(defun %scharset (string index new-el)
+  (setf (schar string index) new-el))
+
+(defun string=* (string1 string2 start1 end1 start2 end2)
+  (let ((offset1 0))
+    (with-two-strings string1 string2 start1 end1 offset1 start2 end2
+      (not (%sp-string-compare string1 start1 end1 string2 start2 end2)))))
+
+
+(defun string/=* (string1 string2 start1 end1 start2 end2)
+  (let ((offset1 0))
+    (with-two-strings string1 string2 start1 end1 offset1 start2 end2
+      (let ((comparison (%sp-string-compare string1 start1 end1
+					    string2 start2 end2)))
+	(if comparison (- (the fixnum comparison) offset1))))))
+
+(eval-when (compile eval)
+
+;;; Lessp is true if the desired expansion is for string<* or string<=*.
+;;; Equalp is true if the desired expansion is for string<=* or string>=*.
+(defmacro string<>=*-body (lessp equalp)
+  (let ((offset1 (gensym)))
+    `(let ((,offset1 0))
+       (declare (fixnum ,offset1))
+       (with-two-strings string1 string2 start1 end1 ,offset1 start2 end2
+	 (let ((index (%sp-string-compare string1 start1 end1
+					  string2 start2 end2)))
+	   (if index
+	       (cond ((= (the fixnum index)
+			 ,(if lessp `(the fixnum end1) `(the fixnum end2)))
+		      (- (the fixnum index) ,offset1))
+		     ((= (the fixnum index)
+			 ,(if lessp `(the fixnum end2) `(the fixnum end1)))
+		      nil)
+		     ((,(if lessp 'char< 'char>)
+		       (schar string1 index)
+		       (schar string2 (+ (the fixnum index) (- start2 start1))))
+		      (- (the fixnum index) ,offset1))
+		     (t nil))
+	       ,(if equalp `(- (the fixnum end1) ,offset1) 'nil)))))))
+) ; eval-when
+
+(defun string<* (string1 string2 start1 end1 start2 end2)
+  (declare (fixnum start1 start2))
+  (string<>=*-body t nil))
+
+(defun string>* (string1 string2 start1 end1 start2 end2)
+  (declare (fixnum start1 start2))
+  (string<>=*-body nil nil))
+
+(defun string<=* (string1 string2 start1 end1 start2 end2)
+  (declare (fixnum start1 start2))
+  (string<>=*-body t t))
+
+(defun string>=* (string1 string2 start1 end1 start2 end2)
+  (declare (fixnum start1 start2))
+  (string<>=*-body nil t))
+
+
+
+(defun string< (string1 string2 &key (start1 0) end1 (start2 0) end2)
+  "Given two strings, if the first string is lexicographically less than
+  the second string, returns the longest common prefix (using char=)
+  of the two strings. Otherwise, returns ()."
+  (string<* string1 string2 start1 end1 start2 end2))
+
+(defun string> (string1 string2 &key (start1 0) end1 (start2 0) end2)
+  "Given two strings, if the first string is lexicographically greater than
+  the second string, returns the longest common prefix (using char=)
+  of the two strings. Otherwise, returns ()."
+  (string>* string1 string2 start1 end1 start2 end2))
+
+
+(defun string<= (string1 string2 &key (start1 0) end1 (start2 0) end2)
+  "Given two strings, if the first string is lexicographically less than
+  or equal to the second string, returns the longest common prefix
+  (using char=) of the two strings. Otherwise, returns ()."
+  (string<=* string1 string2 start1 end1 start2 end2))
+
+(defun string>= (string1 string2 &key (start1 0) end1 (start2 0) end2)
+  "Given two strings, if the first string is lexicographically greater
+  than or equal to the second string, returns the longest common prefix
+  (using char=) of the two strings. Otherwise, returns ()."
+  (string>=* string1 string2 start1 end1 start2 end2))
+
+(defun string= (string1 string2 &key (start1 0) end1 (start2 0) end2)
+  "Given two strings (string1 and string2), and optional integers start1,
+  start2, end1 and end2, compares characters in string1 to characters in
+  string2 (using char=)."
+  (string=* string1 string2 start1 end1 start2 end2))
+
+(defun string/= (string1 string2 &key (start1 0) end1 (start2 0) end2)
+  "Given two strings, if the first string is not lexicographically equal
+  to the second string, returns the longest common prefix (using char=)
+  of the two strings. Otherwise, returns ()."
+  (string/=* string1 string2 start1 end1 start2 end2))
+
+
+(eval-when (compile eval)
+
+;;; STRING-NOT-EQUAL-LOOP is used to generate character comparison loops for
+;;; STRING-EQUAL and STRING-NOT-EQUAL.
+(defmacro string-not-equal-loop (end end-value
+				     &optional (abort-value nil abortp))
+  (declare (fixnum end))
+  (let ((end-test (if (= end 1)
+		      `(= index1 (the fixnum end1))
+		      `(= index2 (the fixnum end2)))))
+    `(do ((index1 start1 (1+ index1))
+	  (index2 start2 (1+ index2)))
+	 (,(if abortp
+	       end-test
+	       `(or ,end-test
+		    (not (char-equal (schar string1 index1)
+				     (schar string2 index2)))))
+	  ,end-value)
+       (declare (fixnum index1 index2))
+       ,@(if abortp
+	     `((if (not (char-equal (schar string1 index1)
+				    (schar string2 index2)))
+		   (return ,abort-value)))))))
+
+) ; eval-when
+
+(defun string-equal (string1 string2 &key (start1 0) end1 (start2 0) end2)
+  "Given two strings (string1 and string2), and optional integers start1,
+  start2, end1 and end2, compares characters in string1 to characters in
+  string2 (using char-equal)."
+  (declare (fixnum start1 start2))
+  (let ((offset1 0))
+    (with-two-strings string1 string2 start1 end1 offset1 start2 end2
+      (let ((slen1 (- (the fixnum end1) start1))
+	    (slen2 (- (the fixnum end2) start2)))
+	(declare (fixnum slen1 slen2))
+	(if (or (minusp slen1) (minusp slen2))
+	    ;;prevent endless looping later.
+	    (error "Improper bounds for string comparison."))
+	(if (= slen1 slen2)
+	    ;;return () immediately if lengths aren't equal.
+	    (string-not-equal-loop 1 t nil)))))) 
+
+(defun string-not-equal (string1 string2 &key (start1 0) end1 (start2 0) end2)
+  "Given two strings, if the first string is not lexicographically equal
+  to the second string, returns the longest common prefix (using char-equal)
+  of the two strings. Otherwise, returns ()."
+  (let ((offset1 0))
+    (declare (fixnum offset1))
+    (with-two-strings string1 string2 start1 end1 offset1 start2 end2
+      (let ((slen1 (- end1 start1))
+	    (slen2 (- end2 start2)))
+	(declare (fixnum slen1 slen2))
+	(if (or (minusp slen1) (minusp slen2))
+	    ;;prevent endless looping later.
+	    (error "Improper bounds for string comparison."))
+	(cond ((or (minusp slen1) (or (minusp slen2)))
+	       (error "Improper substring for comparison."))
+	      ((= slen1 slen2)
+	       (string-not-equal-loop 1 nil (- index1 offset1)))
+	      ((< slen1 slen2)
+	       (string-not-equal-loop 1 (- index1 offset1)))
+	      (t
+	       (string-not-equal-loop 2 (- index1 offset1))))))))
+ 
+
+
+(eval-when (compile eval)
+
+;;; STRING-LESS-GREATER-EQUAL-TESTS returns a test on the lengths of string1
+;;; and string2 and a test on the current characters from string1 and string2
+;;; for the following macro.
+(defun string-less-greater-equal-tests (lessp equalp)
+  (if lessp
+      (if equalp
+	  ;; STRING-NOT-GREATERP
+	  (values '<= `(not (char-greaterp char1 char2)))
+	  ;; STRING-LESSP
+	  (values '< `(char-lessp char1 char2)))
+      (if equalp
+	  ;; STRING-NOT-LESSP
+	  (values '>= `(not (char-lessp char1 char2)))
+	  ;; STRING-GREATERP
+	  (values '> `(char-greaterp char1 char2)))))
+
+(defmacro string-less-greater-equal (lessp equalp)
+  (multiple-value-bind (length-test character-test)
+		       (string-less-greater-equal-tests lessp equalp)
+    `(let ((offset1 0))
+       (declare (fixnum offset1))
+       (with-two-strings string1 string2 start1 end1 offset1 start2 end2
+	 (let ((slen1 (- (the fixnum end1) start1))
+	       (slen2 (- (the fixnum end2) start2)))
+	   (declare (fixnum slen1 slen2))
+	   (if (or (minusp slen1) (minusp slen2))
+	       ;;prevent endless looping later.
+	       (error "Improper bounds for string comparison."))
+	   (do ((index1 start1 (1+ index1))
+		(index2 start2 (1+ index2))
+		(char1)
+		(char2))
+	       ((or (= index1 (the fixnum end1)) (= index2 (the fixnum end2)))
+		(if (,length-test slen1 slen2) (- index1 offset1)))
+	     (declare (fixnum index1 index2))
+	     (setq char1 (schar string1 index1))
+	     (setq char2 (schar string2 index2))
+	     (if (not (char-equal char1 char2))
+		 (if ,character-test
+		     (return (- index1 offset1))
+		     (return ())))))))))
+
+) ; eval-when
+
+(defun string-lessp* (string1 string2 start1 end1 start2 end2)
+  (declare (fixnum start1 start2))
+  (string-less-greater-equal t nil))
+
+(defun string-greaterp* (string1 string2 start1 end1 start2 end2)
+  (declare (fixnum start1 start2))
+  (string-less-greater-equal nil nil))
+
+(defun string-not-lessp* (string1 string2 start1 end1 start2 end2)
+  (declare (fixnum start1 start2))
+  (string-less-greater-equal nil t))
+
+(defun string-not-greaterp* (string1 string2 start1 end1 start2 end2)
+  (declare (fixnum start1 start2))
+  (string-less-greater-equal t t))
+
+(defun string-lessp (string1 string2 &key (start1 0) end1 (start2 0) end2)
+  "Given two strings, if the first string is lexicographically less than
+  the second string, returns the longest common prefix (using char-equal)
+  of the two strings. Otherwise, returns ()."
+  (string-lessp* string1 string2 start1 end1 start2 end2))
+
+(defun string-greaterp (string1 string2 &key (start1 0) end1 (start2 0) end2)
+  "Given two strings, if the first string is lexicographically greater than
+  the second string, returns the longest common prefix (using char-equal)
+  of the two strings. Otherwise, returns ()."
+  (string-greaterp* string1 string2 start1 end1 start2 end2))
+
+(defun string-not-lessp (string1 string2 &key (start1 0) end1 (start2 0) end2)
+  "Given two strings, if the first string is lexicographically greater
+  than or equal to the second string, returns the longest common prefix
+  (using char-equal) of the two strings. Otherwise, returns ()."
+  (string-not-lessp* string1 string2 start1 end1 start2 end2))
+
+(defun string-not-greaterp (string1 string2 &key (start1 0) end1 (start2 0)
+				    end2)
+  "Given two strings, if the first string is lexicographically less than
+  or equal to the second string, returns the longest common prefix
+  (using char-equal) of the two strings. Otherwise, returns ()."
+  (string-not-greaterp* string1 string2 start1 end1 start2 end2))
+
+
+(defun make-string (count &key ((:initial-element fill-char)))
+  "Given a character count and an optional fill character, makes and returns
+   a new string Count long filled with the fill character."
+  (declare (fixnum count))
+  (if fill-char
+      (do ((i 0 (1+ i))
+	   (string (make-string count)))
+	  ((= i count) string)
+	(declare (fixnum i))
+	(setf (schar string i) fill-char))
+      (make-string count)))
+
+(defun string-upcase (string &key (start 0) end)
+  "Given a string, returns a new string that is a copy of it with
+  all lower case alphabetic characters converted to uppercase."
+  (declare (fixnum start))
+  (if (symbolp string) (setq string (symbol-name string)))
+  (let ((slen (length string))
+	(offset 0))
+    (declare (fixnum slen offset))
+    (with-one-string string start end offset
+      (let ((offset-slen (+ slen offset))
+	    (newstring (make-string slen)))
+	(declare (fixnum offset-slen))
+	(do ((index offset (1+ index))
+	     (new-index 0 (1+ new-index)))
+	    ((= index start))
+	  (declare (fixnum index new-index))
+	  (setf (schar newstring new-index) (schar string index)))
+	(do ((index start (1+ index))
+	     (new-index (- start offset) (1+ new-index)))
+	    ((= index (the fixnum end)))
+	  (declare (fixnum index new-index))
+	  (setf (schar newstring new-index)
+		(char-upcase (schar string index))))
+	(do ((index end (1+ index))
+	     (new-index (- (the fixnum end) offset) (1+ new-index)))
+	    ((= index offset-slen))
+	  (declare (fixnum index new-index))
+	  (setf (schar newstring new-index) (schar string index)))
+	newstring))))
+
+(defun string-downcase (string &key (start 0) end)
+  "Given a string, returns a new string that is a copy of it with
+  all upper case alphabetic characters converted to lowercase."
+  (declare (fixnum start))
+  (if (symbolp string) (setq string (symbol-name string)))
+  (let ((slen (length string))
+	(offset 0))
+    (declare (fixnum slen offset))
+    (with-one-string string start end offset
+      (let ((offset-slen (+ slen offset))
+	    (newstring (make-string slen)))
+	(declare (fixnum offset-slen))
+	(do ((index offset (1+ index))
+	     (new-index 0 (1+ new-index)))
+	    ((= index start))
+	  (declare (fixnum index new-index))
+	  (setf (schar newstring new-index) (schar string index)))
+	(do ((index start (1+ index))
+	     (new-index (- start offset) (1+ new-index)))
+	    ((= index (the fixnum end)))
+	  (declare (fixnum index new-index))
+	  (setf (schar newstring new-index)
+		(char-downcase (schar string index))))
+	(do ((index end (1+ index))
+	     (new-index (- (the fixnum end) offset) (1+ new-index)))
+	    ((= index offset-slen))
+	  (declare (fixnum index new-index))
+	  (setf (schar newstring new-index) (schar string index)))
+	newstring))))
+
+(defun string-capitalize (string &key (start 0) end)
+  "Given a string, returns a copy of the string with the first
+  character of each ``word'' converted to upper-case, and remaining
+  chars in the word converted to lower case. A ``word'' is defined
+  to be a string of case-modifiable characters delimited by
+  non-case-modifiable chars."
+  (declare (fixnum start))
+  (if (symbolp string) (setq string (symbol-name string)))
+  (let ((slen (length string))
+	(offset 0))
+    (declare (fixnum slen offset))
+    (with-one-string string start end offset
+      (let ((offset-slen (+ slen offset))
+	    (newstring (make-string slen)))
+	(declare (fixnum offset-slen))
+	(do ((index offset (1+ index))
+	     (new-index 0 (1+ new-index)))
+	    ((= index start))
+	  (declare (fixnum index new-index))
+	  (setf (schar newstring new-index) (schar string index)))
+	(do ((index start (1+ index))
+	     (new-index (- start offset) (1+ new-index))
+	     (newword t)
+	     (char ()))
+	    ((= index (the fixnum end)))
+	  (declare (fixnum index new-index))
+	  (setq char (schar string index))
+	  (cond ((not (alphanumericp char))
+		 (setq newword t))
+		(newword
+		 ;;char is first case-modifiable after non-case-modifiable
+		 (setq char (char-upcase char))
+		 (setq newword ()))
+		;;char is case-modifiable, but not first
+		(t (setq char (char-downcase char))))
+	  (setf (schar newstring new-index) char))
+	(do ((index end (1+ index))
+	     (new-index (- (the fixnum end) offset) (1+ new-index)))
+	    ((= index offset-slen))
+	  (declare (fixnum index new-index))
+	  (setf (schar newstring new-index) (schar string index)))
+	newstring))))
+
+(defun nstring-upcase (string &key (start 0) end)
+  "Given a string, returns that string with all lower case alphabetic
+  characters converted to uppercase."
+  (declare (fixnum start))
+  (let ((save-header string)
+	offset)
+    (with-one-string string start end offset
+      (do ((index start (1+ index)))
+	  ((= index (the fixnum end)))
+	(declare (fixnum index))
+	(setf (schar string index) (char-upcase (schar string index)))))
+    save-header))
+
+(defun nstring-downcase (string &key (start 0) end)
+  "Given a string, returns that string with all upper case alphabetic
+  characters converted to lowercase."
+  (declare (fixnum start))
+  (let ((save-header string)
+	offset)
+    (with-one-string string start end offset
+      (do ((index start (1+ index)))
+	  ((= index (the fixnum end)))
+	(declare (fixnum index))
+	(setf (schar string index) (char-downcase (schar string index)))))
+    save-header)))
+
+(defun nstring-capitalize (string &key (start 0) end)
+  "Given a string, returns that string with the first
+  character of each ``word'' converted to upper-case, and remaining
+  chars in the word converted to lower case. A ``word'' is defined
+  to be a string of case-modifiable characters delimited by
+  non-case-modifiable chars."
+  (declare (fixnum start))
+  (let ((save-header string)
+	offset)
+    (with-one-string string start end offset
+      (do ((index start (1+ index))
+	   (newword t)
+	   (char ()))
+	  ((= index (the fixnum end)))
+	(declare (fixnum index))
+	(setq char (schar string index))
+	(cond ((not (alphanumericp char))
+	       (setq newword t))
+	      (newword
+	       ;;char is first case-modifiable after non-case-modifiable
+	       (setf (schar string index) (char-upcase char))
+	       (setq newword ()))
+	      (t
+	       (setf (schar string index) (char-downcase char))))))
+    save-header))
+
+(defun string-left-trim (char-bag string)
+  "Given a set of characters (a list or string) and a string, returns
+  a copy of the string with the characters in the set removed from the
+  left end."
+  (with-string string
+    (do ((index start (1+ index)))
+	((or (= index (the fixnum end))
+	     (not (find (schar string index) char-bag)))
+	 (subseq (the simple-string string) index end))
+      (declare (fixnum index)))))
+
+(defun string-right-trim (char-bag string)
+  "Given a set of characters (a list or string) and a string, returns
+  a copy of the string with the characters in the set removed from the
+  right end."
+  (with-string string
+    (do ((index (1- (the fixnum end)) (1- index)))
+	((or (< index start) (not (find (schar string index) char-bag)))
+	 (subseq (the simple-string string) start (1+ index)))
+      (declare (fixnum index)))))
+
+(defun string-trim (char-bag string)
+  "Given a set of characters (a list or string) and a string, returns a
+  copy of the string with the characters in the set removed from both
+  ends."
+  (with-string string
+    (let* ((left-end (do ((index start (1+ index)))
+			 ((or (= index (the fixnum end))
+			      (not (find (schar string index) char-bag)))
+			  index)
+		       (declare (fixnum index))))
+	   (right-end (do ((index (1- (the fixnum end)) (1- index)))
+			  ((or (< index left-end)
+			       (not (find (schar string index) char-bag)))
+			   (1+ index))
+			(declare (fixnum index)))))
+      (subseq (the simple-string string) left-end right-end))))
diff --git a/code/struct.lisp b/code/struct.lisp
new file mode 100644
index 000000000..a8f362856
--- /dev/null
+++ b/code/struct.lisp
@@ -0,0 +1,156 @@
+;;; -*- Log: code.log; Package: Lisp -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;;    This file contains structure definitions that need to be compiled early
+;;; for bootstrapping reasons.
+;;;
+(in-package 'lisp)
+
+;;;; Defstruct structures:
+
+(in-package 'c)
+
+;;; Initialization hacks:
+
+#+new-compiler
+(progn
+;;; Make these types be sort-of-defined to allow bootstrapping.
+(setf (info type kind 'defstruct-description) :structure)
+(setf (info type kind 'defstruct-slot-description) :structure)
+
+
+;;; Define this now so that EQUAL works:
+;;;
+(defun pathnamep (x)
+  (and (structurep x)
+       (eq (%primitive header-ref x %g-vector-structure-name-slot)
+	   'pathname)))
+
+;;; Define so that we can test for VOLATILE-INFO-ENVs from the beginning of
+;;; initialization.
+;;;
+(defun c::volatile-info-env-p (x)
+  (and (structurep x)
+       (eq (%primitive header-ref x %g-vector-structure-name-slot)
+	   'c::volatile-info-env)))
+
+;;; Not really a structure, but at least a type-related initialization hack:
+;;;
+(deftype c::inlinep ()
+  '(member :inline :maybe-inline :notinline nil))
+;;;
+(deftype c::boolean ()
+  '(member t nil))
+
+); #+new-compiler
+
+
+(defstruct (defstruct-description
+             (:conc-name dd-)
+             (:print-function print-defstruct-description))
+  name				; name of the structure
+  doc				; documentation on the structure
+  slots				; list of slots
+  conc-name			; prefix for slot names
+  constructor			; name of standard constructor function
+  boa-constructors		; BOA constructors (cdr of option).
+  copier			; name of copying function
+  predicate			; name of type predictate
+  include			; name of included structure
+  (includes ())			; names of all structures included by this one
+  (included-by ())		; names of all strctures that include this one 
+  print-function		; function used to print it
+  type				; type specified, Structure if no type specified.
+  lisp-type			; actual type used for implementation.
+  named				; T if named, Nil otherwise
+  offset			; first slot's offset into implementation sequence
+  (length nil :type (or fixnum null))) ; total length of the thing
+
+
+(defstruct (defstruct-slot-description
+             (:conc-name dsd-)
+             (:print-function print-defstruct-slot-description))
+  %name				; string name of slot
+  (index nil :type fixnum)	; its position in the implementation sequence
+  accessor			; name of it accessor function
+  default			; default value
+  type				; declared type
+  read-only)			; T if there's to be no setter for it
+
+
+(in-package 'lisp)
+
+;;;; The stream structure:
+
+(defconstant in-buffer-length 100 "The size of a stream in-buffer.")
+
+(defstruct (stream (:predicate streamp) (:print-function %print-stream))
+  (in-buffer nil)				; Buffered input
+  (in-index in-buffer-length :type fixnum)	; Index into in-buffer
+  (in #'ill-in)					; Read-Char function
+  (bin #'ill-bin)				; Byte input function
+  (n-bin #'ill-bin)				; N-Byte input function
+  (out #'ill-out)				; Write-Char function
+  (bout #'ill-bout)				; Byte output function
+  (sout #'ill-out)				; String output function
+  (misc #'do-nothing))				; Less used methods
+
+
+;;;; Alien structures:
+ 
+(defstruct (alien-value
+	    (:constructor make-alien-value (sap offset size type))
+	    (:print-function %print-alien-value))
+  "This structure represents an Alien value."
+  sap
+  offset
+  size
+  type)
+
+(defstruct (ct-a-val
+	    (:print-function
+	     (lambda (s stream d)
+	       (declare (ignore s d))
+	       (write-string "#<Alien compiler info>" stream))))
+  type		; Type of expression, NIL if unknown.
+  size		; Expression for the size of the alien.
+  sap		; Expression for SAP.
+  offset	; Expression for bit offset.
+  alien)	; Expression for alien-value or NIL.
+
+
+(defstruct (alien-info
+	    (:print-function %print-alien-info)
+	    (:constructor
+	     make-alien-info (function num-args arg-types result-type)))
+  function	; The function the definition was made into.
+  num-args	; The total number of arguments.
+  arg-types	; Alist of arg numbers to types of Alien args.
+  result-type)	; The type of the resulting Alien.
+
+
+(defstruct (stack-info
+	    (:print-function
+	     (lambda (s stream d)
+	       (declare (ignore s d))
+	       (format stream "#<Alien stack info>"))))
+  type
+  size
+  head
+  current
+  grow)
+
+
+(defstruct enumeration-info
+  signed	; True if minimum value negative.
+  size		; Minimum number of bits needed to hold value.
+  from		; Symbol holding alist from keywords to integers.
+  to		; Symbol holding alist or vector from integers to keywords.
+  kind		; Kind of from mapping, :vector or :alist.
+  offset)	; Offset to add to value for :vector from mapping.
diff --git a/code/symbol.lisp b/code/symbol.lisp
new file mode 100644
index 000000000..50f0598a2
--- /dev/null
+++ b/code/symbol.lisp
@@ -0,0 +1,189 @@
+;;; -*- Log: code.log; Package: Lisp -*-
+;;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; Symbol manipulating functions for Spice Lisp.
+;;;
+;;; Written by Scott Fahlman.
+;;; Hacked on and maintained by Skef Wholey.
+;;;
+;;; Many of these are trivial interpreter entries to functions
+;;; open-coded by the compiler.
+;;;
+(in-package 'lisp)
+(export '(get remprop symbol-plist getf get-properties symbol-name
+	  make-symbol copy-symbol gensym gentemp *gensym-counter*
+	  symbol-package keywordp makunbound symbol-value symbol-function
+	  boundp set))
+
+(defun set (variable new-value)
+  "VARIABLE must evaluate to a symbol.  This symbol's special value cell is
+  set to the specified new value."
+  (set variable new-value))
+
+(defun makunbound (variable)
+  "VARIABLE must evaluate to a symbol.  This symbol is made unbound,
+  removing any value it may currently have."
+  (makunbound variable))
+
+(defun symbol-value (variable)
+  "VARIABLE must evaluate to a symbol.  This symbol's current special
+  value is returned."
+  (symbol-value variable))
+
+(defun symbol-function (variable)
+  "VARIABLE must evaluate to a symbol.  This symbol's current definition
+  is returned."
+  (symbol-function variable))
+
+(defun %sp-set-definition (symbol new-value)
+  (setf (symbol-function symbol) new-value))
+
+(defun boundp (variable)
+  "VARIABLE must evaluate to a symbol.  Return () if this symbol is
+  unbound, T if it has a value."
+  (boundp variable))
+
+(defun symbol-plist (variable)
+  "VARIABLE must evaluate to a symbol.  Return its property list."
+  (symbol-plist variable))
+
+(defun %sp-set-plist (symbol new-value)
+  (setf (symbol-plist symbol) new-value))
+
+(defun symbol-name (variable)
+  "VARIABLE must evaluate to a symbol.  Return its print name."
+  (symbol-name variable))
+
+(defun symbol-package (variable)
+  "VARIABLE must evaluate to a symbol.  Return its package."
+  (symbol-package variable))
+
+(defun make-symbol (string)
+  "Make and return a new symbol with the STRING as its print name."
+  (make-symbol string))
+
+(defun get (symbol indicator &optional (default nil))
+  "Look on the property list of SYMBOL for the specified INDICATOR.  If this
+  is found, return the associated value, else return DEFAULT."
+  (do ((pl (symbol-plist symbol) (cddr pl)))
+      ((atom pl) default)
+    (cond ((atom (cdr pl))
+	   (error "~S has an odd number of items in its property list."
+		   symbol))
+	  ((eq (car pl) indicator)
+	   (return (cadr pl))))))
+
+(defun %put (symbol indicator value)
+  "The VALUE is added as a property of SYMBOL under the specified INDICATOR.
+  Returns VALUE."
+  (%primitive put symbol indicator value)
+#|  (do ((pl (symbol-plist symbol) (cddr pl)))
+      ((atom pl)
+       (setf (symbol-plist symbol)
+	     (list* indicator value (symbol-plist symbol)))
+       value)
+    (cond ((atom (cdr pl))
+	   (error "~S has an odd number of items in its property list."
+		  symbol))
+	  ((eq (car pl) indicator)
+	   (rplaca (cdr pl) value)
+	   (return value))))|#
+  )
+
+(defun remprop (symbol indicator)
+  "Look on property list of SYMBOL for property with specified
+  INDICATOR.  If found, splice this indicator and its value out of
+  the plist, and return the tail of the original list starting with
+  INDICATOR.  If not found, return () with no side effects."
+  (do ((pl (symbol-plist symbol) (cddr pl))
+       (prev nil pl))
+      ((atom pl) nil)
+    (cond ((atom (cdr pl))
+	   (error "~S has an odd number of items in its property list."
+		  symbol))
+	  ((eq (car pl) indicator)
+	   (cond (prev (rplacd (cdr prev) (cddr pl)))
+		 (t
+		  (setf (symbol-plist symbol) (cddr pl))))
+	   (return pl)))))
+
+(defun getf (place indicator &optional (default ()))
+  "Searches the property list stored in Place for an indicator EQ to Indicator.
+  If one is found, the corresponding value is returned, else the Default is
+  returned."
+  (do ((plist place (cddr plist)))
+      ((null plist) default)
+    (cond ((atom (cdr plist))
+	   (error "~S is a malformed property list."
+		  place))
+	  ((eq (car plist) indicator)
+	   (return (cadr plist))))))
+
+
+(defun get-properties (place indicator-list)
+  "Like GETF, except that Indicator-List is a list of indicators which will
+  be looked for in the property list stored in Place.  Three values are
+  returned, see manual for details."
+  (do ((plist place (cddr plist)))
+      ((null plist) (values nil nil nil))
+    (cond ((atom (cdr plist))
+	   (error "~S is a malformed proprty list."
+		  place))
+	  ((memq (car plist) indicator-list)
+	   (return (values (car plist) (cadr plist) plist))))))
+
+(defun copy-symbol (symbol &optional (copy-props nil) &aux new-symbol)
+  "Make and return a new uninterned symbol with the same print name
+  as SYMBOL.  If COPY-PROPS is null, the new symbol has no properties.
+  Else, it has a copy of SYMBOL's property list."
+  (setq new-symbol (make-symbol (symbol-name symbol)))
+  (if copy-props
+      (setf (symbol-plist new-symbol) (copy-list (symbol-plist symbol))))
+  new-symbol)
+
+(proclaim '(special *keyword-package*))
+
+(defun keywordp (object)
+  "Returns true if Object is a symbol in the keyword package."
+  (and (symbolp object)
+       (eq (symbol-package object) *keyword-package*)))
+
+
+;;;; Gensym and friends.
+
+(defvar *gensym-counter* 0
+  "Counter for generating unique GENSYM symbols.")
+
+(defun gensym (&optional string)
+  "Creates a new uninterned symbol whose name is a prefix string (defaults
+  to \"G\"), followed by a decimal number.  String, when supplied, will
+  alter the prefix if it is a string, or the decimal number if it is a
+  number, of this symbol.  The number, defaultly *gensym-counter*, is
+  incremented by each call to GENSYM."
+  (let* ((*print-base* 10)
+	 (*print-radix* nil)
+	 (*print-pretty* nil)
+	 (prefix (if (stringp string) string "G"))
+	 (number (prin1-to-string (if (numberp string)
+				      string
+				      (incf *gensym-counter*)))))
+    (make-symbol (concatenate 'simple-string prefix number))))
+
+(defun gentemp (&optional (prefix t) (package *package*))
+  "Creates a new symbol interned in package Package with the given Prefix."
+  (loop
+    (let ((*print-base* 10)
+	  (*print-radix* nil)
+	  (*print-pretty* nil)
+	  (new-pname (format nil "~A~D"
+			     (string prefix) (incf *gensym-counter*))))
+      (multiple-value-bind (symbol existsp)
+			   (find-symbol new-pname package)
+	(declare (ignore symbol))
+	(unless existsp (return (values (intern new-pname package))))))))
diff --git a/code/sysmacs.lisp b/code/sysmacs.lisp
new file mode 100644
index 000000000..95693b1a2
--- /dev/null
+++ b/code/sysmacs.lisp
@@ -0,0 +1,274 @@
+;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;;    Miscellaneous system hacking macros.
+;;;
+(in-package "LISP" :use '("SYSTEM" "DEBUG"))
+
+#-new-compiler
+(eval-when (compile)
+  (setq lisp::*bootstrap-defmacro* t))
+
+;;; WITH-ARRAY-DATA follows an arbitrarily long chain of displaced arrays
+;;; binding data-var to the data vector, offset-var to the cumulative
+;;; displacement offset, start-var to the actual start index in the data
+;;; vector, and end-var to the actual end of the data vector.  Put all the
+;;; bindings in the LET, so declarations can be made on the variables (for
+;;; example, declaring data-var to be a simple-string.
+(defmacro with-array-data (((data-var array &key (offset-var (gensym)))
+			    (start-var &optional (svalue 0))
+			    (end-var &optional (evalue nil)))
+			   &rest forms)
+  "Bind data-var to the data-vector eventually reached by following displacement
+   links from array, offset-var to a cumulative offset, start-var to the first
+   index in the data vector, and end-var to the total length of the array plus
+   the cumulative offset.  Offset-var, start-var, and end-var are declared to be
+   fixnums."
+  `(multiple-value-bind (,data-var ,offset-var)
+			(find-data-vector ,array)
+     (let* ((,data-var ,data-var)
+	    (,offset-var ,offset-var)
+	    (,start-var (+ ,svalue ,offset-var))
+	    (,end-var (+ ,offset-var (or ,evalue (array-total-size ,array)))))
+       (declare (fixnum ,offset-var ,start-var ,end-var))
+       ,@forms)))
+
+
+(defmacro %displacedp (array-header)
+  `(= (the fixnum (%primitive get-vector-subtype ,array-header))
+      (the fixnum %array-displaced-subtype)))
+
+(defmacro %set-array-displacedp (array-header value)
+  `(%primitive set-vector-subtype ,array-header
+	       (if ,value %array-displaced-subtype %array-normal-subtype)))
+
+
+(defmacro without-gcing (&rest body)
+  "Executes the forms in the body without doing a garbage collection."
+  `(multiple-value-prog1
+       (let ((*gc-inhibit* t))
+	 ,@body)
+     (when (and *need-to-collect-garbage* (not *gc-inhibit*))
+       (maybe-gc nil))))
+
+
+(defmacro with-interrupts (&body body)
+  `(let ((iin %sp-interrupts-inhibited))
+     (setq %sp-interrupts-inhibited NIL)
+     (when (consp iin)
+       (dolist (x iin)
+	 (let ((f (svref *software-interrupt-vector* (car x))))
+	   (when f (apply f x)))))
+     (unwind-protect
+	 (progn ,@body)
+       (if iin (setq %sp-interrupts-inhibited T)))))
+
+(defmacro without-interrupts (&rest body)
+  "Evaluates the forms in the Body without allowing interrupts."
+  `(let* ((old-interrupts-inhibited %sp-interrupts-inhibited)
+	  (%sp-interrupts-inhibited (or %sp-interrupts-inhibited T)))
+     (multiple-value-prog1
+       (progn ,@body)
+       (when (and (null old-interrupts-inhibited)
+		  (consp %sp-interrupts-inhibited))
+	 (dolist (x %sp-interrupts-inhibited)
+	   (let ((f (svref *software-interrupt-vector* (car x))))
+	     (when f (apply f x))))))))
+
+
+(defmacro with-enabled-interrupts (interrupt-list &body body)
+  "With-enabled-interrupts ({(interrupt function [character])}*) {form}*
+  Establish function as a handler for the Unix signal interrupt which
+  should be a number between 1 and 31 inclusive.  For the signals that
+  can be generated from the keyboard, the optional character specifies
+  the character to use to generate the signal."
+  (let ((il (gensym))
+	(fn (gensym))
+	(ch (gensym))
+	(it (gensym)))
+    `(let ((,il NIL))
+       (unwind-protect
+	   (progn
+	     ,@(do* ((item interrupt-list (cdr item))
+		     (intr (caar item) (caar item))
+		     (ifcn (cadar item) (cadar item))
+		     (ichr (caddar item) (caddar item))
+		     (forms NIL))
+		    ((null item) (nreverse forms))
+		 (if (symbolp intr)
+		     (setq intr (symbol-value intr)))
+		 (push `(multiple-value-bind (,fn ,ch)
+					     (enable-interrupt ,intr ,ifcn
+							       ,ichr)
+			  (push `(,,intr ,,fn ,,ch) ,il)) forms))
+	     ,@body)
+	 (dolist (,it (nreverse ,il))
+	   (funcall #'enable-interrupt (car ,it) (cadr ,it) (caddr ,it)))))))
+
+
+(defvar hi::*in-the-editor* nil)
+
+(defmacro without-hemlock (&body body)
+  `(progn
+     (when (and hi::*in-the-editor* (null debug::*in-the-debugger*))
+       (let ((device (hi::device-hunk-device
+		      (hi::window-hunk (hi::current-window)))))
+	 (funcall (hi::device-exit device) device)))
+     ,@body
+     (when (and hi::*in-the-editor* (null debug::*in-the-debugger*))
+       (let ((device (hi::device-hunk-device
+		      (hi::window-hunk (hi::current-window)))))
+	 (funcall (hi::device-init device) device)))))
+
+
+;;; With-Reply-Port  --  Public    
+;;;
+;;;    If we find that the number of ports in use (as indicated by
+;;; *reply-port-pointer*) disagrees with our dynamic depth in
+;;; With-Reply-Port forms (as indicated by *reply-port-depth*),
+;;; then we must have been unwound at some point in the past.
+;;; We reallocate the ports that were in use when we were
+;;; unwound, since they may have random messages hanging on them.
+;;;
+(defmacro with-reply-port ((var) &body body)
+  "With-Reply-Port (Var) {Form}*
+  Binds Var to a port during the evaluation of the Forms."
+  (let ((index (gensym))
+	(old-flag (gensym))
+	(res (gensym)))
+    `(let ((,old-flag %sp-interrupts-inhibited)
+	   ,res)
+       (without-interrupts
+	(let* ((,index *reply-port-depth*)
+	       (*reply-port-depth* (1+ ,index))
+	       ,var)
+	  (unless (eql ,index *reply-port-pointer*)
+	    (reallocate-reply-ports ,index))
+	  (setq ,var (svref *reply-port-stack* ,index))
+	  (setq *reply-port-pointer* (1+ ,index))
+	  (unless ,var (setq ,var (allocate-new-reply-ports)))
+	  (setq %sp-interrupts-inhibited ,old-flag)
+	  (setq ,res (multiple-value-list (progn ,@body)))
+	  (when (eql (car ,res) mach:rcv-timed-out)
+	    (gr-call mach:port_deallocate *task-self* ,var)
+	    (setf (svref *reply-port-stack* ,index)
+		  (gr-call* mach:port_allocate *task-self*)))
+	  (setq %sp-interrupts-inhibited (or ,old-flag T))
+	  (if (eql ,index (1- *reply-port-pointer*))
+	      (setq *reply-port-pointer* ,index)
+	      (reallocate-reply-ports (1+ ,index)))
+	  (values-list ,res))))))
+
+
+;;; Eof-Or-Lose is a useful macro that handles EOF.
+
+(defmacro eof-or-lose (stream eof-errorp eof-value)
+  `(if ,eof-errorp
+       (error "~S: Stream hit EOF unexpectedly." ,stream)
+       ,eof-value))
+
+;;; These macros handle the special cases of t and nil for input and
+;;; output streams.
+;;;
+(defmacro in-synonym-of (stream)
+  (let ((svar (gensym)))
+    `(let ((,svar ,stream))
+       (cond ((null ,svar) *standard-input*)
+	     ((eq ,svar t) *terminal-io*)
+	     (t (check-type ,svar stream)
+		,svar)))))
+
+(defmacro out-synonym-of (stream)
+  (let ((svar (gensym)))
+    `(let ((,svar ,stream))
+       (cond ((null ,svar) *standard-output*)
+	     ((eq ,svar t) *terminal-io*)
+	     (T (check-type ,svar stream)
+		,svar)))))
+
+;;; With-Mumble-Stream calls the function in the given Slot of the Stream with
+;;; the Args.
+;;;
+(defmacro with-in-stream (stream slot &rest args)
+  `(let ((stream (in-synonym-of ,stream)))
+     (funcall (,slot stream) stream ,@args)))
+
+(defmacro with-out-stream (stream slot &rest args)
+  `(let ((stream (out-synonym-of ,stream)))
+     (funcall (,slot stream) stream ,@args)))
+
+
+;;;; These are hacks to make the reader win.
+
+;;; Prepare-For-Fast-Read-Char  --  Internal
+;;;
+;;;    This macro sets up some local vars for use by the Fast-Read-Char
+;;; macro within the enclosed lexical scope.
+;;;
+(defmacro prepare-for-fast-read-char (stream &body forms)
+  `(let* ((%frc-stream% (in-synonym-of ,stream))
+	  (%frc-method% (stream-in %frc-stream%))
+	  (%frc-buffer% (stream-in-buffer %frc-stream%))
+	  (%frc-index% (stream-in-index %frc-stream%)))
+     (declare (type (or simple-string null) %frc-buffer%) (fixnum %frc-index%))
+     ,@forms))
+
+;;; Done-With-Fast-Read-Char  --  Internal
+;;;
+;;;    This macro must be called after one is done with fast-read-char
+;;; inside it's scope to decache the stream-in-index.
+;;;
+(defmacro done-with-fast-read-char ()
+  `(setf (stream-in-index %frc-stream%) %frc-index%))
+
+;;; Fast-Read-Char  --  Internal
+;;;
+;;;    This macro can be used instead of Read-Char within the scope of
+;;; a Prepare-For-Fast-Read-Char.
+;;;
+(defmacro fast-read-char (&optional (eof-errorp t) (eof-value ()))
+  `(cond
+    ((= %frc-index% in-buffer-length)
+     (setf (stream-in-index %frc-stream%) %frc-index%)
+     (prog1 (funcall %frc-method% %frc-stream% ,eof-errorp ,eof-value)
+	    (setq %frc-index% (stream-in-index %frc-stream%))))
+    (t
+     (prog1 (aref %frc-buffer% %frc-index%)
+	    (incf %frc-index%)))))
+
+;;;; And these for the fasloader...
+
+;;; Prepare-For-Fast-Read-Byte  --  Internal
+;;;
+;;;    Just like Prepare-For-Fast-Read-Char except that we get the Bin
+;;; method.
+;;;
+(defmacro prepare-for-fast-read-byte (stream &body forms)
+  `(let* ((%frc-stream% (in-synonym-of ,stream))
+	  (%frc-method% (stream-bin %frc-stream%))
+	  (%frc-buffer% (stream-in-buffer %frc-stream%))
+	  (%frc-index% (stream-in-index %frc-stream%)))
+     (declare (type (or simple-array null) %frc-buffer%) (fixnum %frc-index%))
+     ,@forms))
+
+;;; Fast-Read-Byte, Done-With-Fast-Read-Byte  --  Internal
+;;;
+;;;    Identical to the text versions, but we get some gratuitous
+;;; psuedo-generality by having different names.
+;;;
+(defmacro done-with-fast-read-byte ()
+  `(done-with-fast-read-char))
+;;;
+(defmacro fast-read-byte (&rest stuff)
+  `(fast-read-char ,@stuff))
+
+
+#-new-compiler
+(eval-when (compile)
+  (setq lisp::*bootstrap-defmacro* nil))
diff --git a/code/time.lisp b/code/time.lisp
new file mode 100644
index 000000000..9f98887f1
--- /dev/null
+++ b/code/time.lisp
@@ -0,0 +1,404 @@
+;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;;    This file contains the definitions for the Spice Lisp time functions.
+;;; They are mostly fairly straightforwardly implemented as calls to the 
+;;; time server.
+;;;
+;;;    Written by Rob MacLachlan.
+;;;
+(in-package 'lisp)
+(export '(internal-time-units-per-second get-internal-real-time
+	  get-internal-run-time get-universal-time
+	  get-decoded-time encode-universal-time decode-universal-time))
+
+(defconstant internal-time-units-per-second 100
+  "The number of internal time units that fit into a second.  See
+  Get-Internal-Real-Time and Get-Internal-Run-Time.")
+
+(defmacro not-leap-year (year)
+  (let ((sym (gensym)))
+    `(let ((,sym ,year))
+       (cond ((eq (mod ,sym 4) 0)
+	      (and (eq (mod ,sym 100) 0)
+		   (not (eq (mod ,sym 400) 0))))
+	     (T T)))))
+
+;;; Get-Internal-Real-Time  --  Public
+;;;
+;;;
+(defun get-internal-real-time ()
+  "Return the real time in the internal time format.  This is useful for
+  finding elapsed time.  See Internal-Time-Units-Per-Second."
+  (let ((val (system:%primitive get-real-time)))
+    (when (eq val -1)
+      (error "Failed to get real time."))
+    val))
+
+#|
+(defun get-internal-real-time ()
+  "Return the real time in the internal time format.  This is useful for
+  finding elapsed time.  See Internal-Time-Units-Per-Second."
+  (multiple-value-bind (result seconds useconds) (mach:unix-gettimeofday)
+    (if result (+ (* seconds internal-time-units-per-second) useconds)
+	(error "Unix system call gettimeofday failed: ~A"
+	       (mach:get-unix-error-msg seconds)))))
+|#
+
+;;; Get-Internal-Run-Time  --  Public
+;;;
+;;; PmGetTimes returns run time in microseconds.  Convert to jiffies.
+;;;
+(defun get-internal-run-time ()
+  "Return the run time in the internal time format.  This is useful for
+  finding CPU usage."
+  (let ((val (system:%primitive get-run-time)))
+    (when (eq val -1)
+      (error "Failed to obtain run time."))
+    val))
+
+#|
+(defun get-internal-run-time ()
+  "Return the run time in the internal time format.  This is useful for
+  finding CPU usage."
+  (multiple-value-bind (result utime stime)
+		       (mach:unix-getrusage mach:rusage_self)
+    (if result (+ utime stime)
+	(error "Unix system call getrusage failed: ~A"
+	       (mach:get-unix-error-msg utime)))))
+|#
+
+;;; Subtract from the returned Internal_Time to get the universal time.
+;;; The offset between our time base and the Perq one is 2145 weeks and
+;;; five days.
+;;;
+(defconstant seconds-in-week (* 60 60 24 7))
+(defconstant weeks-offset 2145)
+(defconstant seconds-offset 432000)
+(defconstant minutes-per-day (* 24 60))
+(defconstant quarter-days-per-year (1+ (* 365 4)))
+(defconstant quarter-days-per-century 146097)
+(defconstant november-17-1858 678882)
+(defconstant weekday-november-17-1858 2)
+(defconstant unix-to-universal-time 2208988800)
+
+;;; Make-Universal-Time  --  Internal
+;;;
+;;;    Convert a Unix Internal_Time into a universal time.
+;;;
+(defun make-universal-time (weeks msec)
+  (+ (* (- weeks weeks-offset) seconds-in-week)
+     (- (truncate msec 1000) seconds-offset)))
+
+;;; Get-Universal-Time  --  Public
+;;;
+;;;
+(defun get-universal-time ()
+  "Returns a single integer for the current time of
+   day in universal time format."
+  (multiple-value-bind (res secs) (mach:unix-gettimeofday)
+    (declare (ignore res))
+    (+ secs unix-to-universal-time)))
+
+;;; Get-Decoded-Time  --  Public
+;;;
+;;;
+
+(defun get-decoded-time ()
+  "Returns nine values specifying the current time as follows:
+  second, minute, hour, date, month, year, day of week (0 = Monday),
+  T (daylight savings times) or NIL (standard time), and timezone."
+  (decode-universal-time (get-universal-time)))
+
+;;; Decode-Universal-Time  --  Public
+;;;
+;;;
+
+(defun decode-universal-time (universal-time &optional time-zone)
+  "Converts a universal-time to decoded time format returning
+  the following nine values: second, minute, hour, date, month,
+  year, day of week (0 = Monday), T (daylight savings time) or
+  NIL (standard time), and timezone."
+  (declare (type (or fixnum null) time-zone))
+  (multiple-value-bind (weeks secs)
+		       (truncate (+ universal-time seconds-offset)
+				 seconds-in-week)
+    (let ((weeks (+ weeks weeks-offset))
+	  (second NIL)
+	  (minute NIL)
+	  (hour NIL)
+	  (date NIL)
+	  (month NIL)
+	  (year NIL)
+	  (day NIL)
+	  (daylight NIL)
+	  (timezone (if (null time-zone)
+			(multiple-value-bind (res s us tz)
+					     (mach:unix-gettimeofday)
+			  (declare (ignore s us))
+			  (if res tz 0))
+			(* time-zone 60))))
+      (declare (fixnum timezone))
+      (multiple-value-bind (t1 seconds) (truncate secs 60)
+	(setq second seconds)
+	(setq t1 (- t1 timezone))
+	(let* ((tday (if (< t1 0)
+			 (1- (truncate (1+ t1) minutes-per-day))
+			 (truncate t1 minutes-per-day))))
+	  (multiple-value-setq (hour minute)
+	    (truncate (- t1 (* tday minutes-per-day)) 60))
+	  (let* ((t2 (1- (* (+ (* weeks 7) tday november-17-1858) 4)))
+		 (tcent (truncate t2 quarter-days-per-century)))
+	    (setq t2 (mod t2 quarter-days-per-century))
+	    (setq t2 (+ (- t2 (mod t2 4)) 3))
+	    (setq year (+ (* tcent 100) (truncate t2 quarter-days-per-year)))
+	    (let ((days-since-mar0 (1+ (truncate (mod t2 quarter-days-per-year)
+						 4))))
+	      (setq day (mod (+ tday weekday-november-17-1858) 7))
+	      (if (setq daylight (dst-check days-since-mar0 hour day))
+		  (cond ((eq hour 23)
+			 (setq hour 0)
+			 (setq day (mod (1+ day) 7))
+			 (setq days-since-mar0 (1+ days-since-mar0))
+			 (if (>= days-since-mar0 366)
+			     (if (or (> days-since-mar0 366)
+				     (not-leap-year (1+ year)))
+				 (setq days-since-mar0 368))))
+			(T (setq hour (1+ hour)))))
+	      (let ((t3 (+ (* days-since-mar0 5) 456)))
+		(cond ((>= t3 1989)
+		       (setq t3 (- t3 1836))
+		       (setq year (1+ year))))
+		(multiple-value-setq (month t3) (truncate t3 153))
+		(setq date (1+ (truncate t3 5))))))))
+      (values second minute hour date month year day
+	      daylight (truncate timezone 60)))))
+
+;;; Encode-Universal-Time  --  Public
+;;;
+;;;    Just do a TimeUser:T_UserToInt.  If the year is between 0 and 99 we 
+;;; have to figure out which the "obvious" year is.
+;;;
+
+(defun encode-universal-time (second minute hour date month year
+				     &optional time-zone)
+  "The time values specified in decoded format are converted to 
+   universal time, which is returned."
+  (let* ((year (if (< year 100)
+		   (multiple-value-bind (sec min hour day month now-year)
+					(get-decoded-time)
+		     (declare (ignore sec min hour day month))
+		     (do ((y (+ year (* 100 (1- (truncate now-year 100))))
+			     (+ y 100)))
+			 ((<= (abs (- y now-year)) 50) y)))
+		   year))
+	 (zone (if time-zone (* time-zone 60)
+		   (multiple-value-bind (res s us tz) (mach:unix-gettimeofday)
+		     (declare (ignore s us))
+		     (if res tz))))
+	 (tmonth (- month 3)))
+    (cond ((< tmonth 0)
+	   (setq tmonth (+ tmonth 12))
+	   (setq year (1- year))))
+    (let ((days-since-mar0 (+ (truncate (+ (* tmonth 153) 2) 5) date)))
+      (multiple-value-bind (tcent tyear) (truncate year 100)
+	(let* ((tday (- (+ (truncate (* tcent quarter-days-per-century) 4)
+			   (truncate (* tyear quarter-days-per-year) 4)
+			   days-since-mar0)
+			november-17-1858))
+	       (daylight (dst-check days-since-mar0 (1- hour)
+				    (mod (+ tday weekday-november-17-1858) 7)))
+	       (tminutes (+ (* hour 60) minute zone)))
+	  (if daylight (setq tminutes (- tminutes 60)))
+	  (do ((i tminutes (+ i minutes-per-day)))
+	      ((>= i 0) (setq tminutes i))
+	    (declare (fixnum i))
+	    (decf tday 1))
+	  (do ((i tminutes (- i minutes-per-day)))
+	      ((< i minutes-per-day) (setq tminutes i))
+	    (declare (fixnum i))
+	    (incf tday 1))
+	  (multiple-value-bind (weeks dpart) (truncate tday 7)
+	    (make-universal-time weeks (* (+ (* (+ (* dpart minutes-per-day)
+						   tminutes) 60)
+					     second) 1000))))))))
+
+;;; Dst-check -- Internal
+(defconstant april-1 (+ (truncate (+ (* (- 4 3) 153) 2) 5) 1))
+(defconstant october-31 (+ (truncate (+ (* (- 10 3) 153) 2) 5) 31))
+
+(eval-when (compile eval)
+  
+  (defmacro dst-check-start-of-month-ge (day hour weekday daybound)
+    (let ((d (gensym))
+	  (h (gensym))
+	  (w (gensym))
+	  (db (gensym)))
+      `(let ((,d ,day)
+	     (,h ,hour)
+	     (,w ,weekday)
+	     (,db ,daybound))
+	 (declare (fixnum ,d ,h ,w ,db))
+	 (cond ((< ,d ,db) NIL)
+	       ((> (the fixnum (- ,d ,w)) ,db) T)
+	       ((and (eq ,w 6) (> ,h 0)) T)
+	       (T NIL)))))
+  
+  (defmacro dst-check-end-of-month-ge (day hour weekday daybound)
+    (let ((d (gensym))
+	  (h (gensym))
+	  (w (gensym))
+	  (db (gensym)))
+      `(let ((,d ,day)
+	     (,h ,hour)
+	     (,w ,weekday)
+	     (,db ,daybound))
+	 (declare (fixnum ,d ,h ,w ,db))
+	 (cond ((< (the fixnum (+ ,d 6)) ,db) NIL)
+	       ((> (the fixnum  (- (the fixnum (+ ,d 6)) ,w)) ,db) T)
+	       ((and (eq ,w 6) (> ,h 0)) T)
+	       (T NIL)))))
+  )
+
+(defun dst-check (day hour weekday)
+  (and (dst-check-start-of-month-ge day hour weekday april-1)
+       (not (dst-check-end-of-month-ge day hour weekday october-31))))
+
+(defmacro time (form)
+  "Evaluates the Form and prints timing information on *Trace-Output*."
+  (let ((old-run-utime (gensym))
+	(new-run-utime (gensym))
+	(old-run-stime (gensym))
+	(new-run-stime (gensym))
+	(old-real-time (gensym))
+	(new-real-time (gensym))
+	(old-page-faults (gensym))
+	(new-page-faults (gensym))
+	(real-time-overhead (gensym))
+	(run-utime-overhead (gensym))
+	(run-stime-overhead (gensym))
+	(page-faults-overhead (gensym))
+	(old-bytes-consed (gensym))
+	(new-bytes-consed (gensym))
+	(cons-overhead (gensym))
+	(err? (gensym))
+	(utime (gensym))
+	(stime (gensym)))
+    `(let (,old-run-utime
+	   ,new-run-utime
+	   ,old-run-stime
+	   ,new-run-stime
+	   ,old-real-time
+	   ,new-real-time
+	   ,old-page-faults
+	   ,new-page-faults
+	   ,real-time-overhead
+	   ,run-utime-overhead
+	   ,run-stime-overhead
+	   ,page-faults-overhead
+	   ,old-bytes-consed
+	   ,new-bytes-consed
+	   ,cons-overhead)
+       ;; Calculate the overhead...
+       (multiple-value-bind (,err? ,utime ,stime)
+			    (mach:unix-getrusage mach:rusage_self)
+	 (cond ((null ,err?)
+		(error "Unix system call getrusage failed: ~A."
+		       (mach:get-unix-error-msg ,utime)))
+	       (T (setq ,old-run-utime ,utime)
+		  (setq ,old-run-stime ,stime))))
+       (multiple-value-bind (gr ps fc ac ic wc zf ra in ot pf)
+			    (mach:vm_statistics *task-self*)
+	 (declare (ignore ps fc ac ic wc zf ra in ot))
+	 (gr-error 'mach:vm_allocate gr)
+	 (setq ,old-page-faults pf))
+       (setq ,old-bytes-consed (get-bytes-consed))
+       ;; Do it a second time, to make sure everything is faulted in.
+       (multiple-value-bind (,err? ,utime ,stime)
+			    (mach:unix-getrusage mach:rusage_self)
+	 (cond ((null ,err?)
+		(error "Unix system call getrusage failed: ~A."
+		       (mach:get-unix-error-msg ,utime)))
+	       (T (setq ,old-run-utime ,utime)
+		  (setq ,old-run-stime ,stime))))
+       (multiple-value-bind (gr ps fc ac ic wc zf ra in ot pf)
+			    (mach:vm_statistics *task-self*)
+	 (declare (ignore ps fc ac ic wc zf ra in ot))
+	 (gr-error 'mach:vm_statistics gr)
+	 (setq ,old-page-faults pf))
+       (setq ,old-bytes-consed (get-bytes-consed))
+
+       (multiple-value-bind (,err? ,utime ,stime)
+			    (mach:unix-getrusage mach:rusage_self)
+	 (cond ((null ,err?)
+		(error "Unix system call getrusage failed: ~A."
+		       (mach:get-unix-error-msg ,utime)))
+	       (T (setq ,new-run-utime ,utime)
+		  (setq ,new-run-stime ,stime))))
+       (multiple-value-bind (gr ps fc ac ic wc zf ra in ot pf)
+			    (mach:vm_statistics *task-self*)
+	 (declare (ignore ps fc ac ic wc zf ra in ot))
+	 (gr-error 'mach:vm_statistics gr)
+	 (setq ,new-page-faults pf))
+       (setq ,new-bytes-consed (get-bytes-consed))
+
+       (setq ,run-utime-overhead (- ,new-run-utime ,old-run-utime))
+       (setq ,run-stime-overhead (- ,new-run-stime ,old-run-stime))
+       (setq ,page-faults-overhead (- ,new-page-faults ,old-page-faults))
+       (setq ,old-real-time (get-internal-real-time))
+       (setq ,old-real-time (get-internal-real-time))
+       (setq ,new-real-time (get-internal-real-time))
+       (setq ,real-time-overhead (- ,new-real-time ,old-real-time))
+       (setq ,cons-overhead (- ,new-bytes-consed ,old-bytes-consed))
+       ;; Now get the initial times.
+       (multiple-value-bind (,err? ,utime ,stime)
+			    (mach:unix-getrusage mach:rusage_self)
+	 (cond ((null ,err?)
+		(error "Unix system call getrusage failed: ~A."
+		       (mach:get-unix-error-msg ,utime)))
+	       (T (setq ,old-run-utime ,utime)
+		  (setq ,old-run-stime ,stime))))
+       (multiple-value-bind (gr ps fc ac ic wc zf ra in ot pf)
+			    (mach:vm_statistics *task-self*)
+	 (declare (ignore ps fc ac ic wc zf ra in ot))
+	 (gr-error 'mach:vm_statistics gr)
+	 (setq ,old-page-faults pf))
+       (setq ,old-real-time (get-internal-real-time))
+       (setq ,old-bytes-consed (get-bytes-consed))
+       (multiple-value-prog1
+	;; Execute the form, and return its values.
+	   ,form
+	 (multiple-value-bind (,err? ,utime ,stime)
+			      (mach:unix-getrusage mach:rusage_self)
+	   (cond ((null ,err?)
+		  (error "Unix system call getrusage failed: ~A."
+			 (mach:get-unix-error-msg ,utime)))
+		 (T (setq ,new-run-utime (- ,utime ,run-utime-overhead))
+		    (setq ,new-run-stime (- ,stime ,run-stime-overhead)))))
+	 (multiple-value-bind (gr ps fc ac ic wc zf ra in ot pf)
+			      (mach:vm_statistics *task-self*)
+	   (declare (ignore ps fc ac ic wc zf ra in ot))
+	   (gr-error 'mach:vm_statistics gr)
+	   (setq ,new-page-faults (- pf ,page-faults-overhead)))
+	 (setq ,new-real-time (- (get-internal-real-time) ,real-time-overhead))
+	 (setq ,new-bytes-consed (- (get-bytes-consed) ,cons-overhead))
+	 (format *trace-output*
+		 "~&Evaluation took:~%  ~
+		 ~S second~:P of real time,~%  ~
+		 ~S second~:P of user run time,~%  ~
+		 ~S second~:P of system run time,~%  ~
+		 ~S page fault~:P, and~%  ~
+		 ~S bytes consed.~%"
+		 (max (/ (- ,new-real-time ,old-real-time)
+			 (float internal-time-units-per-second))
+		      0.0)
+		 (max (/ (- ,new-run-utime ,old-run-utime) 1000000.0) 0.0)
+		 (max (/ (- ,new-run-stime ,old-run-stime) 1000000.0) 0.0)
+		 (max (- ,new-page-faults ,old-page-faults) 0)
+		 (max (- ,new-bytes-consed ,old-bytes-consed) 0))))))
diff --git a/code/tty-inspect.lisp b/code/tty-inspect.lisp
new file mode 100644
index 000000000..ceb7abb23
--- /dev/null
+++ b/code/tty-inspect.lisp
@@ -0,0 +1,195 @@
+;;; -*- Log: code.log; Package: inspect -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; Tty interface for INSPECT.
+;;;
+;;; Written by Blaine Burks
+
+(in-package "INSPECT")
+
+;;; The tty inspector views LISP objects as being composed of parts.  A list,
+;;; for example, would be divided into it's members, and a structure into its
+;;; slots.  These parts are stored in a list.  The first two elements of this
+;;; list are for bookkeeping.  The first element is a preamble string that will
+;;; be displayed before the object.  The second element is a boolean value that
+;;; indicates whether a label will be printed in front of a value, or just the
+;;; value.  Symbols and structures need to display both a slot name and a
+;;; value, while lists, vectors, and atoms need only display a value.  If the
+;;; second member of a parts list is t, then the third and successive members
+;;; must be an association list of slot names and values.  When the second slot
+;;; is nil, the third and successive slots must be the parts of an object.
+;;;
+
+;;; *tty-object-stack* is an assoc list of objects to their parts.  
+;;;
+(defvar *tty-object-stack* ())
+
+(proclaim '(inline numbered-parts-p))
+(defun numbered-parts-p (parts)
+  (second parts))
+
+(defconstant parts-offset 2)
+
+(defun nth-parts (parts n)
+  (if (numbered-parts-p parts)
+      (cdr (nth (+ n parts-offset) parts))
+      (nth (+ n parts-offset) parts)))
+
+(defun tty-inspect (object)
+  (unwind-protect
+      (input-loop object (describe-parts object) *standard-output*)
+    (setf *tty-object-stack* nil)))
+
+;;; When %illegal-object% occurs in a parts list, it indicates that that slot
+;;; is unbound.
+(defvar %illegal-object% (cons nil nil))
+
+(defun input-loop (object parts s)
+  (tty-display-object parts s)
+  (loop
+    (format s "~%> ")
+    (let ((command (read))
+	  (parts-len-2 (- (length parts) 2)))
+      (typecase command
+	(number
+	 (cond ((< -1 command parts-len-2)
+		(cond ((eq (nth-parts parts command) %illegal-object%)
+		       (format s "~%That slot is unbound.~%"))
+		      (t
+		       (push (cons object parts) *tty-object-stack*)
+		       (setf object (nth-parts parts command))
+		       (setf parts (describe-parts object))
+		       (tty-display-object parts s))))
+	       (t
+		(format s "~%Enter a VALID number.~%"))))
+	(symbol
+	 (case (find-symbol (symbol-name command) (find-package "KEYWORD"))
+	   ((:q :e)
+	    (return object))
+	   (:u
+	    (cond (*tty-object-stack*
+		   (setf object (caar *tty-object-stack*))
+		   (setf parts (cdar *tty-object-stack*))
+		   (pop *tty-object-stack*)
+		   (tty-display-object parts s))
+		  (t (format s "~%Bottom of Stack.~%"))))
+	   (:r
+	    (setf parts (describe-parts object))
+	    (tty-display-object parts s))
+	   (:d
+	    (tty-display-object parts s))
+	   ((:h :? :help)
+	    (show-help s))
+	   (t
+	    (format s "~%Invalid command.  Type H for help.~%"))))))))
+
+(defun show-help (s)
+  (terpri)
+  (write-line "TTY-Inspector Help:" s)
+  (write-line "  R           -  recompute current object." s)
+  (write-line "  D           -  redisplay current object." s)
+  (write-line "  U           -  Move upward through the object stack." s)
+  (write-line "  Q, E        -  Quit TTY-INSPECTOR." s)
+  (write-line "  ?, H, Help  -  Show this help." s))
+
+(defun tty-display-object (parts stream)
+  (format stream "~%~a" (car parts))
+  (let ((numbered-parts-p (numbered-parts-p parts))
+	(parts (cddr parts)))
+    (do ((part parts (cdr part))
+	 (i 0 (1+ i)))
+	((endp part) nil)
+      (if numbered-parts-p
+	  (format stream "~d. ~a: ~a~%" i (caar part)
+		  (if (eq (cdar part) %illegal-object%)
+		      "Unbound"
+		      (cdar part)))
+	  (format stream "~d. ~a~%" i (car part))))))
+
+
+
+;;;; DESCRIBE-PARTS
+
+(defun describe-parts (object)
+  (typecase object
+    (symbol (describe-symbol-parts object))
+    (structure (describe-structure-parts object))
+    (function (describe-function-parts object))
+    (vector (describe-vector-parts object))
+    (array (describe-array-parts object))
+    (cons (describe-cons-parts object))
+    (t (describe-atomic-parts object))))
+
+(defun describe-symbol-parts (object)
+  (list (format nil "~s is a symbol.~%" object) t
+	(cons "Value" (if (boundp object)
+			  (symbol-value object)
+			  %illegal-object%))
+	(cons "Function" (if (fboundp object)
+			     (symbol-function object)
+			     %illegal-object%))
+	(cons "Plist" (symbol-plist object))
+	(cons "Package" (symbol-package object))))
+
+(defun describe-structure-parts (object)
+  (let ((dd-slots
+	 (c::dd-slots
+	  (ext:info type structure-info
+		    (system:%primitive header-ref object
+				       system:%g-vector-structure-name-slot))))
+	(parts-list ()))
+    (push (format nil "~s is a structure.~%" object) parts-list)
+    (push t parts-list)
+    (dolist (dd-slot dd-slots (nreverse parts-list))
+      (push (cons (c::dsd-%name dd-slot)
+		  (system:%primitive header-ref object (c::dsd-index dd-slot)))
+	    parts-list))))
+
+(defun describe-function-parts (object)
+  (list (format nil "Function ~s.~%Argument List: ~a." object
+		(system:%primitive header-ref object
+				   lisp::%function-arg-names-slot)
+		#|###
+		(system:%primitive header-ref object
+				   lisp::%function-defined-from-slot)
+		~%Defined from: ~a
+		|#
+		)
+	t))
+
+(defun describe-vector-parts (object)
+  (list* (format nil "Object is a ~:[~;displaced ~]vector of length ~d.~%"
+		 (lisp::%displacedp object) (length object))
+	 nil
+	 (coerce object 'list)))
+
+(defun describe-cons-parts (object)
+  (list* (format nil "Object is a LIST of length ~d.~%" (length object))
+	 nil
+	 object))
+
+(defun describe-array-parts (object)
+  (let* ((length (min (array-total-size object) inspect-length))
+	 (reference-array (make-array length :displaced-to object))
+	 (dimensions (array-dimensions object))
+	 (parts ()))
+    (push (format nil "Object is ~:[a displaced~;an~] array of ~a.~%~
+                       Its dimensions are ~s.~%"
+		  (array-element-type object) (lisp::%displacedp object)
+		  dimensions)
+	  parts)
+    (push t parts)
+    (dotimes (i length (nreverse parts))
+      (push (cons (format nil "~a " (index-string i (reverse dimensions)))
+		  (aref reference-array i))
+	    parts))))
+
+(defun describe-atomic-parts (object)
+  (list (format nil "Object is an atom.~%") nil object))
+
diff --git a/tools/worldcom.lisp b/tools/worldcom.lisp
new file mode 100644
index 000000000..8ca0b2089
--- /dev/null
+++ b/tools/worldcom.lisp
@@ -0,0 +1,118 @@
+;;; -*- Package: User; Log: code.log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; Spice Lisp is currently incomplete and under active development.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+
+(in-package "USER")
+
+(with-compiler-log-file ("ncode:compile-lisp.log")
+
+;;; these guys need to be first.
+
+(comf "ncode:globals" :always-once t) ; For global variables.
+(comf "ncode:struct" :always-once t) ; For structures.
+
+;;; these guys can supposedly come in any order, but not really.
+;;; some are put at the end so macros don't run interpreted and stuff.
+
+(comf "ncode:lispinit")
+(comf "ncode:error")
+(comf "ncode:alieneval")
+(comf "ncode:stream")
+(comf "ncode:arith")
+(comf "ncode:array")
+(comf "ncode:backq")
+(comf "ncode:c-call")
+(comf "ncode:char")
+(comf "ncode:list")
+;(comf "ncode:clx-ext")
+(comf "ncode:commandline")
+(comf "ncode:eval")
+(comf "ncode:debug")
+(comf "ncode:trace")
+(comf "ncode:extensions")
+(comf "ncode:fdefinition")
+(comf "ncode:filesys")
+(comf "ncode:format")
+(comf "ncode:hash")
+(comf "ncode:lfloatcon")
+(comf "ncode:load")
+(comf "ncode:machio")
+(comf "ncode:miscop")
+(comf "ncode:package")
+(comf "ncode:rompstrops")
+(comf "ncode:pred")
+(comf "ncode:print")
+(comf "ncode:provide")
+(comf "ncode:query")
+(comf "ncode:rand")
+(comf "ncode:reader")
+(comf "ncode:rompnum")
+(comf "ncode:salterror")
+(comf "ncode:save")
+(comf "ncode:search-list")
+(comf "ncode:seq")
+(comf "ncode:sharpm")
+(comf "ncode:sort")
+(comf "ncode:run-program")
+(comf "ncode:spirrat")
+(comf "ncode:xp")
+(comf "ncode:xp-patch")
+(comf "ncode:pprint")
+(comf "ncode:string")
+(comf "ncode:subtypep")
+(comf "ncode:symbol")
+(comf "ncode:syscall")
+(comf "ncode:sysmacs")
+(comf "ncode:time")
+(comf "ncode:foreign")
+(comf "c:proclaim")
+(comf "c:knownfun")
+(comf "ncode:debug-info")
+
+;;; Later so that miscellaneous structures are defined (not crucial, but nice.)
+(comf "ncode:describe")
+;(comf "ncode:inspect")
+(comf "ncode:tty-inspect")
+
+(comf "ncode:purify")
+(comf "ncode:gc")
+(comf "ncode:misc")
+(comf "ncode:format-time")
+(comf "ncode:parse-time")
+
+(comf "ncode:internet")
+(comf "ncode:wire")
+(comf "ncode:remote")
+
+(comf "assem:ropdefs")
+(comf "assem:rompconst")
+(comf "assem:disassemble")
+
+(comf "ncode:machdef")
+(comf "ncode:mmlispdefs")
+(comf "nicode:machdefs")
+(comf "nicode:netnamedefs")
+#-new-compiler ; Leave these out for now...
+(load "nicode:machmsgdefs.lisp")
+#-new-compiler
+(comf "nicode:machuser")
+#-new-compiler
+(load "nicode:netnamemsgdefs.lisp")
+#-new-compiler
+(comf "nicode:netnameuser")
+
+(comf "ncode:defstruct")
+(comf "ncode:defmacro")
+(comf "ncode:macros")
+(comf "ncode:defrecord")
+(comf "ncode:constants")
+
+(comf "c:globaldb")
+
+); with-compiler-log-file
diff --git a/tools/worldload.lisp b/tools/worldload.lisp
new file mode 100644
index 000000000..16c5a028f
--- /dev/null
+++ b/tools/worldload.lisp
@@ -0,0 +1,164 @@
+;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; Spice Lisp is currently incomplete and under active development.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+;;;
+;;; This file loads the parts of the system that aren't cold loaded and saves
+;;; the resulting core image.  It writes "lisp.core" in the DEFAULT-DIRECTORY.
+;;;
+
+;;; Turn of GC so bad things don't happen.
+;;;
+(setq lisp::*already-maybe-gcing* t)
+#| Can't eval conditionals now...
+;;; Setup some packages.
+;;;
+(unless (eq *package* (find-package "USER"))
+  (error "Set *package* to the User package and try again."))
+|#
+
+(in-package "CLOS" :nicknames '("PCL"))
+(in-package "USER" :use '("LISP" "EXTENSIONS" "CONDITIONS" "DEBUG" "CLOS"))
+(in-package "HEMLOCK")
+(in-package "LISP")
+
+;;; Must load this here, instead of before loading this file, otherwise
+;;; SEARCH-LIST is unknown.
+;;;
+(load "/afs/cs/project/clisp/new-compiler/logical-names.lisp")
+
+;;; Get some data on this core.
+;;;
+(write-string "What is the current lisp-implementation-version? ")
+(set '*lisp-implementation-version* (read-line))
+(write-string "What is the compiler version? ")
+(set 'compiler-version (read-line))
+(write-string "What is the Hemlock version? ")
+(set '*hemlock-version* (read-line))
+
+;;;
+;;; Keep us entertained...
+(setq *load-verbose* t)
+
+(export 'ed)
+
+(load "code:run-program")
+(load "code:lfloatcon")
+(load "code:spirrat")
+(load "code:foreign")
+(load "code:format-time")
+(load "code:parse-time")
+;(load "code:xp-patch")
+(load "assem:ropdefs")
+(load "assem:rompconst")
+(load "assem:disassemble")
+
+
+(load "c:loadcom.lisp")
+
+(setq lisp::original-lisp-environment NIL)
+
+
+;;; Load the symbol table information for the Lisp start up code.
+;;; Used by CLX for the C routine to connect to the X11 server.
+;;;
+(load-foreign nil)
+
+#|
+;;; CLX.
+;;;
+(load "clx:defsystem")
+(load-clx (pathname "clx:"))
+
+;;; A hack to fix a bug in the X11 R3 server.  This should go away when
+;;; the server is fixed.
+;;;
+(load "/afs/cs/project/clisp/systems-work/font-patch")
+|#
+
+;;; Stick these after LOAD-FORIEGN but before Hemlock.
+;;;
+(load "code:internet")
+(load "code:wire")
+(load "code:remote")
+
+#|
+;;; Hemlock.
+;;;
+(load "hem:rompsite") ;Contains site-init stuff called at load time.
+(load "hem:load-hem.lisp")
+(hi::build-hemlock)
+
+;;; Setup definition editing defaults to look in the stable AFS directory.
+;;; The first translation says what we want most clearly, but we require
+;;; the others due to symbol links.
+;;;
+(ed::add-definition-dir-translation "/afs/cs/project/clisp/systems-work/"
+				    "/afs/cs/project/clisp/systems/")
+(ed::add-definition-dir-translation "/afs/cs/project/clisp-1/systems-work/"
+				    "/afs/cs/project/clisp/systems/")
+(ed::add-definition-dir-translation
+ "/afs/cs.cmu.edu/project/clisp-1/systems-work/"
+ "/afs/cs/project/clisp/systems/")
+(ed::add-definition-dir-translation
+ "/afs/cs.cmu.edu/project/clisp/systems-work/"
+ "/afs/cs/project/clisp/systems/")
+
+;;; For some interim time, translate old compilation directories to the new
+;;; working directories.  Do it for symbolic links and actual paths.
+;;;
+(ed::add-definition-dir-translation "/usr/lisp/"
+				    "/afs/cs/project/clisp/systems/")
+(ed::add-definition-dir-translation "/usr1/lisp/"
+				    "/afs/cs/project/clisp/systems/")
+(ed::add-definition-dir-translation "/usr2/lisp/"
+				    "/afs/cs/project/clisp/systems/")
+
+
+;;; PCL.
+;;;
+(load "pcl:defsys")
+(pcl::load-pcl)
+
+|#
+
+;;; Load these after PCL.
+;;;
+;(load "code:inspect")
+(load "code:tty-inspect")
+
+
+;;; There should be no search lists defined in a full core.
+;;;
+(clrhash lisp::*search-list-table*)
+
+
+;;; Okay, build the thing!
+;;;
+(in-package "USER")
+(progn 
+  (setq + NIL)
+  (setq * NIL)
+  (setq ++ NIL)
+  (setq ** NIL)
+  (setq +++ NIL)
+  (setq *** NIL)
+  (setq lisp::*already-maybe-gcing* t)
+  (setq *load-verbose* nil)
+  (setq *info-environment*
+	(list (make-info-environment :name "Working")
+	      (compact-info-environment (car *info-environment*))))
+  (save-lisp (namestring (merge-pathnames "lisp.core" (default-directory)))
+	     :purify t
+	     :root-structures `(ed
+				#|,hi::*global-command-table*|#
+				lisp::%top-level
+				extensions:save-lisp
+				,lisp::fop-codes
+				compile-file)
+	     :init-function #'abort))
-- 
GitLab