Import to github.

8 files changed, 4256 insertions, 0 deletions

diff --git a/support/README b/support/README
new file mode 100644
index 0000000..6127bc6
--- /dev/null
+++ b/support/README
@@ -0,0 +1,4 @@
+This directory contains utilities that are layered on top of the basic
+mumble support stuff.  There should be no T-specific or CL-specific
+code in this area.
+
diff --git a/support/compile.scm b/support/compile.scm
new file mode 100644
index 0000000..77e222f
--- /dev/null
+++ b/support/compile.scm
@@ -0,0 +1,447 @@
+;;; compile.scm -- compilation utilities
+;;;
+;;; author :  Sandra Loosemore
+;;; date   :  24 Oct 1991
+;;;
+;;; This file defines a makefile-like compilation system that supports
+;;; a hierarchy of dependencies.
+;;; The external entry points are define-compilation-unit, load-unit, and
+;;; compile-and-load-unit.
+
+
+
+;;;=====================================================================
+;;; Parsing
+;;;=====================================================================
+
+
+;;; Establish global defaults for filenames.
+
+(define compile.source-filename source-file-type)
+(define compile.binary-filename binary-file-type)
+(define compile.binary-subdir (string-append lisp-implementation-name "/"))
+(define compile.delayed-loads '())
+
+
+;;; Top level units are stored in this table.
+;;; This is really a slight wart on the whole scheme of things; this
+;;; is done instead of storing the top-level units in variables because
+;;; we were getting unintentional name collisions.
+
+(define compile.unit-table (make-table))
+
+(define-syntax (compile.lookup-unit name)
+  `(table-entry compile.unit-table ,name))
+
+(define (mung-global-units names lexical-units)
+  (map (lambda (n)
+	 (if (memq n lexical-units)
+	     n
+	     `(compile.lookup-unit ',n)))
+       names))
+
+
+;;; Top-level compilation units are defined with define-compilation-unit.
+;;; The body can consist of the following clauses:
+;;;
+;;; (source-filename <filename>)
+;;; (binary-filename <filename>)
+;;;   Specify source and/or binary file names.  For nested units, these
+;;;   are merged with defaults from outer units.  If you don't specify
+;;;   an explicit binary filename, it's inherited from the source file
+;;;   name.
+;;; (require ...)
+;;;   Specify compile/load dependencies.  Arguments are names of other
+;;;   units/component files; these names have scoping like let*, so a unit
+;;;   can require previously listed units at the same or outer level.
+;;; (unit name ....)
+;;;   Specifies a nested unit.  This can appear multiple times.
+;;;   If a unit doesn't include any nested units, then it's a leaf
+;;;   consisting of a single source file.
+;;; (load <boolean>)
+;;;   If supplied and false, the unit isn't loaded unless it is needed
+;;;   to satisfy a require clause.  Used for files containing compilation
+;;;   support stuff.
+;;; (compile <boolean>)
+;;;   If supplied and false, the unit isn't compiled.  Only useful for
+;;;   leaf nodes.  Typically used in combination with (load '#f) to suppress
+;;;   compilation of stuff only used at compile time.
+
+(define-syntax (define-compilation-unit name . clauses)
+  `(begin
+     (let ((unit  ,(compile.process-unit-spec name clauses '#t '())))
+       (setf (compile.lookup-unit ',name) unit)
+       (setf compilation-units (append compilation-units (list unit))))
+     ',name))
+
+
+;;; The basic approach is to turn the compilation unit definition into
+;;; a big LET*, and put calls to build the actual unit object inside
+;;; of this.
+;;; 
+
+(define (compile.process-unit-spec name clauses top-level? lexical-units)
+  (multiple-value-bind
+      (source-filename binary-filename require nested-units
+		       load? compile?)
+      (compile.parse-unit-spec clauses lexical-units)
+    `(let* ((compile.source-filename ,source-filename)
+	    (compile.binary-filename ,binary-filename)
+	    (compile.unit-require    (list ,@require))
+	    (compile.delayed-loads   (append compile.delayed-loads
+					     (compile.select-delayed-loads
+						     compile.unit-require)))
+	    ,@nested-units)
+       (make compile.unit
+	     (name ',name)
+	     (source-filename compile.source-filename)
+	     (binary-filename compile.binary-filename)
+	     (components (list ,@(map (function car) nested-units)))
+	     (require compile.unit-require)
+	     (top-level? ',top-level?)
+	     (load? ,load?)
+	     (compile? ,compile?)
+	     (delayed-loads compile.delayed-loads)))))
+
+(define (compile.parse-unit-spec clauses lexical-units)
+  (let ((source-filename  '#f)
+	(binary-filename  '#f)
+	(require          '#f)
+	(nested-units     '())
+	(load?            ''#t)
+	(compile?         ''#t))
+    (dolist (c clauses)
+      (cond ((not (pair? c))
+	     (compile.unit-syntax-error c))
+	    ((eq? (car c) 'source-filename)
+	     (if source-filename
+		 (compile.unit-duplicate-error c)
+		 (setf source-filename (cadr c))))
+	    ((eq? (car c) 'binary-filename)
+	     (if binary-filename
+		 (compile.unit-duplicate-error c)
+		 (setf binary-filename (cadr c))))
+	    ((eq? (car c) 'require)
+	     (if require
+		 (compile.unit-duplicate-error c)
+		 (setf require (mung-global-units (cdr c) lexical-units))))
+	    ((eq? (car c) 'unit)
+	     (push (list (cadr c)
+			 (compile.process-unit-spec (cadr c) (cddr c)
+						    '#f lexical-units))
+		   nested-units)
+	     (push (cadr c) lexical-units))
+	    ((eq? (car c) 'load)
+	     (setf load? (cadr c)))
+	    ((eq? (car c) 'compile)
+	     (setf compile? (cadr c)))
+	    (else
+	     (compile.unit-syntax-error c))))
+    (values
+        (if source-filename
+	    `(compile.merge-filenames ,source-filename
+		     compile.source-filename '#f)
+	    'compile.source-filename)
+	(if binary-filename
+	    `(compile.merge-filenames ,binary-filename
+		     compile.binary-filename '#f)
+	    (if source-filename
+		'(compile.merge-filenames compile.binary-filename
+			 compile.source-filename
+			 compile.binary-subdir)
+		'compile.binary-filename))
+	(or require '())
+	(nreverse nested-units)
+	load?
+	compile?)))
+
+
+(predefine (error format . args))
+
+(define (compile.unit-syntax-error c)
+  (error "Invalid compilation unit clause ~s." c))
+
+(define (compile.unit-duplicate-error c)
+  (error "Duplicate compilation unit clause ~s." c))
+
+
+
+;;;=====================================================================
+;;; Representation and utilities
+;;;=====================================================================
+
+;;; Here are constructors and accessors for unit objects.
+;;; Implementationally, the compilation unit has the following slots:
+;;;
+;;; * The unit name.
+;;; * The source file name.
+;;; * The binary file name.
+;;; * A list of component file/units.
+;;; * A list of units/files to require.
+;;; * A load timestamp.
+;;; * A timestamp to keep track of the newest source file.
+;;; * Flags for compile and load.
+
+(define-struct compile.unit
+  (predicate compile.unit?)
+  (slots
+    (name             (type symbol))
+    (source-filename  (type string))
+    (binary-filename  (type string))
+    (components       (type list))
+    (require          (type list))
+    (top-level?       (type bool))
+    (load?            (type bool))
+    (compile?         (type bool))
+    (delayed-loads    (type list))
+    (load-time        (type (maybe integer)) (default '#f))
+    (source-time      (type (maybe integer)) (default '#f))
+    (last-update      (type (maybe integer)) (default 0))
+    ))
+
+(define (compile.newer? t1 t2)
+  (and t1
+       t2
+       (> t1 t2)))
+
+(define (compile.select-newest t1 t2)
+  (if (compile.newer? t1 t2) t1 t2))
+
+(define (compile.get-source-time u)
+  (let ((source-file  (compile.unit-source-filename u)))
+    (if (file-exists? source-file)
+	(file-write-date source-file)
+	'#f)))
+
+(define (compile.get-binary-time u)
+  (let ((binary-file  (compile.unit-binary-filename u)))
+    (if (file-exists? binary-file)
+	(file-write-date binary-file)
+	'#f)))
+
+(define (compile.load-source u)
+  (load (compile.unit-source-filename u))
+  (setf (compile.unit-load-time u) (current-date)))
+
+(define (compile.load-binary u)
+  (load (compile.unit-binary-filename u))
+  (setf (compile.unit-load-time u) (current-date)))
+
+(define (compile.compile-and-load u)
+  (let ((source-file  (compile.unit-source-filename u))
+	(binary-file  (compile.unit-binary-filename u)))
+    (compile-file source-file binary-file)
+    (load binary-file)
+    (setf (compile.unit-load-time u) (current-date))))
+
+(define (compile.do-nothing u)
+  u)
+
+      
+;;;=====================================================================
+;;; Runtime support for define-compilation-unit
+;;;=====================================================================
+
+(define (compile.select-delayed-loads require)
+  (let ((result  '()))
+    (dolist (r require)
+      (if (not (compile.unit-load? r))
+	  (push r result)))
+    (nreverse result)))
+
+(define (compile.merge-filenames fname1 fname2 add-subdir)
+  (let ((place1  (filename-place fname1))
+	(name1   (filename-name fname1))
+	(type1   (filename-type fname1)))
+    (assemble-filename
+        (if (string=? place1 "")
+	    (if add-subdir
+		(string-append (filename-place fname2) add-subdir)
+		fname2)
+	    place1)
+	(if (string=? name1 "") fname2 name1)
+	(if (string=? type1 "") fname2 type1))))
+
+
+
+;;;=====================================================================
+;;; Load operation
+;;;=====================================================================
+
+;;; Load-unit and compile-and-load-unit are almost identical.  The only 
+;;; difference is that load-unit will load source files as necessary, while
+;;; compile-and-load-unit will compile them and load binaries instead.
+
+(define (load-unit u)
+  (compile.update-unit-source-times u '#f (current-date))
+  (compile.load-unit-aux u))
+
+(define (compile.load-unit-aux u)
+  (with-compilation-unit ()
+    (compile.load-unit-recursive u '#f)))
+
+(define (compile-and-load-unit u)
+  (compile.update-unit-source-times u '#f (current-date))
+  (compile.compile-and-load-unit-aux u))
+
+(define (compile.compile-and-load-unit-aux u)
+  (with-compilation-unit ()
+    (compile.load-unit-recursive u '#t)))
+
+
+;;; Load a bunch of compilation units as a group.  This is useful because
+;;; it can prevent repeated lookups of file timestamps.  Basically, the
+;;; assumption is that none of the source files will change while the loading
+;;; is in progress.
+;;; In case of an error, store the units left to be compiled in a global
+;;; variable.
+
+(define remaining-units '())
+
+(define (load-unit-list l)
+  (let ((timestamp  (current-date)))
+    (dolist (u l)
+      (compile.update-unit-source-times u '#f timestamp))
+    (setf remaining-units l)
+    (dolist (u l)
+      (compile.load-unit-aux u)
+      (pop remaining-units))))
+
+(define (compile-and-load-unit-list l)
+  (let ((timestamp  (current-date)))
+    (dolist (u l)
+      (compile.update-unit-source-times u '#f timestamp))
+    (setf remaining-units l)
+    (dolist (u l)
+      (compile.compile-and-load-unit-aux u)
+      (pop remaining-units))))
+
+
+;;; Walk the compilation unit, updating the source timestamps.
+
+(define (compile.update-unit-source-times u newest-require timestamp)
+  (unless (eqv? timestamp (compile.unit-last-update u))
+    (setf (compile.unit-last-update u) timestamp)
+    (dolist (r (compile.unit-require u))
+      (if (compile.unit-top-level? r)
+	  (compile.update-unit-source-times r '#f timestamp))
+      (setf newest-require
+	    (compile.select-newest newest-require
+				   (compile.unit-source-time r))))
+    (let ((components  (compile.unit-components u)))
+      (if (not (null? components))
+	  (let ((source-time  newest-require))
+	    (dolist (c components)
+	      (compile.update-unit-source-times c newest-require timestamp)
+	      (setf source-time
+		    (compile.select-newest source-time
+					   (compile.unit-source-time c))))
+	    (setf (compile.unit-source-time u) source-time))
+	  (setf (compile.unit-source-time u)
+		(compile.select-newest
+		  newest-require
+		  (compile.get-source-time u)))))))
+
+
+;;; Load a compilation unit.  Do this by first loading its require list,
+;;; then by recursively loading each of its components, in sequence.  
+;;; Note that because of the way scoping of units works and the
+;;; sequential nature of the load operation, only top-level
+;;; units in the require list have to be loaded explicitly.
+
+(define (compile.load-unit-recursive u compile?)
+  (let ((components       (compile.unit-components u)))
+    ;; First recursively load dependencies.
+    ;; No need to update time stamps again here.
+    (dolist (r (compile.unit-require u))
+      (if (compile.unit-top-level? r)
+	  (compile.load-unit-aux r)))
+    (if (not (null? components))
+	;; Now recursively load subunits.
+	(dolist (c components)
+	  (unless (not (compile.unit-load? c))
+	    (compile.load-unit-recursive c compile?)))
+	;; For a leaf node, load either source or binary if necessary.
+	(let ((source-time  (compile.unit-source-time u))
+	      (binary-time  (compile.get-binary-time u))
+	      (load-time    (compile.unit-load-time u)))
+	  (cond ((compile.newer? load-time source-time)
+		 ;; The module has been loaded since it was last changed,
+		 ;; but maybe we want to compile it now.
+		 (if (and compile?
+			  (compile.unit-compile? u)
+			  (compile.newer? source-time binary-time))
+		     (begin
+		       (compile.do-delayed-loads
+			       (compile.unit-delayed-loads u)
+			       compile?)
+		       (compile.compile-and-load u))
+		     (compile.do-nothing u)))
+		((compile.newer? binary-time source-time)
+		 ;; The binary is up-to-date, so load it.
+		 (compile.load-binary u))
+		(else
+		 ;; The binary is out-of-date, so either load source or
+		 ;; recompile the binary.
+		 (compile.do-delayed-loads
+			 (compile.unit-delayed-loads u)
+			 compile?)
+		 (if (and compile? (compile.unit-compile? u))
+		     (compile.compile-and-load u)
+		     (compile.load-source u)))
+		)))))
+
+
+(define (compile.do-delayed-loads units compile?)
+  (dolist (u units)
+    (compile.load-unit-recursive u compile?)))
+
+
+
+
+;;;=====================================================================
+;;; Extra stuff
+;;;=====================================================================
+
+
+;;; Reload a unit without testing to see if any of its dependencies are
+;;; out of date.
+
+(define (reload-unit-source u)
+  (let ((components  (compile.unit-components u)))
+    (if (not (null? components))
+	(dolist (c components)
+	  (reload-unit-source c))
+	(compile.load-source u))))
+
+(define (reload-unit-binary u)
+  (let ((components  (compile.unit-components u)))
+    (if (not (null? components))
+	(dolist (c components)
+	  (reload-unit-binary c))
+	(compile.load-binary u))))
+
+
+;;; Find a (not necessarily top-level) compilation unit with the given
+;;; name.
+
+(define (find-unit name)
+  (compile.find-unit-aux name compilation-units))
+
+(define (compile.find-unit-aux name units)
+  (block find-unit-aux
+    (dolist (u units '#f)
+      (if (eq? name (compile.unit-name u))
+	  (return-from find-unit-aux u)
+	  (let* ((components (compile.unit-components u))
+		 (result     (compile.find-unit-aux name components)))
+	    (if result
+		(return-from find-unit-aux result)))))))
+
+
+;;; Combine the two above:  reload a compilation unit.
+
+(define-syntax (reload name)
+  `(reload-unit-source
+     (or (find-unit ',name)
+	 (error "Couldn't find unit named ~s." ',name))))
diff --git a/support/format.scm b/support/format.scm
new file mode 100644
index 0000000..c9dbb38
--- /dev/null
+++ b/support/format.scm
@@ -0,0 +1,683 @@
+;;; format.scm -- format function for Scheme
+;;;
+;;; author :  Sandra Loosemore
+;;; date   :  29 Oct 1991
+;;;
+;;;
+;;; This code is adapted from the XP pretty printer originally written
+;;; in Common Lisp by Dick Waters.  Here is the copyright notice attached
+;;; to the original XP source file:
+;;;
+;;;------------------------------------------------------------------------
+;;;
+;;; Copyright 1989,1990 by the Massachusetts Institute of Technology,
+;;; Cambridge, Massachusetts.
+;;; 
+;;; Permission to use, copy, modify, and distribute this software and its
+;;; documentation for any purpose and without fee is hereby granted,
+;;; provided that this copyright and permission notice appear in all
+;;; copies and supporting documentation, and that the name of M.I.T. not
+;;; be used in advertising or publicity pertaining to distribution of the
+;;; software without specific, written prior permission. M.I.T. makes no
+;;; representations about the suitability of this software for any
+;;; purpose.  It is provided "as is" without express or implied warranty.
+;;; 
+;;;  M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
+;;;  ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
+;;;  M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
+;;;  ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+;;;  WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
+;;;  ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
+;;;  SOFTWARE.
+;;;
+;;;------------------------------------------------------------------------
+;;;
+
+
+;;; The stream argument can be #f, in which case a string is returned.
+;;; If the stream is #t, (current-output-port) is used.
+;;; We compile a string argument into a function and call the function.
+;;; The only exception is if the string doesn't contain any ~ escapes;
+;;; then we can treat it as a literal and just write it to the stream.
+
+(define (format stream string-or-fn . args)
+  (cond ((not stream)
+	 (call-with-output-string
+	     (lambda (stream)
+	       (apply (function format) stream string-or-fn args))))
+	(else
+	 (if (eq? stream '#t)
+	     (setf stream (current-output-port)))
+	 (when (string? string-or-fn)
+	   (setf string-or-fn (xp.process-format-string string-or-fn)))
+	 (if (string? string-or-fn)
+	     (write-string string-or-fn stream)
+	     (xp.maybe-initiate-xp-printing string-or-fn stream args))
+	 '#f)))
+
+(define xp.format-string-cache (make-table))
+
+(define (xp.process-format-string string-or-fn)
+  (cond ((not (string? string-or-fn)) string-or-fn)
+	((not xp.format-string-cache)
+	 (xp.maybe-compile-format-string string-or-fn))
+	(else
+	 (when (not (table? xp.format-string-cache))
+	   (setf xp.format-string-cache (make-table)))
+	 (let ((value
+		   (table-entry xp.format-string-cache string-or-fn)))
+	   (when (not value)
+	     (setf value (xp.maybe-compile-format-string string-or-fn))
+	     (setf (table-entry xp.format-string-cache string-or-fn)
+		   value))
+	   value))))
+
+
+(define (xp.maybe-compile-format-string string)
+  (let ((length  (string-length string)))
+    (or (xp.simple-format-string? string 0 length)
+	(let ((fn  (xp.parse-format-string string 0 length)))
+	  (lambda (xp args)
+	    (funcall fn xp args args))))))
+
+
+;;; Try to detect format strings without fancy directives, that can be 
+;;; written with a call to  write-string.
+;;; Can do simple transformations e.g. ~% => newline, ~~ => ~, etc.
+
+(define (xp.simple-format-string? s start end)
+  (let ((twiddle  (string-position #\~ s start end)))
+    (if (not twiddle)
+	(if (eqv? start 0)
+	    s
+	    (substring s start end))
+	(let ((char    (string-ref s (1+ twiddle))))
+	  (cond ((eqv? char #\%)
+		 (let ((tail (xp.simple-format-string? s (+ twiddle 2) end)))
+		   (if tail
+		       (string-append (substring s start twiddle)
+				      (string #\newline)
+				      tail)
+		       '#f)))
+		((eqv? char #\~)
+		 (let ((tail (xp.simple-format-string? s (+ twiddle 2) end)))
+		   (if tail
+		       (string-append (substring s start (1+ twiddle))
+				      tail)
+		       '#f)))
+		((eqv? char #\newline)
+		 (let ((tail (xp.simple-format-string?
+			         s
+				 (xp.skip-whitespace s (+ twiddle 2) end)
+				 end)))
+		   (if tail
+		       (string-append (substring s start twiddle)
+				      tail)
+		       '#f)))
+		(else
+		 '#f))))))
+
+(define (warning string-or-fn . args)
+  (internal-warning (apply (function format) '#f string-or-fn args)))
+
+(define (error string-or-fn . args)
+  (internal-error (apply (function format) '#f string-or-fn args)))
+
+
+;;;=====================================================================
+;;; Compiled format
+;;;=====================================================================
+
+;;; Note that compiled format strings always print through xp streams even if
+;;; they don't have any xp directives in them.  As a result, the compiled code
+;;; can depend on the fact that the stream being operated on is an xp
+;;; stream not an ordinary one.
+
+
+;;; Parse a format string, returning a function to do the printing.
+;;; The function is called with three arguments
+;;;    * the xp stream
+;;;    * the original argument list
+;;;    * the argument list tail
+;;; It should return the list of leftover, unprocessed arguments.
+
+(define (xp.parse-format-string string start end)
+  (cond ((eqv? start end)
+	 (function xp.format-finish))
+	((eqv? (string-ref string start) #\~)
+	 (xp.parse-format-string-dispatch string start end))
+	(else
+	 (let* ((next       (or (string-position #\~ string start end) end))
+		(literal    (substring string start next))
+		(count      (- next start))
+		(continue   (xp.parse-format-string string next end))
+		(newline?   (string-position #\newline literal 0 count)))
+	   (if newline?
+	       (lambda (xp args tail)
+		 (xp.write-string+ literal xp 0 count)
+		 (funcall continue xp args tail))
+	       (lambda (xp args tail)
+		 (xp.write-string++ literal xp 0 count)
+		 (funcall continue xp args tail)))))
+	))
+
+(define (xp.format-finish xp args tail)
+  (declare (ignore xp args))
+  tail)
+
+
+;;; Functions for handling individual format specifiers are installed
+;;; in this table.  They are called with these arguments:
+;;; * the format string
+;;; * the index of the next character
+;;; * the index of the end of the format string
+;;; * the list of parameters for the format specification
+;;; * a boolean indicating whether the colon modifier was present
+;;; * a boolean indicating whether the atsign modifier was present
+;;; The handler is responsible for calling xp.parse-format-string to parse 
+;;; the rest of the format string, and returning a function.  (This has
+;;; to be done by the individual handlers because some of them need to
+;;; scan the format string for matching delimiters, etc.)
+
+;;; *** This probably isn't right, we assume characters can be compared
+;;; *** with EQ? and used as table keys.
+
+(define xp.fn-table (make-table))
+
+(define (define-format char function)
+  (setf (table-entry xp.fn-table (char-upcase char)) function)
+  (setf (table-entry xp.fn-table (char-downcase char)) function))
+
+;;; Parse a ~ sequence from the format string and dispatch to the
+;;; appropriate handler.  
+
+(define (xp.parse-format-string-dispatch string start end)
+  (multiple-value-bind (next params colon? atsign? char)
+      (xp.parse-format-descriptor string start end)
+    (let ((fn  (table-entry xp.fn-table char)))
+      (if fn
+	  (funcall fn string next end params colon? atsign?)
+	  (error "Unrecognized format escape ~~~a." char)))))
+
+(define (xp.parse-format-descriptor string start end)
+  (multiple-value-bind (params start)
+      (xp.parse-format-parameters string start end)
+    (let ((colon?    '#f)
+	  (atsign?   '#f)
+	  (char      '#f))
+      (block parse-format-descriptor
+	(do ()
+	    ((xp.check-for-incomplete-format-string string start end))
+	    (setf char (string-ref string start))
+	    (incf start)
+	    (cond ((eqv? char #\:)
+		   (setf colon? '#t))
+		  ((eqv? char #\@)
+		   (setf atsign? '#t))
+		  (else
+		   (return-from parse-format-descriptor
+		     (values start params colon? atsign? char)))
+		))))))
+
+
+;;; *** The stuff for V and # format parameters is disabled because
+;;; *** it makes the handler functions hairier.  It's rarely used anyway,
+;;; *** and you can get the same effect by consing up a format string
+;;; *** on the fly if you really need to.
+
+(define (xp.parse-format-parameters string start end)
+  (let ((params  '())
+	(char    '#f))
+    (incf start)  ; skip ~
+    (block parse-format-parameters
+      (do ()
+	  ((xp.check-for-incomplete-format-string string start end))
+	  (setf char (string-ref string start))
+	  (cond ((char-numeric? char)
+		 (multiple-value-bind (next value)
+		     (xp.parse-format-number string start end 0)
+		   (setf start next)
+		   (push value params)))
+		((eqv? char #\')
+		 (push (string-ref string (1+ start)) params)
+		 (setf start (+ start 2)))
+		((or (eqv? char #\v) (eqv? char #\V))
+		 (error "V format parameter not supported.")  ;***
+		 (push 'value params)
+		 (setf start (+ start 1)))
+		((eqv? char #\#)
+		 (error "# format parameter not supported.")  ;***
+		 (push 'count params)
+		 (setf start (+ start 1)))
+		((eqv? char #\,)
+		 (push '#f params))
+		(else
+		 (return-from parse-format-parameters
+		   (values (nreverse params) start))))
+	  (if (eqv? (string-ref string start) #\,)
+	      (incf start))))))
+
+(define (xp.parse-format-number string start end value)
+  (xp.check-for-incomplete-format-string string start end)
+  (let* ((char    (string-ref string start))
+	 (weight  (string-position char "0123456789" 0 10)))
+    (if weight
+	(xp.parse-format-number string (1+ start) end (+ (* value 10) weight))
+	(values start value))))
+
+(define (xp.check-for-incomplete-format-string string start end)
+  (if (eqv? start end)
+      (error "Incomplete format string ~s." string)
+      '#f))
+
+
+;;; *** All of these format handlers probably ought to do more checking
+;;; *** for the right number of parameters and not having colon? and
+;;; *** atsign? supplied when they are not allowed.
+
+;;; ~A and ~S are the basic format directives.
+
+(define (xp.format-a string start end params colon? atsign?)
+  (xp.format-a-s-helper string start end params colon? atsign? '#f))
+(define-format #\a (function xp.format-a))
+
+(define (xp.format-s string start end params colon? atsign?)
+  (xp.format-a-s-helper string start end params colon? atsign? '#t))
+(define-format #\s (function xp.format-s))
+
+(define (xp.format-a-s-helper string start end params colon? atsign? escape?)
+  (declare (ignore colon? atsign?))  ;***
+  (let ((continuation  (xp.parse-format-string string start end)))
+    (if (null? params)
+	;; Do the simple, common case.
+	(lambda (xp args tail)
+	  (dynamic-let ((*print-escape*   escape?))
+	    (xp.write+ (car tail) xp))
+	  (funcall continuation xp args (cdr tail)))
+	;; Do the hard case.
+	(let* ((mincol   (or (and (not (null? params)) (pop params)) 0))
+	       (colinc   (or (and (not (null? params)) (pop params)) 1))
+	       (minpad   (or (and (not (null? params)) (pop params)) 0))
+	       (padchar  (or (and (not (null? params)) (pop params)) #\space)))
+	  (declare (ignore mincol colinc minpad padchar))  ;***
+;;; *** I'm confused.  It seems like we have to print this to a string
+;;; *** and then write the string to the XP stream along with the padding
+;;; *** But won't switching to a new stream mess up circularity detection, 
+;;; *** indentation, etc?
+	  (error "Unimplemented format option ~s!" string))
+      )))
+
+
+;;; ~W -> write
+
+(define (xp.format-w string start end params colon? atsign?)
+  (declare (ignore params))
+  (let ((continuation  (xp.parse-format-string string start end)))
+    (cond ((and (not colon?) (not atsign?))
+	   (lambda (xp args tail)
+	     (xp.write+ (car tail) xp)
+	     (funcall continuation xp args (cdr tail))))
+	  ((and colon? (not atsign?))
+	   (lambda (xp args tail)
+	     (dynamic-let ((*print-pretty*  '#t))
+	       (xp.write+ (car tail) xp))
+	     (funcall continuation xp args (cdr tail))))
+	  ((and (not colon?) atsign?)
+	   (lambda (xp args tail)
+	     (dynamic-let ((*print-level*  '#f)
+			   (*print-length* '#f))
+	       (xp.write+ (car tail) xp))
+	     (funcall continuation xp args (cdr tail))))
+	  ((and colon? atsign?)
+	   (lambda (xp args tail)
+	     (dynamic-let ((*print-level*  '#f)
+			   (*print-length* '#f)
+			   (*print-pretty* '#t))
+	       (xp.write+ (car tail) xp))
+	     (funcall continuation xp args (cdr tail))))
+	  )))
+(define-format #\w (function xp.format-w))
+
+
+;;; Here are the directives for printing integers, ~D and friends.
+
+(define (xp.format-d string start end params colon? atsign?)
+  (xp.format-d-b-o-x-helper string start end params colon? atsign? 10))
+(define-format #\d (function xp.format-d))
+
+(define (xp.format-b string start end params colon? atsign?)
+  (xp.format-d-b-o-x-helper string start end params colon? atsign? 2))
+(define-format #\b (function xp.format-b))
+
+(define (xp.format-o string start end params colon? atsign?)
+  (xp.format-d-b-o-x-helper string start end params colon? atsign? 8))
+(define-format #\o (function xp.format-o))
+
+(define (xp.format-x string start end params colon? atsign?)
+  (xp.format-d-b-o-x-helper string start end params colon? atsign? 16))
+(define-format #\x (function xp.format-x))
+
+(define (xp.format-d-b-o-x-helper string start end params colon? atsign? radix)
+  (let ((continuation  (xp.parse-format-string string start end)))
+    (if (and (null? params) (not colon?) (not atsign?))
+	;; Do the simple, common case.
+	(lambda (xp args tail)
+	  (dynamic-let ((*print-escape*  '#f)
+			(*print-radix*   '#f)
+			(*print-base*    radix))
+	    (xp.write+ (car tail) xp))
+	  (funcall continuation xp args (cdr tail)))
+	;; Do the hard case.
+	(let* ((mincol    (or (and (not (null? params)) (pop params)) 0))
+	       (padchar   (or (and (not (null? params)) (pop params)) #\space))
+	       (commachar (or (and (not (null? params)) (pop params)) #\,))
+	       (commaint  (or (and (not (null? params)) (pop params)) 3)))
+	  (declare (ignore mincol padchar commachar commaint))  ;***
+	  ;; *** I'm too lazy to do this right now.
+	  (error "Unimplemented format option ~s!" string)))))
+
+
+(define (xp.format-r string start end params colon? atsign?)
+  (if (not (null? params))
+      (xp.format-d-b-o-x-helper string start end (cdr params)
+			     colon? atsign? (car params))
+      ;; *** The colon? and atsign? modifiers do weird things like
+      ;; *** printing roman numerals.  I'm too lazy to do this until/unless
+      ;; *** we have a real need for it.
+      (error "Unimplemented format option ~s!" string)))
+(define-format #\r (function xp.format-r))
+
+
+;;; ~P -> plurals
+
+(define (xp.format-p string start end params colon? atsign?)
+  (declare (ignore params))
+  (let ((continuation  (xp.parse-format-string string start end)))
+    (cond ((and (not colon?) (not atsign?))
+	   (lambda (xp args tail)
+	     (if (not (eqv? (car tail) 1))
+		 (xp.write-char++ #\s xp))
+	     (funcall continuation xp args (cdr tail))))
+	  ((and colon? (not atsign?))
+	   (lambda (xp args tail)
+	     (setf tail (xp.back-up 1 args tail))
+	     (if (not (eqv? (car tail) 1))
+		 (xp.write-char++ #\s xp))
+	     (funcall continuation xp args (cdr tail))))
+	  ((and (not colon?) atsign?)
+	   (lambda (xp args tail)
+	     (if (eqv? (car tail) 1)
+		 (xp.write-char++ #\y xp)
+		 (begin
+		   (xp.write-char++ #\i xp)
+		   (xp.write-char++ #\e xp)
+		   (xp.write-char++ #\s xp)))
+	     (funcall continuation xp args (cdr tail))))
+	  ((and colon? atsign?)
+	   (lambda (xp args tail)
+	     (setf tail (xp.back-up 1 args tail))
+	     (if (eqv? (car tail) 1)
+		 (xp.write-char++ #\y xp)
+		 (begin
+		   (xp.write-char++ #\i xp)
+		   (xp.write-char++ #\e xp)
+		   (xp.write-char++ #\s xp)))
+	     (funcall continuation xp args (cdr tail)))))))
+(define-format #\p (function xp.format-p))
+
+
+;;; ~C -> character
+
+(define (xp.format-c string start end params colon? atsign?)
+  (declare (ignore params))
+  (let ((continuation  (xp.parse-format-string string start end)))
+    (cond ((and (not colon?) (not atsign?))
+	   (lambda (xp args tail)
+	     (xp.write-char++ (car tail) xp)
+	     (funcall continuation xp args (cdr tail))))
+	  ((and (not colon?) atsign?)
+	   (lambda (xp args tail)
+	     (dynamic-let ((*print-escape*  '#t))
+	       (xp.write+ (car tail) xp)
+	       (funcall continuation xp args (cdr tail)))))
+	  (else
+	   ;; *** I don't know how to get at the character names.
+	   (error "Unimplemented format option ~s!" string)))))
+(define-format #\c (function xp.format-c))
+
+
+
+;;; Newline directives, ~% and ~&
+
+(define (xp.format-percent string start end params colon? atsign?)
+  (xp.format-newline-helper string start end params colon? atsign?
+			 'unconditional))
+(define-format #\% (function xp.format-percent))
+
+(define (xp.format-ampersand string start end params colon? atsign?)
+  (xp.format-newline-helper string start end params colon? atsign?
+			 'fresh))
+(define-format #\& (function xp.format-ampersand))
+
+(define (xp.format-newline-helper string start end params colon? atsign? kind)
+  (declare (ignore colon? atsign?))
+  (let ((continuation (xp.parse-format-string string start end))
+	(n            (or (and (not (null? params)) (pop params)) 1)))
+    (if (eqv? n 1)
+	(lambda (xp args tail)
+	  (xp.pprint-newline+ kind xp)
+	  (funcall continuation xp args tail))
+	(lambda (xp args tail)
+	  (xp.pprint-newline+ kind xp)
+	  (dotimes (i (1- n))
+	    (xp.pprint-newline+ 'unconditional xp))
+	  (funcall continuation xp args tail))
+      )))
+
+
+;;; ~_, Conditional newline
+
+(define (xp.format-underbar string start end params colon? atsign?)
+  (declare (ignore params))
+  (let ((continuation  (xp.parse-format-string string start end))
+	(kind          (if colon?
+			   (if atsign? 'mandatory 'fill)
+			   (if atsign? 'miser 'linear))))
+    (lambda (xp args tail)
+      (xp.pprint-newline+ kind xp)
+      (funcall continuation xp args tail))))
+(define-format #\_ (function xp.format-underbar))
+
+
+;;; Random character printing directives, ~| and ~~
+
+;;; *** commented out because #\page is not standard scheme
+; (define (xp.format-bar string start end params colon? atsign?)
+;  (xp.format-char-helper string start end params colon? atsign? #\page))
+; (define-format #\| (function xp.format-bar))
+
+(define (xp.format-twiddle string start end params colon? atsign?)
+  (xp.format-char-helper string start end params colon? atsign? #\~))
+(define-format #\~ (function xp.format-twiddle))
+
+(define (xp.format-char-helper string start end params colon? atsign? char)
+  (declare (ignore colon? atsign?))
+  (let ((continuation  (xp.parse-format-string string start end))
+	(n             (or (and (not (null? params)) (pop params)) 1)))
+    (if (eqv? n 1)
+	(lambda (xp args tail)
+	  (xp.write-char++ char xp)
+	  (funcall continuation xp args tail))
+	(lambda (xp args tail)
+	  (dotimes (i n)
+	    (xp.write-char++ char xp))
+	  (funcall continuation xp args tail)))))
+
+
+
+;;; ~<newline> directive (ignore whitespace in format string)
+
+(define (xp.format-newline string start end params colon? atsign?)
+  (declare (ignore params))
+  (let ((newline?   '#f)
+	(skip?      '#f))
+    (cond ((and (not colon?) (not atsign?))  ; skip both newline and whitespace
+	   (setf skip? '#t))
+	  ((and colon? (not atsign?)))  ; skip newline, leave whitespace
+	  ((and (not colon?) atsign?)   ; do newline, skip whitespace
+	   (setf newline? '#t)
+	   (setf skip? '#t))
+	  (else
+	   (error "~:@<newline> not allowed.")))
+    (if skip?
+	(setf start (xp.skip-whitespace string start end)))
+    (let ((continuation  (xp.parse-format-string string start end)))
+      (if newline?
+	  (lambda (xp args tail)
+	    (xp.pprint-newline+ 'unconditional xp)
+	    (funcall continuation xp args tail))
+	  continuation))))
+(define-format #\newline (function xp.format-newline))
+
+(define (xp.skip-whitespace string start end)
+  (if (eqv? start end)
+      start
+      (let ((char  (string-ref string start)))
+	(if (and (char-whitespace? char)
+		 (not (eqv? char #\newline)))
+	    (xp.skip-whitespace string (1+ start) end)
+	    start))))
+
+
+
+;;; ~T -> tab
+
+(define (xp.format-t string start end params colon? atsign?)
+  (let* ((continuation  (xp.parse-format-string string start end))
+	 (colnum        (or (and (not (null? params)) (pop params)) 1))
+	 (colinc        (or (and (not (null? params)) (pop params)) 1))
+	 (kind          (if colon?
+			    (if atsign? 'section-relative 'section)
+			    (if atsign? 'line-relative 'line))))
+    (lambda (xp args tail)
+      (xp.pprint-tab+ kind colnum colinc xp)
+      (funcall continuation xp args tail))))
+(define-format #\t (function xp.format-t))
+
+
+;;; ~I -> indent
+
+(define (xp.format-i string start end params colon? atsign?)
+  (declare (ignore atsign?))
+  (let ((continuation  (xp.parse-format-string string start end))
+	(kind          (if colon? 'current 'block))
+	(n             (or (and (not (null? params)) (pop params)) 0)))
+    (lambda (xp args tail)
+      (pprint-indent kind n)
+      (funcall continuation xp args tail))))
+(define-format #\i (function xp.format-i))
+
+
+;;; ~* -> skip or back up over arguments
+
+(define (xp.format-star string start end params colon? atsign?)
+  (let ((continuation  (xp.parse-format-string string start end))
+	(n             (or (and (not (null? params)) (pop params)) 1)))
+    (cond ((and (not colon?) (not atsign?))
+	   (lambda (xp args tail)
+	     (funcall continuation xp args (list-tail tail n))))
+	  ((and colon? (not atsign?))
+	   (lambda (xp args tail)
+	     (funcall continuation xp args (xp.back-up n args tail))))
+	  ((and (not colon?) atsign?)
+	   (lambda (xp args tail)
+	     (declare (ignore tail))
+	     (funcall continuation xp args (list-tail args n))))
+	  (else
+	   (error "~:@* not allowed.")))))
+(define-format #\* (function xp.format-star))
+
+(define (xp.back-up n head tail)
+  (if (eq? (list-tail head n) tail)
+      head
+      (xp.back-up n (cdr head) tail)))
+
+
+;;; ~? -> indirection
+;;; Normally uses two arguments, a string and a list.
+;;; With @, only uses a string, takes arguments from the tail.
+
+(define (xp.format-question string start end params colon? atsign?)
+  (declare (ignore params colon?))
+  (let ((continuation  (xp.parse-format-string string start end)))
+    (if atsign?
+	(lambda (xp args tail)
+	  (setf tail (apply (function format) xp (car tail) (cdr tail)))
+	  (funcall continuation xp args tail))
+	(lambda (xp args tail)
+	  (apply (function format) xp (car tail) (cadr tail))
+	  (funcall continuation xp args (cddr tail))))))
+(define-format #\? (function xp.format-question))
+
+
+;;; ~(...~) -> case conversion.
+
+(define *xp.format-paren-next* '#f)
+
+(define (xp.format-paren string start end params colon? atsign?)
+  (declare (ignore params))
+  (let* ((handler      (dynamic-let ((*xp.format-paren-next* '#t))
+			 (let ((result (xp.parse-format-string
+					   string start end)))
+			   (if (eq? (dynamic *xp.format-paren-next*) '#t)
+			       (error "~( directive has no matching ~)."))
+			   (setf start (dynamic *xp.format-paren-next*))
+			   result)))
+	 (continuation (xp.parse-format-string string start end))
+	 (mode         (if colon?
+			   (if atsign? 'up 'cap1)
+			   (if atsign? 'cap0 'down))))
+    (lambda (xp args tail)
+      (xp.push-char-mode xp mode)
+      (setf tail (funcall handler xp args tail))
+      (xp.pop-char-mode xp)
+      (funcall continuation xp args tail))))
+(define-format #\( (function xp.format-paren))
+
+(define (xp.format-paren-end string start end params colon? atsign?)
+  (declare (ignore string end params colon? atsign?))
+  (if (not (dynamic *xp.format-paren-next*))
+      (error "~) directive has no matching ~(."))
+  (setf (dynamic *xp.format-paren-next*) start)
+  (function xp.format-finish))
+(define-format #\) (function xp.format-paren-end))
+
+;;; ~F      -> fixed-width      *** unimplemented
+;;; ~E      -> e-notation       *** unimplemented
+;;; ~G      -> general float    *** unimplemented
+;;; ~$      -> dollars float    *** unimplemented
+;;; ~[...~] -> conditional      *** unimplemented
+;;; ~{...~} -> iteration        *** unimplemented
+;;; ~<...~> -> justification    *** unimplemented
+;;; ~;      -> clause seperator *** unimplemented
+;;; ~^      -> up and out       *** unimplemented
+;;; ~/.../  -> hook             *** unimplemented
+
+(define (xp.unimplemented-format string start end params colon? atsign?)
+  (declare (ignore start end params colon? atsign?))
+  (error "Unimplemented format directive in ~s." string))
+
+(define-format #\f (function xp.unimplemented-format))
+(define-format #\e (function xp.unimplemented-format))
+(define-format #\g (function xp.unimplemented-format))
+(define-format #\$ (function xp.unimplemented-format))
+(define-format #\[ (function xp.unimplemented-format))
+(define-format #\] (function xp.unimplemented-format))
+(define-format #\{ (function xp.unimplemented-format))
+(define-format #\} (function xp.unimplemented-format))
+(define-format #\< (function xp.unimplemented-format))
+(define-format #\> (function xp.unimplemented-format))
+(define-format #\; (function xp.unimplemented-format))
+(define-format #\^ (function xp.unimplemented-format))
+(define-format #\/ (function xp.unimplemented-format))
+
diff --git a/support/mumble.txt b/support/mumble.txt
new file mode 100644
index 0000000..0ca2f40
--- /dev/null
+++ b/support/mumble.txt
@@ -0,0 +1,840 @@
+Syntax
+------
+
+(quote x)
+
+(function name)
+  You must use this to reference a global function, as in CL.  (There
+  isn't a local function namespace.)
+
+(lambda lambda-list . body)
+  Equivalent to #'(lambda ...) in Common Lisp.
+  The lambda-list can be dotted, as in Scheme.  CL lambda-list keywords
+  are not supported.
+
+function call
+  Order of evaluation is unspecified, as in Scheme.
+  You have to use FUNCALL if the function is bound with let.
+
+(funcall function . args)
+  As in Common Lisp, but might be a macro.  (The function is guaranteed
+  to be a true function, not a symbol.)
+
+(apply procedure . args)
+  As in Common Lisp/Scheme.
+
+(map procedure . lists)
+  As in Scheme.  Equivalent to MAPCAR in CL.
+
+(for-each procedure . lists)
+  As in Scheme.  Equivalent to MAPC in CL.
+
+(every procedure . lists)
+(some procedure . lists)
+(notany procedure . lists)
+(notevery procedure . lists)
+  As in CL, but only work on lists.
+
+(procedure? object)
+  As in Scheme, but can return an arbitrary truth value instead of just #t.
+  Note that we never use symbols or quoted lambda expressions as functions.
+
+(if test then . maybe-else)
+(when test . body)
+(unless test . body)
+
+(cond . tests)
+  As in Scheme, but the = syntax isn't supported.  When no test is true, the
+  result is undefined.
+
+(case value . cases)
+  As in Scheme.
+  Stylistically, use this only when the case labels are symbols.
+
+(and . expressions)
+(or  . expressions)
+
+(not value)
+  As in Scheme but can return an arbitrary truth value instead of #t.
+
+(set! variable value)
+  As in Scheme; this doesn't return a useful value.  Use setf instead.
+
+(setf place value)
+  Similar to SETF in Common Lisp.  Returns value.
+  See define-setf below.  Places that are macro calls are expanded
+  if they don't have their own setter.
+  Here is a list of the built-in setters:
+    dynamic
+    car
+    cdr
+    list-ref
+    string-ref
+    vector-ref
+    table-entry
+
+(let    bindings . body)
+(let*   bindings . body)
+(letrec bindings . body)
+  Note that each binding clause must be a list of the form (var init);
+  you can't just supply var or (var) as in Common Lisp.  Also remember
+  that the order of evaluation for the init-forms is not specified for
+  let/letrec.
+  The Scheme named LET construct is not supported.
+
+(flet   bindings . body)
+(labels bindings . body)
+  As in Common Lisp.
+
+(dynamic-let bindings . body)
+(dynamic name)
+  As in Eulisp.  Dynamic-let is equivalent to bind in T, or LET in
+  Common Lisp with all of the variables declared special.  As a matter
+  of style, use dynamic to reference the value rather than just the name.
+
+(begin . body)
+  Like PROGN in Common Lisp.
+
+(block name . body)
+(return-from name result)
+  The intersection of the Eulisp and Common Lisp definitions.  The "name" 
+  may be bound as a lexical variable, but you should only refer to it
+  inside a return-from.
+  Don't depend on named functions (etc) establishing implicit blocks,
+  as they do in CL.
+
+(do bindings-and-steppers (end-test . results) . body)
+  As in Scheme.  It doesn't necessarily establish an implicit BLOCK 
+  as in CL so you can't RETURN from the loop.
+
+(dolist (variable init . maybe-result) . body)
+(dotimes (variable init . maybe-result) . body)
+  As in CL, except you can't RETURN from the loop.
+
+(values . values)
+(multiple-value-bind variables values-expression . body)
+  As in Common Lisp, except that the values-expression must explicitly
+  return multiple values.
+
+(let/cc variable . body)
+  As in EuLisp.  This is the same as catch in T.  The continuation
+  has dynamic extent within the body.
+  You call the continuation with an arbitrary number of arguments, which
+  are the multiple values to be returned.
+
+(unwind-protect protected-form . body)
+
+(declare ...)
+  Similar to Common Lisp declare.  Declarations are allowed only in the
+  standard places that Common Lisp permits (in particular, at the
+  beginning of binding forms).  For now, only the following declarations
+  are permitted:
+
+  (ignore . variables)
+  (ignorable . variables)
+  (type type-spec . variables)  -- see info on type-specs below.
+
+
+
+
+Definitions
+-----------
+
+(define pattern . value)
+  As in Scheme.
+
+(define-integrable pattern . value)
+  Like DEFINE, but also tells the compiler to try to inline the value.
+
+(define-syntax (name . lambda-list) . body)
+  Similar to the equivalent T functionality.  The lambda-list does not
+  support destructuring, as does Common Lisp's DEFMACRO.
+  The macro definition is made both when the file is loaded and when it
+  is compiled.
+
+(define-local-syntax (name . lambda-list) . body)
+  Again, similar to the T functionality.  In Common Lisp, equivalent to
+  a DEFMACRO wrapped in (eval-when (compile) ...).  
+
+(define-setf getter-name setter-name)
+  Similar to the short form of DEFSETF in Common Lisp, except that the
+  calling convention for the setter differs:  the value is passed as the
+  first argument rather than as the last.  The setter must return this
+  value.
+
+(predefine pattern)
+  This is a forward definition for a function or variable.  It doesn't
+  actually make a definition; its purpose is to try to get rid of compiler
+  warnings about calls to functions that haven't been defined yet.  It can
+  be a no-op if the underlying Lisp system doesn't provide any way to do
+  this.
+
+(redefine pattern . value)
+  Like DEFINE, but hints to the compiler not to complain if this 
+  function/variable was previously defined somewhere else.
+
+(redefine-syntax (name . lambda-list) . body)
+  Like DEFINE-SYNTAX, but hints to the compiler not to complain if this
+  macro was previously defined somewhere else.
+
+
+Equivalence
+-----------
+
+(eq? x1 x2)
+(eqv? x1 x2)
+(equal? x1 x2)
+  As in Scheme but can return an arbitrary truth value instead of #t.
+  Note that equal? is not the same as EQUAL in CL because it descends vectors.
+  eqv? is different from the T equiv? because it doesn't descent strings.
+
+
+Lists
+-----
+
+(pair? x)
+  As in Scheme but can return an arbitrary truth value instead of #t.
+
+(cons x y)
+(list . values)
+(make-list length . maybe-init)
+
+(cxxxxr x)
+
+(null? x)
+(list? x)
+  As in Scheme but can return an arbitrary truth value instead of #t.
+  Note that this is a check for a proper (null-terminated) list, not
+  like LISTP in CL.
+
+(length x)
+(append list . more-lists)
+(nconc list . more-lists)
+
+(reverse x)
+(nreverse x)
+
+(list-tail list n)
+  Like NTHCDR in Common Lisp.
+
+(list-ref list n)
+  Like NTH in Common Lisp.
+
+(last list)
+(butlast list)
+  As in Common Lisp.
+
+(memq object list)
+(memv object list)
+(member object list)
+
+(assq object list)
+(assv object list)
+(assoc object list)
+
+(push item place)
+(pop place)
+  As in Common Lisp.
+
+(list-copy list)
+
+
+Symbols
+-------
+
+(symbol? object)
+(symbol->string object)
+(string->symbol object)
+(gensym . maybe-prefix)
+(gensym? object)
+
+(symbol-append . symbols)
+
+
+Characters
+----------
+
+(char? object)
+  As in Scheme, but can return an arbitrary truth value instead of just #t.  
+
+(char=? c1 c2)
+(char<? c1 c2)
+(char>? c1 c2)
+(char<=? c1 c2)
+(char>=? c1 c2)
+  As in Scheme, except that they can return an arbitrary truth value
+  instead of just #t.
+
+(char-ci=? c1 c2)
+(char-ci<? c1 c2)
+(char-ci>? c1 c2)
+(char-ci<=? c1 c2)
+(char-ci>=? c1 c2)
+  As in Scheme, except that they can return an arbitrary truth value
+  instead of just #t.
+
+(char-alphabetic? c)
+(char-numeric? c)
+(char-whitespace? c)
+(char-upper-case? c)
+(char-lower-case? c)
+
+(char->integer c)
+(integer->char n)
+
+(char-upcase c)
+(char-downcase c)
+
+(char-name c)
+  As in Common Lisp.
+
+(char->digit c . maybe-radix)
+  Returns nil or the "weight" of the character as a fixnum in the given
+  radix (defaults to 10).
+
+
+Strings
+-------
+
+(string? object)
+  As in Scheme, but can return an arbitrary truth value instead of just #t.
+
+(make-string length . maybe-init)
+
+(string char . more-chars)
+
+(string-length string)
+(string-ref string index)
+
+(string=? s1 s2)
+(string<? s1 s2)
+(string>? s1 s2)
+(string<=? s1 s2)
+(string>=? s1 s2)
+  As in Scheme, but can return an arbitrary truth value instead of just #t.
+
+(string-ci=? s1 s2)
+(string-ci<? s1 s2)
+(string-ci>? s1 s2)
+(string-ci<=? s1 s2)
+(string-ci>=? s1 s2)
+  As in Scheme, but can return an arbitrary truth value instead of just #t.
+
+(substring string start end)
+(string-append string . more-strings)
+
+(string->list string)
+(list->string list)
+
+(string-copy string)
+
+(string-upcase string)
+(string-downcase string)
+
+
+Vectors
+-------
+
+(vector? object)
+  As in Scheme, but can return an arbitrary truth value instead of just #t.
+
+(make-vector length . maybe-init)
+(vector object . more-objects)
+
+(vector-length vector)
+(vector-ref vector index)
+(vector->list vector)
+(list->vector list)
+
+(vector-copy vector)
+
+
+Numbers
+-------
+
+(number? object)
+  As in Scheme, but can return an arbitrary truth value instead of just #t.
+
+(integer? object)
+(rational? object)
+(float? object)
+  These test the representation of a number, not its mathematical 
+  properties.  They're equivalent to the CL integerp, rationalp, and floatp
+  predicates.  We ignore complex numbers for now.
+
+(exact->inexact number)
+  Convert an exact-rational to a float.
+
+(= x1 x2)
+(< x1 x2)
+(> x1 x2)
+(<= x1 x2)
+(>= x1 x2)
+  As in Scheme, except they can return an arbitrary truth value.
+  They're restricted to being binary operators because that's all
+  that's supported in T.
+
+(zero? x)
+(positive? x)
+(negative? x)
+  As in Scheme, except they can return an arbitrary truth value.
+
+(min number . more-numbers)
+(max number . more-numbers)
+
+(+ . numbers)
+(* . numbers)
+(- n1 . more-numbers)
+(/ n1 . more-numbers)
+  As in Scheme.
+
+(quotient n1 n2)
+(remainder n1 n2)
+(modulo n1 n2)
+  quotient rounds towards zero.
+  remainder has the sign of the second argument, modulo has the sign of
+  the first argument.
+
+(floor x)
+(ceiling x)
+(truncate x)
+(round x)
+  As in Scheme.  These return a number of the same type as the argument.
+
+(floor->exact x)
+(ceiling->exact x)
+(truncate->exact x)
+(round->exact x)
+  Like the above, but return an exact-integer result.  Borrowed from
+  MIT Scheme.
+
+(1+ n)
+(1- n)
+(incf place . maybe-delta)
+(decf place . maybe-delta)
+  As in Common Lisp.
+
+(number->string number . maybe-radix)
+(string->number string . maybe-radix)
+  As in Scheme.
+
+(expt base power)
+  As in Common Lisp.  [our only use is when both args are integers]
+
+
+Tables
+------
+
+(table? object)
+(make-table)
+(table-entry table key)
+(table-for-each proc table)
+(copy-table table)
+  More or less as in T.  For now we only bother with tables that use
+  eq? as the comparison function -- mostly symbols are used as keys.
+ 
+
+I/O
+---
+
+(call-with-input-file string proc)
+(call-with-output-file string proc)
+  As in Scheme.  The proc is called with one argument, the port.
+
+(call-with-input-string string proc)
+(call-with-output-string proc)
+  Similar, but for reading/writing to a string stream string.
+  Call-with-output-string returns the string.
+
+(input-port? object)
+(output-port? object)
+  As in Scheme, but can return an arbitrary truth value.
+
+(current-input-port)
+(current-output-port)
+
+(open-input-file filename)
+(open-output-file filename)
+
+(close-input-port port)
+(close-output-port port)
+
+(read . maybe-port)
+(read-char . maybe-port)
+(peek-char . maybe-port)
+(read-line . maybe-port)
+
+(eof-object? object)
+
+
+Printer
+-------
+
+(internal-write object port)
+(internal-output-width port)
+(internal-output-position port)
+(internal-write-char char port)
+(internal-write-string string port start end)
+(internal-newline port)
+(internal-fresh-line port)
+(internal-finish-output port)
+(internal-force-output port)
+(internal-clear-output port)
+(internal-write-to-string object)
+(internal-warning string)
+(internal-error string)
+  These are all internal hooks.  Don't use them directly if you can
+  avoid it.
+
+(write object . maybe-stream)
+(print object . maybe-stream)
+(prin1 object . maybe-stream)
+(princ object . maybe-stream)
+(pprint object . maybe-stream)
+(prin1-to-string object)
+(princ-to-string object)
+(write-char char . maybe-stream)
+(write-string string . maybe-stream-start-end)
+(write-line string . maybe-stream-start-end)
+(terpri . maybe-stream)
+(fresh-line . maybe-stream)
+(finish-output . maybe-stream)
+(force-output . maybe-stream)
+(clear-output . maybe-stream)
+  These are the standard Common Lisp print functions.  All of them
+  accept either a port or an XP stream as a stream argument.
+
+(display object . maybe-stream)
+  Same as princ; for Scheme compatibility.
+(newline object . maybe-stream)
+  Same as terpri; for Scheme compatibility.
+
+
+*print-escape*
+*print-shared*
+*print-circle*
+*print-pretty*
+*print-level*
+*print-length*
+  These are the standard Common Lisp printer control variables.  The
+  functions listed above obey them.
+
+*print-base*
+*print-radix*
+*print-case*
+*print-readably*
+  These are more standard Common Lisp printer control variables, but
+  support for them hasn't been implemented yet.  Maybe some day.
+
+*print-dispatch*
+  This is the hook for user customization of the printer.  Its value is a 
+  function that is passed an object as an argument, and returns another
+  function that takes a stream and the object as arguments.
+
+*print-structure*
+  If true, use standard structure printing syntax (overriding any special
+  print function for the structure type).
+
+*print-structure-slots*
+  If true, recursively print structure slots when using standard structure
+  printing syntax; otherwise just print the structure type name.
+
+
+(standard-print-dispatch object)
+  This function is the initial value of *print-dispatch*.
+
+*print-right-margin*
+*print-miser-width*
+*print-lines*
+*default-right-margin*
+*last-abbreviated-printing*
+  These are the XP pretty-printer control variables.  For more information
+  about the pretty-printer, read the XP document.
+
+(pprint-newline kind . maybe-stream)
+  The kind argument can be one of LINEAR, FILL, MISER, or MANDATORY.
+
+(pprint-logical-block (stream-symbol list . more-options) . body)
+  This is a macro.  The body should contain code for printing a logical
+  block to the stream stream-symbol.
+
+  The format of the options is (stream-symbol list prefix suffix per-line?).
+  
+  The list argument can be used with the pprint-pop macro.
+
+  The prefix is a string that is printed as the initial prefix of the logical
+  block.  If per-line? is true, then the prefix is printed on every line.
+  The suffix is a string that is printed at the end of the logical block.
+
+  You can use this macro even when not pretty-printing, to get support
+  for *print-length* and *print-level*.  In that case, you should have
+  the body forms put out only a minimal amount of whitespace.
+
+(pprint-pop)
+  Returns the next item from the list specified to an enclosing 
+  pprint-logical-block.  Checks for circular list tails and *print-length*
+  abbreviation.
+
+(pprint-exit-if-list-exhausted)
+  Can be used inside pprint-logical-block to see if the list is empty.
+  Causes the block to be exited if so.
+
+(pprint-indent relative-to n . maybe-stream)
+  Specify the indentation level to use for a logical block.
+  The relative-to argument can be either BLOCK or CURRENT.
+
+(pprint-tab kind colnum colinc . maybe-stream)
+  Specify tabbing.  The kind argument can be one of LINE, SECTION,
+  LINE-RELATIVE, or SECTION-RELATIVE.
+  
+(pprint-fill stream list . maybe-colon-atsign)
+(pprint-linear stream list . maybe-colon-atsign)
+(pprint-tabular stream list . maybe-colon-atsign-tabsize)
+  Pretty-print list to the stream in the given style.
+  
+
+(format stream string-or-fn . args)
+  The standard Common Lisp format, except that some of the more esoteric
+  directives are unimplemented.  (Specifically, watch out for specifying
+  field widths or using # or V parameters; most of the numeric formatting
+  options are unimplemented, as are complicated directives like ~{...~}.)
+
+  The stream parameter can be #f to output to a string, or #t to output
+  to the (current-output-port).
+
+  The string-or-fn argument can be a function as well as a string containing
+  embedded directives.  The function is applied to the stream and the args.
+
+(warning string-or-fn . args)
+(error string-or-fn . args)
+
+
+
+System Interface
+----------------
+
+(macroexpand-1 form . maybe-env)
+(macroexpand form . maybe-env)
+  As in Common Lisp.  Since we don't have lexical macros and don't allow
+  syntax to be shadowed by local bindings, you can omit the environment 
+  argument.  These functions are provided mostly for debugging purposes.
+
+(eval form . maybe-compile)
+  As in Common Lisp.  If the optional argument is supplied and is true,
+  try to compile the code in memory, not interpret it.
+
+(load filename)
+
+*code-quality*
+  A number between 0 and 3.  0 = minimal compilation, 1 = for debugging,
+  2 = low safety, high speed, fast compilation, 3 = go all out.
+
+(compile-file source-filename . maybe-binary-filename)
+
+(with-compilation-unit options . forms)
+  This is the ANSI CL macro.  We don't use any options.
+
+(filename-place filename)
+(filename-name filename)
+(filename-type filename)
+  We use a rather simplistic file system model.  Filenames are strings
+  with place (or directory), name, and type components.  These functions
+  pick apart filename strings.  You shouldn't have to mess with string 
+  operations on the components directly.  
+
+(assemble-filename place-filename name-filename type-filename)
+  Build a new filename by combining the appropriate parts of the argument
+  filenames.
+
+source-file-type
+binary-file-type
+  These constants hold appropriate default types for source and
+  compiled files.  By convention, source-file-type is ".scm" but
+  the binary-file-type depends on the underlying Lisp system.
+
+(file-exists? filename)
+  Returns true if the file exists.
+
+(file-write-date filename)
+(current-date)
+  Dates are represented as integers relative to an arbitrary base.  These
+  functions are mostly useful for recording timestamps.
+
+(get-run-time)
+  Return run time as a floating-point number relative to an arbitrary base.
+  Useful for doing timings.
+
+(getenv name)
+  Explicitly expand an environment variable.  (Environment variables that
+  appear as filename prefixes are expanded automagically by the functions 
+  that open files.)
+
+(cd filename)
+  Change the current directory.
+
+
+(exit)
+  Go away.
+
+
+Reader Support
+--------------
+
+' => quote
+` => backquote; also , and ,@
+#t and #f
+
+
+Random Stuff
+------------
+
+lisp-implementation-name
+  returns a string identifying the underlying lisp implementation; e.g.
+  "lucid", "t", etc.
+
+(identify-system)
+  return a longer string indentifying the lisp version and machine type.
+
+left-to-right-evaluation
+  True if the underlying Lisp always evaluates function arguments
+  left-to-right; false otherwise.
+
+(gc-messages onoff)
+  Turn garbage collection messages on/off, if possible.
+
+(identity x)
+  The identity function.
+
+
+
+Type specifiers
+---------------
+
+t
+procedure
+pair
+null
+list, (list element-type)
+symbol
+char
+string
+vector
+number
+integer
+rational
+float
+fixnum, int
+table, (table key-type value-type)
+(enum . values)
+(tuple . component-types)
+bool
+alist, (alist key-type value-type)
+(maybe type)
+struct
+type-descriptor
+slot-descriptor
+  These are the standard type specifiers.
+
+the
+  As in Common Lisp.
+subtype?
+  Equivalent to CL subtypep
+is-type?
+  Equivalent to CL typep
+typecase
+  As in Common Lisp, also recognizes "else" clause.
+  
+
+
+Structures
+----------
+
+(struct? object)
+  Returns true if the object is a struct.
+(struct-type-descriptor object)
+  Returns the type descriptor of a struct object.
+
+name, slots, parent-type, printer
+  Slots of type-descriptor object.
+
+(td-name td)
+(td-slots td)
+(td-parent-type td)
+(td-printer td)
+  Accessors for type-descriptors.
+
+name, type, default, getter
+  Slots of slot-descriptor object.
+
+(sd-name sd)
+(sd-type sd)
+(sd-default sd)
+(sd-getter sd)
+  Accessors for slot-descriptors.
+(sd-getter-function sd)
+  Returns a function which can be used to access a slot (as opposed to
+  the symbol that names the function).
+
+(lookup-type-descriptor type-name)
+(lookup-slot-descriptor type-name slot-name)
+  Name to descriptor mappings.
+
+
+(make type . initializers)
+  The type must name a struct type; it is not evaluated.
+  The initializers are of the form (slot-name value-form).
+
+(struct-slot type slot object)
+  Generalized slot access.  Type and slot are symbols.  If both are
+  quoted, can be used with SETF.
+
+(with-slots type slot-names object . body)
+  Binds the specified slots of object to local variables with the
+  same names.  Bindings are read-only.  Type is not evaluated.
+
+(update-slots type object . initializers)
+  Modifies the slots of object.  Syntax of initializers is as for make.
+  Type is not evaluated.
+
+(define-struct name
+  (include parent-type-name)
+  (type-template subtype-of-type-descriptor)
+  (prefix prefix-symbol)
+  (predicate predicate-name)
+  (slots
+    (slot-name
+      (type type)
+      (default init-form)
+      (bit #t)
+      (read-only? #t)
+      (uninitialized? #t))
+    ...))
+
+  Defines name as a subtype of struct with the given slots.
+  All fields are optional.
+
+  Include specifies the immediate supertype.  All accessors on the supertype
+  work on the newly defined type.  It defaults to struct.
+
+  Type-template specifies the metaclass.  It can be used to attach 
+  additional information to the type descriptor.  It defaults to 
+  type-descriptor.
+
+  Prefix can be used to specify an alternate prefix for accessors.  The
+  default is name-.
+
+  Predicate can be used to create a predicate function.  The default is
+  not to create one.
+
+  If no default is specified for a slot, it's expected to have an
+  explicit initializer supplied with MAKE.  You'll get a compilation
+  warning otherwise, unless you specify the uninitialized? option instead.
+
+  Bit is a hint for optimizing internal representation.
+
+  Read-only? says not to create a SETFer for the slot.
+
+
+(define-struct-printer struct-name printer-function)
+  Specifies a printer function to use when *print-structure* is false.
+
diff --git a/support/pprint.scm b/support/pprint.scm
new file mode 100644
index 0000000..9b28ec8
--- /dev/null
+++ b/support/pprint.scm
@@ -0,0 +1,1788 @@
+;;; pprint.scm -- xp pretty-printer in Scheme
+;;;
+;;; author :  Sandra Loosemore
+;;; date   :  29 Oct 1991
+;;;
+;;;
+;;; This code is adapted from the XP pretty printer originally written
+;;; in Common Lisp by Dick Waters.  Here is the copyright notice attached
+;;; to the original XP source file:
+;;;
+;;;------------------------------------------------------------------------
+;;;
+;;; Copyright 1989,1990 by the Massachusetts Institute of Technology,
+;;; Cambridge, Massachusetts.
+;;; 
+;;; Permission to use, copy, modify, and distribute this software and its
+;;; documentation for any purpose and without fee is hereby granted,
+;;; provided that this copyright and permission notice appear in all
+;;; copies and supporting documentation, and that the name of M.I.T. not
+;;; be used in advertising or publicity pertaining to distribution of the
+;;; software without specific, written prior permission. M.I.T. makes no
+;;; representations about the suitability of this software for any
+;;; purpose.  It is provided "as is" without express or implied warranty.
+;;; 
+;;;  M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
+;;;  ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
+;;;  M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
+;;;  ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+;;;  WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
+;;;  ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
+;;;  SOFTWARE.
+;;;
+;;;------------------------------------------------------------------------
+;;;
+
+
+;;;=====================================================================
+;;; Variables
+;;;=====================================================================
+
+
+;;; External variables.  These may be specially bound by user code.
+
+(define *print-escape*           '#t)
+(define *print-circle*           '#f)
+(define *print-level*            '#f)
+(define *print-length*           '#f)
+(define *print-base*             10)
+(define *print-radix*            '#f)
+
+
+(define *print-shared*           '#f)
+(define *print-pretty*           '#f)
+(define *print-right-margin*     '#f)
+(define *print-miser-width*      40)
+(define *print-lines*            '#f)
+(define *default-right-margin*   70)
+(define *last-abbreviated-printing*
+  (lambda maybe-stream
+    (declare (ignore maybe-stream))
+    '#f))
+
+(define *print-dispatch*         '#f)  ; initialized later
+(define *print-structure*        '#f)
+(define *print-structure-slots*  '#t)
+
+
+;;; *** These variables aren't really supported, but they should be.
+
+(define *print-readably*         '#f)
+(define *print-case*             'upcase)
+
+
+
+;;; Internal variables.  These are all specially rebound when we initiate
+;;; printing to an XP stream.
+
+(define *xp.current-level* 0)
+(define *xp.current-length* 0)
+(define *xp.abbreviation-happened* '#f)
+(define *xp.locating-circularities* '#f)
+(define *xp.parents* '())
+(define *xp.circularity-hash-table* '#f)
+(define *xp.line-limit-abbreviation-exit*
+  (lambda values
+    (declare (ignore values))
+    (error "No line limit abbreviation exit in this extent.")))
+
+
+
+;;;=====================================================================
+;;; Dispatching
+;;;=====================================================================
+
+;;; Since Scheme doesn't have type specifiers or named structures,
+;;; the dispatch mechanism defined for the Common Lisp XP won't work
+;;; very well.  A more general alternative might be to maintain a
+;;; sorted list of <priority predicate printer> tuples, but having to
+;;; try each of these in sequence could get very slow.
+;;;
+;;; What I've decided to to instead is to have the value of
+;;; *print-dispatch* be a user-defined dispatcher
+;;; function:  given an object, it should return a function to print it,
+;;; or #f.  In the latter case, the object is printed in some default
+;;; way.
+;;;
+;;; The standard dispatcher function is defined towards the bottom
+;;; of this file.  If you are writing your own dispatcher, you should
+;;; probably call this function as the fall-through case.
+
+(define (xp.get-printer object)
+  (funcall (dynamic *print-dispatch*) object))
+
+
+;;;=====================================================================
+;;; Internal data structures
+;;;=====================================================================
+
+(define-integrable xp.block-stack-entry-size 1)
+(define-integrable xp.prefix-stack-entry-size 5)
+(define-integrable xp.queue-entry-size 7)
+(define-integrable xp.buffer-entry-size 1)
+(define-integrable xp.prefix-entry-size 1)
+(define-integrable xp.suffix-entry-size 1)
+
+(define-integrable xp.block-stack-min-size (* 35 xp.block-stack-entry-size))
+(define-integrable xp.prefix-stack-min-size (* 30 xp.prefix-stack-entry-size))
+(define-integrable xp.queue-min-size (* 75 xp.queue-entry-size))
+(define-integrable xp.buffer-min-size 256)
+(define-integrable xp.prefix-min-size 256)
+(define-integrable xp.suffix-min-size 256)
+
+
+;;; The xp stream structure.
+;;; Fields without defaults are initialized by xp.initialize-xp, below.
+
+(define-struct xp
+  (prefix xp.)
+  (predicate xp.xp-structure-p)
+  (slots
+   (base-stream (type t) (default '#f))
+   (linel (type fixnum) (default 0))
+   (line-limit (type (maybe fixnum)) (default '#f))
+   (line-no (type fixnum) (default 0))
+   (char-mode (type (enum #f up down cap0 cap1 capw)) (default '#f))
+   (char-mode-counter (type fixnum) (default 0))
+   ;; number of logical blocks at qright that are started but not ended.
+   (depth-in-blocks (type fixnum) (default 0))
+   ;; This stack is pushed and popped in accordance with the way blocks
+   ;; are nested at the moment they are entered into the queue.
+   (block-stack (type vector) (default (make-vector xp.block-stack-min-size)))
+   ;; Pointer into block-stack vector.
+   (block-stack-ptr (type fixnum) (default 0))
+   ;; This is a string that builds up the line images that will be printed out.
+   (buffer (type string) (default (make-string xp.buffer-min-size)))
+   ;; The output character position of the first character in the buffer;
+   ;; nonzero only if a partial line has been output.
+   (charpos (type fixnum) (default 0))
+   ;; The index in the buffer where the next character is to be inserted.
+   (buffer-ptr (type fixnum) (default 0))
+   ;; This is used in computing total lengths.  It is changed to reflect
+   ;; all shifting and insertion of prefixes so that total length computes
+   ;; things as they would be if they were all on one line.
+   (buffer-offset (type fixnum) (default 0))
+   ;; The queue of action descriptors.  The value is a vector.
+   (queue (type vector) (default (make-vector xp.queue-min-size)))
+   ;; Index of next queue entry to dequeue.
+   (qleft (type fixnum) (default 0))
+   ;; Index of last entry queued; queue is empty when (> qleft qright).
+   (qright (type fixnum) (default 0))
+   ;; This stores the prefix that should be used at the start of the line.
+   (prefix (type string) (default (make-string xp.buffer-min-size)))
+   ;; This stack is pushed and popped in accordance with the way blocks
+   ;; are nested at the moment things are taken off the queue and printed.
+   (prefix-stack (type vector) (default (make-vector xp.prefix-stack-min-size)))
+   ;; Index into prefix-stack.
+   (prefix-stack-ptr (type fixnum) (default 0))
+   ;; This stores the suffixes that have to be pritned to close of the
+   ;; current open blocks.  For convenience in popping, the whole suffix
+   ;; is stored in reverse order.
+   (suffix (type string) (default (make-string xp.buffer-min-size)))
+   ))
+
+
+(define (xp.make-xp-structure)
+  (make xp))
+
+
+;;; Positions within the buffer are kept in three ways:
+;;; * Buffer position (eg BUFFER-PTR)
+;;; * Line position (eg (+ BUFFER-PTR CHARPOS)).
+;;;   Indentations are stored in this form.
+;;; * Total position if all on one line (eg (+ BUFFER-PTR BUFFER-OFFSET))
+;;;   Positions are stored in this form.
+
+(define-local-syntax (xp.lp<-bp xp . maybe-ptr)
+  (let ((ptr  (if (not (null? maybe-ptr))
+		  (car maybe-ptr)
+		  `(xp.buffer-ptr ,xp))))
+    `(+ ,ptr (xp.charpos ,xp))))
+
+(define-local-syntax (xp.tp<-bp xp)
+  `(+ (xp.buffer-ptr ,xp) (xp.buffer-offset ,xp)))
+
+(define-local-syntax (xp.bp<-lp xp ptr)
+  `(- ,ptr (xp.charpos ,xp)))
+
+(define-local-syntax (xp.bp<-tp xp ptr)
+  `(- ,ptr (xp.buffer-offset ,xp)))
+
+(define-local-syntax (xp.lp<-tp xp ptr)
+  `(xp.lp<-bp ,xp (xp.bp<-tp ,xp ,ptr)))
+
+
+;;; Define some macros for growing the various stacks in the xp-structure.
+
+(define-local-syntax (xp.check-block-stack-size xp ptr)
+  `(setf (xp.block-stack ,xp)
+	 (xp.grow-vector (xp.block-stack ,xp) ,ptr xp.block-stack-entry-size)))
+
+(define-local-syntax (xp.check-prefix-size xp ptr)
+  `(setf (xp.prefix ,xp)
+	 (xp.grow-string (xp.prefix ,xp) ,ptr xp.prefix-entry-size)))
+
+(define-local-syntax (xp.check-prefix-stack-size xp ptr)
+  `(setf (xp.prefix-stack ,xp)
+	 (xp.grow-vector (xp.prefix-stack ,xp) ,ptr xp.prefix-stack-entry-size)))
+
+(define-local-syntax (xp.check-queue-size xp ptr)
+  `(setf (xp.queue ,xp)
+	 (xp.grow-vector (xp.queue ,xp) ,ptr xp.queue-entry-size)))
+
+(define-local-syntax (xp.check-buffer-size xp ptr)
+  `(setf (xp.buffer ,xp)
+	 (xp.grow-string (xp.buffer ,xp) ,ptr xp.buffer-entry-size)))
+
+(define-local-syntax (xp.check-suffix-size xp ptr)
+  `(setf (xp.suffix ,xp)
+	 (xp.grow-string (xp.suffix ,xp) ,ptr xp.suffix-entry-size)))
+
+(define (xp.grow-vector old ptr entry-size)
+  (let ((end  (vector-length old)))
+    (if (> ptr (- end entry-size))
+	(let ((new  (make-vector (+ ptr 50))))
+	  (dotimes (i end)
+	    (setf (vector-ref new i) (vector-ref old i)))
+	  new)
+	old)))
+
+(define (xp.grow-string old ptr entry-size)
+  (let ((end  (string-length old)))
+    (if (> ptr (- end entry-size))
+	(let ((new  (make-string (+ ptr 50))))
+	  (dotimes (i end)
+	    (setf (string-ref new i) (string-ref old i)))
+	  new)
+	old)))
+
+
+
+;;; Things for manipulating the block stack.
+
+(define-local-syntax (xp.section-start xp)
+  `(vector-ref (xp.block-stack ,xp) (xp.block-stack-ptr ,xp)))
+
+(define (xp.push-block-stack xp)
+  (incf (xp.block-stack-ptr xp) xp.block-stack-entry-size)
+  (xp.check-block-stack-size xp (xp.block-stack-ptr xp)))
+
+(define (xp.pop-block-stack xp)
+  (decf (xp.block-stack-ptr xp) xp.block-stack-entry-size))
+
+
+;;; Prefix stack manipulations
+
+(define-local-syntax (xp.prefix-ptr xp)
+  `(vector-ref (xp.prefix-stack ,xp) (xp.prefix-stack-ptr ,xp)))
+(define-local-syntax (xp.suffix-ptr xp)
+  `(vector-ref (xp.prefix-stack ,xp) (+ (xp.prefix-stack-ptr ,xp) 1)))
+(define-local-syntax (non-blank-prefix-ptr xp)
+  `(vector-ref (xp.prefix-stack ,xp) (+ (xp.prefix-stack-ptr ,xp) 2)))
+(define-local-syntax (initial-prefix-ptr xp)
+  `(vector-ref (xp.prefix-stack ,xp) (+ (xp.prefix-stack-ptr ,xp) 3)))
+(define-local-syntax (xp.section-start-line xp)
+  `(vector-ref (xp.prefix-stack ,xp) (+ (xp.prefix-stack-ptr ,xp) 4)))
+
+(define (xp.push-prefix-stack xp)
+  (let ((old-prefix 0)
+	(old-suffix 0)
+	(old-non-blank 0))
+    (when (not (negative? (xp.prefix-stack-ptr xp)))
+      (setf old-prefix (xp.prefix-ptr xp))
+      (setf old-suffix (xp.suffix-ptr xp))
+      (setf  old-non-blank (non-blank-prefix-ptr xp)))
+    (incf (xp.prefix-stack-ptr xp) xp.prefix-stack-entry-size)
+    (xp.check-prefix-stack-size xp (xp.prefix-stack-ptr xp))
+    (setf (xp.prefix-ptr xp) old-prefix)
+    (setf (xp.suffix-ptr xp) old-suffix)
+    (setf (non-blank-prefix-ptr xp) old-non-blank)))
+
+(define (xp.pop-prefix-stack xp)
+  (decf (xp.prefix-stack-ptr xp) xp.prefix-stack-entry-size))
+
+
+;;; The queue entries have several parts:
+;;; QTYPE one of :NEWLINE/:IND/:START-BLOCK/:END-BLOCK
+;;; QKIND :LINEAR/:MISER/:FILL/:MANDATORY or :UNCONDITIONAL/:FRESH
+;;;  or :BLOCK/:CURRENT
+;;; QPOS total position corresponding to this entry
+;;; QDEPTH depth in blocks of this entry.
+;;; QEND offset to entry marking end of section this entry starts.
+;;   (NIL until known.)
+;;;  Only :start-block and non-literal :newline entries can start sections.
+;;; QOFFSET offset to :END-BLOCK for :START-BLOCK (NIL until known).
+;;; QARG for :IND indentation delta
+;;;      for :START-BLOCK suffix in the block if any.
+;;;                       or if per-line-prefix then cons of suffix and
+;;;                       per-line-prefix.
+;;;      for :END-BLOCK suffix for the block if any.
+
+(define-local-syntax (xp.qtype   xp index)
+  `(vector-ref (xp.queue ,xp) ,index))
+(define-local-syntax (xp.qkind   xp index)
+  `(vector-ref (xp.queue ,xp) (1+ ,index)))
+(define-local-syntax (xp.qpos    xp index)
+  `(vector-ref (xp.queue ,xp) (+ ,index 2)))
+(define-local-syntax (xp.qdepth  xp index)
+  `(vector-ref (xp.queue ,xp) (+ ,index 3)))
+(define-local-syntax (xp.qend    xp index)
+  `(vector-ref (xp.queue ,xp) (+ ,index 4)))
+(define-local-syntax (xp.qoffset xp index)
+  `(vector-ref (xp.queue ,xp) (+ ,index 5)))
+(define-local-syntax (xp.qarg    xp index)
+  `(vector-ref (xp.queue ,xp) (+ ,index 6)))
+
+;;; we shift the queue over rather than using a circular queue because
+;;; that works out to be a lot faster in practice.  Note, short printout
+;;; does not ever cause a shift, and even in long printout, the queue is
+;;; shifted left for free every time it happens to empty out.
+
+(define (xp.enqueue xp type kind . maybe-arg)
+  (incf (xp.qright xp) xp.queue-entry-size)
+  (when (> (xp.qright xp) (- xp.queue-min-size xp.queue-entry-size))
+    (vector-replace (xp.queue xp) (xp.queue xp) 0 (xp.qleft xp) (xp.qright xp))
+    (setf (xp.qright xp) (- (xp.qright xp) (xp.qleft xp)))
+    (setf (xp.qleft xp) 0))
+  (xp.check-queue-size xp (xp.qright xp))
+  (setf (xp.qtype xp (xp.qright xp)) type)
+  (setf (xp.qkind xp (xp.qright xp)) kind)
+  (setf (xp.qpos xp (xp.qright xp)) (xp.tp<-bp xp))
+  (setf (xp.qdepth xp (xp.qright xp)) (xp.depth-in-blocks xp))
+  (setf (xp.qend xp (xp.qright xp)) '#f)
+  (setf (xp.qoffset xp (xp.qright xp)) '#f)
+  (setf (xp.qarg xp (xp.qright xp)) (car maybe-arg)))
+
+(define-local-syntax (xp.qnext index) `(+ ,index xp.queue-entry-size))
+
+
+
+;;; Print routine for xp structures
+;;; *** this is broken, it uses unimplemented format options.
+
+(define *xp.describe-xp-streams-fully* '#f)
+
+(define (xp.describe-xp xp . maybe-stream)
+  (let ((s  (if (not (null? maybe-stream))
+		(car maybe-stream)
+		(current-output-port))))
+    (format s "#<XP stream ")
+    (if (not (xp.base-stream xp))
+	(format s "not currently in use")
+	(begin
+ 	  (format s "outputting to ~S" (xp.base-stream xp))
+	  (format s "~&buffer= ~S"
+		  (substring (xp.buffer xp) 0 (max (xp.buffer-ptr xp) 0)))
+	  (if (not (dynamic *xp.describe-xp-streams-fully*))
+	      (format s " ...")
+	      (begin
+	        (format s "~&   pos   _123456789_123456789_123456789_123456789")
+		(format s "~&depth-in-blocks= ~D linel= ~D line-no= ~D line-limit= ~D"
+			(xp.depth-in-blocks xp) (xp.linel xp)
+			(xp.line-no xp) (xp.line-limit xp))
+		(when (or (xp.char-mode xp) (not (zero? (xp.char-mode-counter xp))))
+		  (format s "~&char-mode= ~S char-mode-counter= ~D"
+			  (xp.char-mode xp) (xp.char-mode-counter xp)))
+		(unless (negative? (xp.block-stack-ptr xp))
+		  (format s "~&section-start")
+		  (do ((save (xp.block-stack-ptr xp)))
+		      ((negative? (xp.block-stack-ptr xp))
+		       (setf (xp.block-stack-ptr xp) save))
+		      (format s " ~D" (xp.section-start xp))
+		      (xp.pop-block-stack xp)))
+		(format s "~&linel= ~D charpos= ~D buffer-ptr= ~D buffer-offset= ~D"
+			(xp.linel xp) (xp.charpos xp)
+			(xp.buffer-ptr xp) (xp.buffer-offset xp))
+		(unless (negative? (xp.prefix-stack-ptr xp))
+		  (format s "~&prefix= ~S"
+			  (substring (xp.prefix xp) 0 (max (xp.prefix-ptr xp) 0)))
+		  (format s "~&suffix= ~S"
+			  (substring (xp.suffix xp) 0 (max (xp.suffix-ptr xp) 0))))
+		(unless (> (xp.qleft xp) (xp.qright xp))
+		  (format s "~&ptr type         kind           pos depth end offset arg")
+		  (do ((p (xp.qleft xp) (xp.qnext p)))
+		      ((> p (xp.qright xp)))
+		      (format s "~&~4A~13A~15A~4A~6A~4A~7A~A"
+			      (/ (- p (xp.qleft xp)) xp.queue-entry-size)
+			      (xp.qtype xp p)
+			      (if (memq (xp.qtype xp p) '(newline ind))
+				  (xp.qkind xp p)
+				  "")
+			      (xp.bp<-tp xp (xp.qpos xp p))
+			      (xp.qdepth xp p)
+			      (if (not (memq (xp.qtype xp p)
+					     '(newline start-block)))
+				  ""
+				  (and (xp.qend xp p)
+				       (/ (- (+ p (xp.qend xp p)) (xp.qleft xp))
+					  xp.queue-entry-size)))
+			      (if (not (eq? (xp.qtype xp p) 'start-block))
+				  ""
+				  (and (xp.qoffset xp p)
+				       (/ (- (+ p (xp.qoffset xp p)) (xp.qleft xp))
+					  xp.queue-entry-size)))
+			      (if (not (memq (xp.qtype xp p)
+					     '(ind start-block end-block)))
+				  ""
+				  (xp.qarg xp p)))))
+		(unless (negative? (xp.prefix-stack-ptr xp))
+		  (format s "~&initial-prefix-ptr prefix-ptr suffix-ptr non-blank start-line")
+		  (do ((save (xp.prefix-stack-ptr xp)))
+		      ((negative? (xp.prefix-stack-ptr xp))
+		       (setf (xp.prefix-stack-ptr xp) save))
+		      (format s "~& ~19A~11A~11A~10A~A"
+			      (initial-prefix-ptr xp)
+			      (xp.prefix-ptr xp)
+			      (xp.suffix-ptr xp)
+			      (non-blank-prefix-ptr xp)
+			      (xp.section-start-line xp))
+		      (xp.pop-prefix-stack xp)))))))
+    (format s ">")))
+
+
+
+;;; Allocation of XP structures
+
+;;; This maintains a list of XP structures.  We save them
+;;; so that we don't have to create new ones all of the time.
+;;; We have separate objects so that many can be in use at once
+;;; (e.g. for printing to multiple streams).
+
+(define xp.free-xps '())
+
+(define (xp.get-pretty-print-stream stream)
+  (xp.initialize-xp
+      (if (not (null? xp.free-xps))
+	  (pop xp.free-xps)
+	  (xp.make-xp-structure))
+      stream))
+
+
+;;; If you call this, the xp-stream gets efficiently recycled.
+
+(define (xp.free-pretty-print-stream xp)
+  (setf (xp.base-stream xp) '#f)
+  (if (not (memq xp xp.free-xps))
+      (push xp xp.free-xps)))
+
+
+;;; This is called to initialize things when you start pretty printing.
+
+(define (xp.initialize-xp xp stream)
+  (setf (xp.base-stream xp) stream)
+  (setf (xp.linel xp)
+	(max 0
+	     (cond ((dynamic *print-right-margin*))
+		   ((internal-output-width stream))
+		   (else (dynamic *default-right-margin*)))))
+  (setf (xp.line-limit xp) (dynamic *print-lines*))
+  (setf (xp.line-no xp) 1)
+  (setf (xp.char-mode xp) '#f)
+  (setf (xp.char-mode-counter xp) 0)
+  (setf (xp.depth-in-blocks xp) 0)
+  (setf (xp.block-stack-ptr xp) 0)
+  (setf (xp.charpos xp) (or (internal-output-position stream) 0))
+  (setf (xp.section-start xp) 0)
+  (setf (xp.buffer-ptr xp) 0)
+  (setf (xp.buffer-offset xp) (xp.charpos xp))
+  (setf (xp.qleft xp) 0)
+  (setf (xp.qright xp) (- xp.queue-entry-size))
+  (setf (xp.prefix-stack-ptr xp) (- xp.prefix-stack-entry-size))
+  xp)
+
+
+
+;;; The char-mode stuff is a bit tricky.
+;;; one can be in one of the following modes:
+;;; NIL no changes to characters output.
+;;; :UP CHAR-UPCASE used.
+;;; :DOWN CHAR-DOWNCASE used.
+;;; :CAP0 capitalize next alphanumeric letter then switch to :DOWN.
+;;; :CAP1 capitalize next alphanumeric letter then switch to :CAPW
+;;; :CAPW downcase letters.  When a word break letter found, switch to :CAP1.
+;;; It is possible for ~(~) to be nested in a format string, but note that
+;;; each mode specifies what should happen to every letter.  Therefore, inner
+;;; nested modes never have any effect.  You can just ignore them.
+
+(define (xp.push-char-mode xp new-mode)
+  (if (zero? (xp.char-mode-counter xp))
+      (setf (xp.char-mode xp) new-mode))
+  (incf (xp.char-mode-counter xp)))
+
+(define (xp.pop-char-mode xp)
+  (decf (xp.char-mode-counter xp))
+  (if (zero? (xp.char-mode-counter xp))
+      (setf (xp.char-mode xp) '#f)))
+
+
+;;; Assumes is only called when char-mode is non-nil
+
+(define (xp.handle-char-mode xp char)
+  (case (xp.char-mode xp)
+    ((CAP0)
+     (cond ((not (or (char-alphabetic? char) (char-numeric? char))) char)
+	   (else (setf (xp.char-mode xp) 'DOWN) (char-upcase char))))
+    ((CAP1)
+     (cond ((not (or (char-alphabetic? char) (char-numeric? char))) char)
+	   (else (setf (xp.char-mode xp) 'CAPW) (char-upcase char))))
+    ((CAPW)
+     (cond ((or (char-alphabetic? char) (char-numeric? char))
+	    (char-downcase char))
+	   (else (setf (xp.char-mode xp) 'CAP1) char)))
+    ((UP)
+     (char-upcase char))
+    (else
+     (char-downcase char)))) ;DOWN
+
+
+;;; All characters output are passed through the handler above.  However, 
+;;; it must be noted that on-each-line prefixes are only processed in the 
+;;; context of the first place they appear.  They stay the same later no 
+;;; matter what.  Also non-literal newlines do not count as word breaks.
+
+;;; This handles the basic outputting of characters.  note + suffix means that
+;;; the stream is known to be an XP stream, all inputs are mandatory, and no
+;;; error checking has to be done.  Suffix ++ additionally means that the
+;;; output is guaranteed not to contain a newline char.
+
+(define (xp.write-char+ char xp)
+  (if (eqv? char #\newline)
+      (xp.pprint-newline+ 'unconditional xp)
+      (xp.write-char++ char xp)))
+
+(define (xp.write-string+ mystring xp start end)
+  (let ((next-newline (string-position #\newline mystring start end)))
+    (if next-newline
+	(begin
+	  (xp.write-string++ mystring xp start next-newline)
+	  (xp.pprint-newline+ 'unconditional xp)
+	  (xp.write-string+ mystring xp (1+ next-newline) end))
+	(xp.write-string++ mystring xp start end))))
+
+
+;;; note this checks (> BUFFER-PTR LINEL) instead of (> (xp.lp<-bp) LINEL)
+;;; this is important so that when things are longer than a line they
+;;; end up getting printed in chunks of size LINEL.
+
+(define (xp.write-char++ char xp)
+  (when (> (xp.buffer-ptr xp) (xp.linel xp))
+    (xp.force-some-output xp))
+  (let ((new-buffer-end (1+ (xp.buffer-ptr xp))))
+    (xp.check-buffer-size xp new-buffer-end)
+    (if (xp.char-mode xp) (setf char (xp.handle-char-mode xp char)))
+    (setf (string-ref (xp.buffer xp) (xp.buffer-ptr xp)) char)    
+    (setf (xp.buffer-ptr xp) new-buffer-end)))
+
+(define (xp.force-some-output xp)
+  (xp.attempt-to-output xp '#f '#f)
+  (when (> (xp.buffer-ptr xp) (xp.linel xp)) ;only if printing off end of line
+    (xp.attempt-to-output xp '#t '#t)))
+
+(define (xp.write-string++ mystring xp start end)
+  (when (> (xp.buffer-ptr xp) (xp.linel xp))
+    (xp.force-some-output xp))
+  (xp.write-string+++ mystring xp start end))
+
+
+;;; never forces output; therefore safe to call from within xp.output-line.
+
+(define (xp.write-string+++ mystring xp start end) 
+  (let ((new-buffer-end (+ (xp.buffer-ptr xp) (- end start))))
+    (xp.check-buffer-size xp new-buffer-end)
+    (do ((buffer (xp.buffer xp))
+	 (i (xp.buffer-ptr xp) (1+ i))
+	 (j start (1+ j)))
+	((= j end))
+      (let ((char (string-ref mystring j)))
+	(if (xp.char-mode xp) (setf char (xp.handle-char-mode xp char)))
+	(setf (string-ref buffer i) char)))
+    (setf (xp.buffer-ptr xp) new-buffer-end)))
+
+
+(define (xp.pprint-tab+ kind colnum colinc xp)
+  (let ((indented? '#f)
+	(relative? '#f))
+    (case kind
+      ((section) (setf indented? '#t))
+      ((line-relative) (setf relative? '#t))
+      ((section-relative) (setf indented? '#t) (setf relative? '#t)))
+    (let* ((current
+	     (if (not indented?)
+		 (xp.lp<-bp xp)
+		 (- (xp.tp<-bp xp) (xp.section-start xp))))
+	   (new
+	     (if (zero? colinc)
+		 (if relative? (+ current colnum) (max colnum current))
+		 (cond (relative?
+			(* colinc
+			   (quotient (+ current colnum colinc -1) colinc)))
+		       ((> colnum current) colnum)
+		       (else
+			(+ colnum
+			   (* colinc
+			      (quotient (+ current (- colnum) colinc)
+					colinc)))))))
+	   (end (- new current)))
+      (when (positive? end)
+	(if (xp.char-mode xp) (xp.handle-char-mode xp #\space))
+	(let ((end (+ (xp.buffer-ptr xp) end)))
+	  (xp.check-buffer-size xp end)
+	  (string-fill (xp.buffer xp) #\space (xp.buffer-ptr xp) end)
+	  (setf (xp.buffer-ptr xp) end))))))
+
+
+;;; note following is smallest number >= x that is a multiple of colinc
+;;;  (* colinc (quotient (+ x (1- colinc)) colinc))
+
+
+(define (xp.pprint-newline+ kind xp)
+  (xp.enqueue xp 'newline kind)
+  (do ((ptr (xp.qleft xp) (xp.qnext ptr)))    ;find sections we are ending
+      ((not (< ptr (xp.qright xp))))	;all but last
+    (when (and (not (xp.qend xp ptr))
+	       (not (> (xp.depth-in-blocks xp) (xp.qdepth xp ptr)))
+	       (memq (xp.qtype xp ptr) '(newline start-block)))
+      (setf (xp.qend xp ptr) (- (xp.qright xp) ptr))))
+  (setf (xp.section-start xp) (xp.tp<-bp xp))
+  (when (and (memq kind '(fresh unconditional)) (xp.char-mode xp))
+    (xp.handle-char-mode xp #\newline))
+  (when (memq kind '(fresh unconditional mandatory))
+    (xp.attempt-to-output xp '#t '#f)))
+
+
+(define (xp.start-block xp prefix-string on-each-line? suffix-string)
+  (xp.write-prefix-suffix prefix-string xp)
+  (if (and (xp.char-mode xp) on-each-line?)
+      (setf prefix-string
+	    (substring (xp.buffer xp)
+		       (- (xp.buffer-ptr xp) (string-length prefix-string))
+		       (xp.buffer-ptr xp))))
+  (xp.push-block-stack xp)
+  (xp.enqueue xp 'start-block '#f
+	   (if on-each-line? (cons suffix-string prefix-string) suffix-string))
+  (incf (xp.depth-in-blocks xp))	      ;must be after enqueue
+  (setf (xp.section-start xp) (xp.tp<-bp xp)))
+
+
+(define (xp.end-block xp suffix)
+  (unless (and (dynamic *xp.abbreviation-happened*)
+	       (eqv? (dynamic *xp.abbreviation-happened*)
+		     (dynamic *print-lines*)))
+    (xp.write-prefix-suffix suffix xp)
+    (decf (xp.depth-in-blocks xp))
+    (xp.enqueue xp 'end-block '#f suffix)
+    (block foundit
+      (do ((ptr (xp.qleft xp) (xp.qnext ptr))) ;look for start of block we are ending
+	  ((not (< ptr (xp.qright xp))))    ;all but last
+	  (when (and (= (xp.depth-in-blocks xp) (xp.qdepth xp ptr))
+		     (eq? (xp.qtype xp ptr) 'start-block)
+		     (not (xp.qoffset xp ptr)))
+	    (setf (xp.qoffset xp ptr) (- (xp.qright xp) ptr))
+	    (return-from foundit '#f)))	;can only be 1
+      )
+    (xp.pop-block-stack xp)))
+
+(define (xp.write-prefix-suffix mystring xp)
+  (when mystring
+    (xp.write-string++ mystring xp 0 (string-length mystring))))
+
+(define (xp.pprint-indent+ kind n xp)
+  (xp.enqueue xp 'ind kind n))
+
+
+;;; attempt-to-output scans the queue looking for things it can do.
+;;; it keeps outputting things until the queue is empty, or it finds
+;;; a place where it cannot make a decision yet.
+;;; If flush-out? is T and force-newlines? is NIL then the buffer,
+;;; prefix-stack, and queue will be in an inconsistent state after the call.
+;;; You better not call it this way except as the last act of outputting.
+
+
+(define-local-syntax (xp.maybe-too-large xp Qentry)
+  `(let ((limit (xp.linel ,xp)))
+     (when (eqv? (xp.line-limit ,xp) (xp.line-no ,xp)) ;prevents suffix overflow
+       (decf limit 2) ;3 for " .." minus 1 for space (heuristic)
+       (when (not (negative? (xp.prefix-stack-ptr ,xp)))
+	 (decf limit (xp.suffix-ptr ,xp))))
+     (cond ((xp.qend ,xp ,Qentry)
+	    (> (xp.lp<-tp ,xp (xp.qpos ,xp (+ ,Qentry (xp.qend ,xp ,Qentry)))) limit))
+	   ((or force-newlines? (> (xp.lp<-bp ,xp) limit))
+	    '#t)
+	   (else ;wait until later to decide.
+	    (return-from attempt-to-output '#f)))))
+
+(define-local-syntax (xp.misering? xp)
+  `(and (dynamic *print-miser-width*)
+	(<= (- (xp.linel ,xp) (initial-prefix-ptr ,xp))
+	    (dynamic *print-miser-width*))))
+
+(define (xp.attempt-to-output xp force-newlines? flush-out?)
+  (block attempt-to-output
+    (do ()
+	((> (xp.qleft xp) (xp.qright xp))
+	 (setf (xp.qleft xp) 0)
+	 (setf (xp.qright xp) (- xp.queue-entry-size))) ;saves shifting
+      (case (xp.qtype xp (xp.qleft xp))
+	    ((ind)
+	     (unless (xp.misering? xp)
+	       (xp.set-indentation-prefix
+		   xp
+		   (case (xp.qkind xp (xp.qleft xp))
+			 ((block)
+			  (+ (initial-prefix-ptr xp) (xp.qarg xp (xp.qleft xp))))
+			 (else ; current
+			  (+ (xp.lp<-tp xp (xp.qpos xp (xp.qleft xp)))
+			     (xp.qarg xp (xp.qleft xp)))))))
+	     (setf (xp.qleft xp) (xp.qnext (xp.qleft xp))))
+	    ((start-block)
+	     (cond ((xp.maybe-too-large xp (xp.qleft xp))
+		    (xp.push-prefix-stack xp)
+		    (setf (initial-prefix-ptr xp) (xp.prefix-ptr xp))
+		    (xp.set-indentation-prefix
+		        xp (xp.lp<-tp xp (xp.qpos xp (xp.qleft xp))))
+		    (let ((arg (xp.qarg xp (xp.qleft xp))))
+		      (when (pair? arg) (xp.set-prefix xp (cdr arg)))
+		      (setf (initial-prefix-ptr xp) (xp.prefix-ptr xp))
+		      (cond ((not (list? arg)) (xp.set-suffix xp arg))
+			    ((car arg) (xp.set-suffix xp (car arg)))))
+		    (setf (xp.section-start-line xp) (xp.line-no xp)))
+		   (else (incf (xp.qleft xp) (xp.qoffset xp (xp.qleft xp)))))
+	     (setf (xp.qleft xp) (xp.qnext (xp.qleft xp))))
+	    ((end-block)
+	     (xp.pop-prefix-stack xp)
+	     (setf (xp.qleft xp) (xp.qnext (xp.qleft xp))))
+	    (else ; newline
+	     (when (case (xp.qkind xp (xp.qleft xp))
+			 ((fresh) (not (zero? (xp.lp<-bp xp))))
+			 ((miser) (xp.misering? xp))
+			 ((fill) (or (xp.misering? xp)
+				      (> (xp.line-no xp) (xp.section-start-line xp))
+				      (xp.maybe-too-large xp (xp.qleft xp))))
+			 (else '#t)) ;(linear unconditional mandatory) 
+	       (xp.output-line xp (xp.qleft xp))
+	       (xp.setup-for-next-line xp (xp.qleft xp)))
+	     (setf (xp.qleft xp) (xp.qnext (xp.qleft xp)))))))
+  (when flush-out? (xp.flush xp)))
+
+
+;;; this can only be called last!
+
+(define (xp.flush xp)
+  (unless (dynamic *xp.locating-circularities*)
+    (internal-write-string (xp.buffer xp) (xp.base-stream xp) 0 (xp.buffer-ptr xp)))
+  (incf (xp.buffer-offset xp) (xp.buffer-ptr xp))
+  (incf (xp.charpos xp) (xp.buffer-ptr xp))
+  (setf (xp.buffer-ptr xp) 0))
+
+
+;;; This prints out a line of stuff.
+
+(define (xp.output-line xp Qentry)
+  (let* ((out-point (xp.bp<-tp xp (xp.qpos xp Qentry)))
+	 (last-non-blank (string-position-not-from-end
+			     #\space (xp.buffer xp) 0 out-point))
+	 (end (cond ((memq (xp.qkind xp Qentry) '(fresh unconditional))
+		     out-point)
+		    (last-non-blank (1+ last-non-blank))
+		    (else 0)))
+	 (line-limit-exit (and (xp.line-limit xp)
+			       (not (> (xp.line-limit xp) (xp.line-no xp))))))
+    (when line-limit-exit
+      (setf (xp.buffer-ptr xp) end)          ;truncate pending output.
+      (xp.write-string+++ " .." xp 0 3)
+      (string-nreverse (xp.suffix xp) 0 (xp.suffix-ptr xp))
+      (xp.write-string+++ (xp.suffix xp) xp 0 (xp.suffix-ptr xp))
+      (setf (xp.qleft xp) (xp.qnext (xp.qright xp)))
+      (setf (dynamic *xp.abbreviation-happened*) (dynamic *print-lines*))
+      (funcall (dynamic *xp.line-limit-abbreviation-exit*) '#t))
+    (incf (xp.line-no xp))
+    (unless (dynamic *xp.locating-circularities*)
+      (internal-write-string (xp.buffer xp) (xp.base-stream xp) 0 end)
+      (newline (xp.base-stream xp)))))
+
+(define (xp.setup-for-next-line xp Qentry)
+  (let* ((out-point (xp.bp<-tp xp (xp.qpos xp Qentry)))
+	 (prefix-end
+	   (cond ((memq (xp.qkind xp Qentry) '(unconditional fresh))
+		  (non-blank-prefix-ptr xp))
+		 (else (xp.prefix-ptr xp))))
+	 (change (- prefix-end out-point)))
+    (setf (xp.charpos xp) 0)
+    (when (positive? change)                  ;almost never happens
+      (xp.check-buffer-size xp (+ (xp.buffer-ptr xp) change)))
+    (string-replace (xp.buffer xp) (xp.buffer xp)
+		    prefix-end out-point (xp.buffer-ptr xp))
+    (string-replace (xp.buffer xp) (xp.prefix xp) 0 0 prefix-end)
+    (incf (xp.buffer-ptr xp) change)
+    (decf (xp.buffer-offset xp) change)
+    (when (not (memq (xp.qkind xp Qentry) '(unconditional fresh)))
+      (setf (xp.section-start-line xp) (xp.line-no xp)))))
+
+(define (xp.set-indentation-prefix xp new-position)
+  (let ((new-ind (max (non-blank-prefix-ptr xp) new-position)))
+    (setf (xp.prefix-ptr xp) (initial-prefix-ptr xp))
+    (xp.check-prefix-size xp new-ind)
+    (when (> new-ind (xp.prefix-ptr xp))
+      (string-fill (xp.prefix xp) #\space (xp.prefix-ptr xp) new-ind))
+    (setf (xp.prefix-ptr xp) new-ind)))
+
+(define (xp.set-prefix xp prefix-string)
+  (let ((end  (string-length prefix-string)))
+    (string-replace (xp.prefix xp) prefix-string
+		    (- (xp.prefix-ptr xp) end) 0 end))
+  (setf (non-blank-prefix-ptr xp) (xp.prefix-ptr xp)))
+
+(define (xp.set-suffix xp suffix-string)
+  (let* ((end (string-length suffix-string))
+	 (new-end (+ (xp.suffix-ptr xp) end)))
+    (xp.check-suffix-size xp new-end)
+    (do ((i (1- new-end) (1- i))
+	 (j 0 (1+ j)))
+	((= j end))
+      (setf (string-ref (xp.suffix xp) i) (string-ref suffix-string j)))
+    (setf (xp.suffix-ptr xp) new-end)))
+
+
+;;;=====================================================================
+;;; Basic interface functions
+;;;=====================================================================
+
+;;; The internal functions in this file
+;;; use the '+' forms of these functions directly (which is faster) because,
+;;; they do not need error checking of fancy stream coercion.  The '++' forms
+;;; additionally assume the thing being output does not contain a newline.
+
+(define (write object . maybe-stream)
+  (let ((stream  (if (not (null? maybe-stream))
+		     (car maybe-stream)
+		     (current-output-port))))
+    (cond ((xp.xp-structure-p stream)
+	   (xp.write+ object stream))
+	  ((xp.get-printer object)
+	   (xp.initiate-xp-printing
+	     (lambda (s o) (xp.write+ o s))
+	     stream
+	     object))
+	  (else
+	   (internal-write object stream)))))
+
+(define (xp.maybe-initiate-xp-printing fn stream . args)
+  (if (xp.xp-structure-p stream)
+      (apply fn stream args)
+      (apply (function xp.initiate-xp-printing) fn stream args)))
+
+(define (xp.initiate-xp-printing fn stream . args)
+  (dynamic-let ((*xp.abbreviation-happened*
+		    '#f)
+		(*xp.locating-circularities*
+		    (if (dynamic *print-circle*)
+			0
+			'#f))
+		(*xp.circularity-hash-table*
+		    (if (dynamic *print-circle*)
+			(make-table)
+			'#f))
+		(*xp.parents*
+		    (if (not (dynamic *print-shared*))
+			(list '#f)
+			'()))			;*** is this right?
+		(*xp.current-level*
+		    0)
+		(*xp.current-length*
+		    0))
+    (let ((result  (xp.xp-print fn stream args)))
+      (when (dynamic *xp.abbreviation-happened*)
+	(setf args (list-copy args))
+	(setf (dynamic *last-abbreviated-printing*)
+	      (lambda maybe-stream
+		(let ((stream  (if (not (null? maybe-stream))
+				   (car maybe-stream)
+				   stream)))
+		  (apply (function xp.maybe-initiate-xp-printing)
+			 fn stream args)))))
+      result)))
+
+(define (xp.xp-print fn stream args)
+  (let ((result  (xp.do-xp-printing fn stream args)))
+    (when (dynamic *xp.locating-circularities*)
+      (setf (dynamic *xp.locating-circularities*) '#f)
+      (setf (dynamic *xp.abbreviation-happened*) '#f)
+      (setf (dynamic *xp.parents*) '())
+      (setf result (xp.do-xp-printing fn stream args)))
+    result))
+
+(define (xp.do-xp-printing fn stream args)
+  (let ((xp (xp.get-pretty-print-stream stream))
+	(result '#f))
+    (dynamic-let ((*xp.current-level* 0))
+      (let/cc catch
+        (dynamic-let ((*xp.line-limit-abbreviation-exit* catch))
+	  (xp.start-block xp '#f '#f '#f)
+	  (setf result (apply fn xp args))
+	  (xp.end-block xp '#f)))
+      (when (and (dynamic *xp.locating-circularities*)
+		 (zero? (dynamic *xp.locating-circularities*)) ;No circularities.
+		 (= (xp.line-no xp) 1)	     	;Didn't suppress line.
+		 (zero? (xp.buffer-offset xp)))	;Didn't suppress partial line.
+	(setf (dynamic *xp.locating-circularities*) '#f))	;print what you have got.
+      (when (let/cc catch
+	      (dynamic-let ((*xp.line-limit-abbreviation-exit* catch))
+	        (xp.attempt-to-output xp '#f '#t)
+		'#f))
+	(xp.attempt-to-output xp '#t '#t))
+      (xp.free-pretty-print-stream xp)
+      result)))
+
+
+(define (xp.write+ object xp)
+  (dynamic-let ((*xp.parents* (dynamic *xp.parents*)))
+    (unless (and (dynamic *xp.circularity-hash-table*)
+		 (eq? (xp.circularity-process xp object '#f) 'subsequent))
+      (when (and (dynamic *xp.circularity-hash-table*) (pair? object))
+	;; Must do this to avoid additional circularity detection by
+        ;; pprint-logical-block; otherwise you get stuff like #1=#1#.
+	(setf object (cons (car object) (cdr object))))
+      (funcall (or (xp.get-printer object) (function xp.print-default))
+	       object
+	       xp))
+    object))
+
+
+
+(define (xp.print-default object xp)
+  (let ((stuff (internal-write-to-string object)))
+    (xp.write-string+ stuff xp 0 (string-length stuff))))
+
+
+;;; It is vital that this function be called EXACTLY once for each occurrence 
+;;;   of each thing in something being printed.
+;;; Returns nil if printing should just continue on.
+;;;   Either it is not a duplicate, or we are in the first pass and do not 
+;;;   know.
+;;; returns :FIRST if object is first occurrence of a DUPLICATE.
+;;;   (This can only be returned on a second pass.)
+;;;   After an initial code (printed by this routine on the second pass)
+;;;   printing should continue on for the object.
+;;; returns :SUBSEQUENT if second or later occurrence.
+;;;   Printing is all taken care of by this routine.
+
+;;; Note many (maybe most) lisp implementations have characters and small 
+;;; numbers represented in a single word so that the are always eq when 
+;;; they are equal and the reader takes care of properly sharing them 
+;;; (just as it does with symbols).  Therefore, we do not want circularity 
+;;; processing applied to them.  However, some kinds of numbers 
+;;; (e.g., bignums) undoubtedly are complex structures that the reader 
+;;; does not share.  However, they cannot have circular pointers in them
+;;; and it is therefore probably a waste to do circularity checking on them.  
+;;; In any case, it is not clear that it easy to tell exactly what kinds of 
+;;; numbers a given implementation is going to have the reader 
+;;; automatically share.
+
+(define (xp.circularity-process xp object interior-cdr?)
+  (unless (or (number? object)
+	      (char? object)
+	      (and (symbol? object) (not (gensym? object))))
+    (let ((id (table-entry (dynamic *xp.circularity-hash-table*) object)))
+      (if (dynamic *xp.locating-circularities*)
+	  ;; This is the first pass.
+	  (cond ((not id)	;never seen before
+		 (when (not (null? (dynamic *xp.parents*)))
+		   (push object (dynamic *xp.parents*)))
+		 (setf (table-entry (dynamic *xp.circularity-hash-table*) object)
+		       0)
+		 '#f)
+		((zero? id) ;possible second occurrence
+		 (cond ((or (null? (dynamic *xp.parents*))
+			    (memq object (dynamic *xp.parents*)))
+			(setf (table-entry
+			          (dynamic *xp.circularity-hash-table*) object)
+			      (incf (dynamic *xp.locating-circularities*)))
+			'subsequent)
+		       (else '#f)))
+		(else 'subsequent));third or later occurrence
+	  ;; This is the second pass.
+	  (cond ((or (not id)	;never seen before (note ~@* etc. conses)
+		     (zero? id));no duplicates
+		 '#f)
+		((positive? id) ; first occurrence
+		 (cond (interior-cdr?
+			(decf (dynamic *xp.current-level*))
+			(xp.write-string++ ". #" xp 0 3))
+		       (else (xp.write-char++ #\# xp)))
+		 (xp.print-integer id xp)
+		 (xp.write-char++ #\= xp)
+		 (setf (table-entry (dynamic *xp.circularity-hash-table*) object)
+		       (- id))
+		 'first)
+		(else
+		 (if interior-cdr?
+		     (xp.write-string++ ". #" xp 0 3)
+		     (xp.write-char++ #\# xp))
+		 (xp.print-integer(- id) xp)
+		 (xp.write-char++ #\# xp)
+		 'subsequent))))))
+
+
+;;; Here are all the standard Common Lisp printing functions.
+
+(define (print object . maybe-stream)
+  (let ((stream  (if (not (null? maybe-stream))
+		     (car maybe-stream)
+		     (current-output-port))))
+    (dynamic-let ((*print-escape* '#t))
+      (terpri stream)
+      (write object stream)
+      (write-char #\space stream)
+      object)))
+
+(define (prin1 object . maybe-stream)
+  (let ((stream  (if (not (null? maybe-stream))
+		     (car maybe-stream)
+		     (current-output-port))))
+    (dynamic-let ((*print-escape* '#t))
+      (write object stream)
+      object)))
+
+(define (princ object . maybe-stream)
+  (let ((stream  (if (not (null? maybe-stream))
+		     (car maybe-stream)
+		     (current-output-port))))
+    (dynamic-let ((*print-escape* '#f))
+      (write object stream)
+      object)))
+
+(define (display object . maybe-stream)
+  (apply (function princ) object maybe-stream))
+
+
+(define (pprint object . maybe-stream)
+  (let ((stream  (if (not (null? maybe-stream))
+		     (car maybe-stream)
+		     (current-output-port))))
+    (dynamic-let ((*print-escape* '#t)
+		  (*print-pretty* '#t))
+      (terpri stream)
+      (write object stream)
+      (values))))
+
+(define (prin1-to-string object)
+  (call-with-output-string
+      (lambda (stream)
+	(dynamic-let ((*print-escape* '#t))
+	  (write object stream)))))
+
+(define (princ-to-string object)
+  (call-with-output-string
+      (lambda (stream)
+	(dynamic-let ((*print-escape* '#f))
+	  (write object stream)))))
+
+
+
+(define (write-char char . maybe-stream)
+  (let ((stream  (if (not (null? maybe-stream))
+		     (car maybe-stream)
+		     (current-output-port))))
+    (if (xp.xp-structure-p stream)
+	(xp.write-char+ char stream)
+	(internal-write-char char stream))
+    char))
+
+(define (write-string mystring . maybe-stream-start-end)
+  (let* ((stream  (if (not (null? maybe-stream-start-end))
+		      (car maybe-stream-start-end)
+		      (current-output-port)))
+	 (start   (if (not (null? (cdr maybe-stream-start-end)))
+		      (cadr maybe-stream-start-end)
+		      0))
+	 (end     (if (not (null? (cddr maybe-stream-start-end)))
+		      (caddr maybe-stream-start-end)
+		      (string-length mystring))))
+    (if (xp.xp-structure-p stream)
+	(xp.write-string+ mystring stream start end)
+	(internal-write-string mystring stream start end))
+    mystring))
+
+(define (write-line mystring . maybe-stream-start-end)
+  (let* ((stream  (if (not (null? maybe-stream-start-end))
+		      (car maybe-stream-start-end)
+		      (current-output-port)))
+	 (start   (if (not (null? (cdr maybe-stream-start-end)))
+		      (cadr maybe-stream-start-end)
+		      0))
+	 (end     (if (not (null? (cddr maybe-stream-start-end)))
+		      (caddr maybe-stream-start-end)
+		      (string-length mystring))))
+    (if (xp.xp-structure-p stream)
+	(begin
+	  (xp.write-string+ mystring stream start end)
+	  (xp.pprint-newline+ 'unconditional stream))
+	(begin 
+	  (internal-write-string mystring stream start end)
+	  (internal-newline stream)))
+    mystring))
+
+(define (terpri . maybe-stream)
+  (let ((stream  (if (not (null? maybe-stream))
+		     (car maybe-stream)
+		     (current-output-port))))
+    (if (xp.xp-structure-p stream)
+	(xp.pprint-newline+ 'unconditional stream)
+	(internal-newline stream))
+    '#f))
+
+(define (newline . maybe-stream)
+  (apply (function terpri) maybe-stream))
+
+
+;;; This has to violate the XP data abstraction and fool with internal
+;;; stuff, in order to find out the right info to return as the result.
+
+(define (fresh-line . maybe-stream)
+  (let ((stream  (if (not (null? maybe-stream))
+		     (car maybe-stream)
+		     (current-output-port))))
+    (cond ((xp.xp-structure-p stream)
+	   (xp.attempt-to-output stream '#t '#t) ;ok because we want newline
+	   (when (not (zero? (xp.lp<-bp stream)))
+	     (xp.pprint-newline+ 'fresh stream)
+	     '#t))
+	  (else
+	   (internal-fresh-line stream)))))
+
+
+;;; Each of these causes the stream to be pessimistic and insert
+;;; newlines wherever it might have to, when forcing the partial output
+;;; out.  This is so that things will be in a consistent state if
+;;; output continues to the stream later.
+
+(define (finish-output . maybe-stream)
+  (let ((stream  (if (not (null? maybe-stream))
+		     (car maybe-stream)
+		     (current-output-port))))
+    (if (xp.xp-structure-p stream)
+	(xp.attempt-to-output stream '#t '#t)
+	(internal-finish-output stream))
+    '#f))
+
+(define (force-output . maybe-stream)
+  (let ((stream  (if (not (null? maybe-stream))
+		     (car maybe-stream)
+		     (current-output-port))))
+    (if (xp.xp-structure-p stream)
+	(xp.attempt-to-output stream '#t '#t)
+	(internal-force-output stream))
+    '#f))
+
+(define (clear-output . maybe-stream)
+  (let ((stream  (if (not (null? maybe-stream))
+		     (car maybe-stream)
+		     (current-output-port))))
+    (if (xp.xp-structure-p stream)
+	(dynamic-let ((*xp.locating-circularities* 0)) ;hack to prevent visible output
+	  (xp.attempt-to-output stream '#t '#t)
+	(internal-clear-output stream)))
+    '#f))
+   
+
+
+
+;;;=====================================================================
+;;; Functional interface to dynamic formatting
+;;;=====================================================================
+
+;;; The internal functions in this file, and the (formatter "...") expansions
+;;; use the '+' forms of these functions directly (which is faster) because,
+;;; they do not need error checking or fancy stream coercion.  The '++' forms
+;;; additionally assume the thing being output does not contain a newline.
+
+(define-syntax (pprint-logical-block stream-symbol-stuff . body)
+  (let* ((stream-symbol    (car stream-symbol-stuff))
+	 (mylist             (cadr stream-symbol-stuff))
+	 (rest             (cddr stream-symbol-stuff))
+	 (prefix           (if (not (null? rest)) (pop rest) ""))
+	 (suffix           (if (not (null? rest)) (pop rest) ""))
+	 (per-line?        (if (not (null? rest)) (pop rest) '#f)))
+    `(xp.maybe-initiate-xp-printing
+       (lambda (,stream-symbol)
+	 (let ((+l ,mylist)
+	       (+p ,prefix)
+	       (+s ,suffix)
+	       (+x ,stream-symbol))
+	   (xp.pprint-logical-block+ (+x +l +p +s ,per-line? '#t '#f)
+	     ,@body
+	     '#f)))
+       ,stream-symbol)))
+
+
+;;; Assumes var and args must be variables.  Other arguments must be literals 
+;;; or variables.
+
+(define-syntax (xp.pprint-logical-block+ stuff . body)
+  (let* ((var            (pop stuff))
+	 (args           (pop stuff))
+	 (prefix         (pop stuff))
+	 (suffix         (pop stuff))
+	 (per-line?      (pop stuff)))
+    `(unless (xp.check-abbreviation ,var ,args)
+       (dynamic-let ((*xp.current-level* (1+ (dynamic *xp.current-level*)))
+		     (*xp.current-length* -1)
+		     (*xp.parents* (dynamic *xp.parents*)))
+	 (block logical-block
+	   (if (dynamic *print-pretty*)
+	       (xp.start-block ,var ,prefix ,per-line? ,suffix)
+	       (xp.write-prefix-suffix ,prefix ,var))
+	   (unwind-protect
+	       (begin ,@body)
+	     (if (dynamic *print-pretty*)
+		 (xp.end-block ,var ,suffix)
+		 (xp.write-prefix-suffix ,suffix ,var))))))
+    ))
+
+(define (xp.check-abbreviation xp object)
+  (cond ((and (dynamic *print-level*)
+	      (>= (dynamic *xp.current-level*)
+		  (dynamic *print-level*)))
+	 (xp.write-char++ #\# XP)
+	 (setf (dynamic *xp.abbreviation-happened*) '#t)
+	 '#t)
+	((and (dynamic *xp.circularity-hash-table*)
+	      (eq? (xp.circularity-process xp object '#f) 'subsequent))
+	 '#t)
+	(else '#f)))
+
+
+(define-syntax (pprint-pop)
+  `(xp.pprint-pop+ +l +x))
+
+(define-syntax (xp.pprint-pop+ args xp)
+  `(if (xp.pprint-pop-check+ ,args ,xp)
+       (return-from logical-block '#f)
+       (if (null? ,args) '() (pop ,args))))
+
+(define (xp.pprint-pop-check+ args xp)
+  (incf (dynamic *xp.current-length*))
+  (cond ((not (or (pair? args) (null? args)))
+	 ;; must be first to supersede length abbreviation
+	 (xp.write-string++ ". " xp 0 2)
+	 (xp.write+ args xp)
+	 '#t)
+	((and (dynamic *print-length*)
+	      (not (< *xp.current-length* (dynamic *print-length*))))
+	 ;; must supersede circularity check
+	 (xp.write-string++ "..." xp 0 3)
+	 (setf (dynamic *xp.abbreviation-happened*) '#t)
+	 '#t)
+	((and (dynamic *xp.circularity-hash-table*)
+	      (not (zero? *xp.current-length*)))
+	 (case (xp.circularity-process xp args '#t)
+	       ((first)
+		(xp.write+ (cons (car args) (cdr args)) xp) '#t)
+	       ((subsequent)
+		'#t)
+	       (else
+		'#f)))
+	(else
+	 '#f)))
+
+(define-syntax (pprint-exit-if-list-exhausted)
+  `(xp.pprint-exit-if-list-exhausted+ +l))
+
+(define-syntax (xp.pprint-exit-if-list-exhausted+ mylist)
+  `(if (null? ,mylist) (return-from logical-block '#f)))
+
+
+(define (pprint-newline kind . maybe-stream)
+  (let ((stream  (if (not (null? maybe-stream))
+		     (car maybe-stream)
+		     (current-output-port))))
+    (when (not (memq kind '(linear miser fill mandatory)))
+      (error "Invalid KIND argument ~A to PPRINT-NEWLINE" kind))
+    (when (and (xp.xp-structure-p stream) (dynamic *print-pretty*))
+      (xp.pprint-newline+ kind stream))
+    '#f))
+
+(define (pprint-indent relative-to n . maybe-stream)
+  (let ((stream  (if (not (null? maybe-stream))
+		     (car maybe-stream)
+		     (current-output-port))))
+    (when (not (memq relative-to '(block current)))
+      (error "Invalid KIND argument ~A to PPRINT-INDENT" relative-to))
+    (when (and (xp.xp-structure-p stream) (dynamic *print-pretty*))
+      (xp.pprint-indent+ relative-to n stream))
+    '#f))
+
+(define (pprint-tab kind colnum colinc . maybe-stream)
+  (let ((stream  (if (not (null? maybe-stream))
+		     (car maybe-stream)
+		     (current-output-port))))
+    (when (not (memq kind '(line section line-relative section-relative)))
+      (error "Invalid KIND argument ~A to PPRINT-TAB" kind))
+    (when (and (xp.xp-structure-p stream) (dynamic *print-pretty*))
+      (xp.pprint-tab+ kind colnum colinc stream))
+    '#f))
+
+
+
+
+;;;=====================================================================
+;;; Standard print dispatch function
+;;;=====================================================================
+
+
+(define (xp.print-null object xp)
+  (declare (ignore object))
+  (xp.write-string+ "()" xp 0 2))
+
+(define (xp.print-true object xp)
+  (declare (ignore object))
+  (xp.write-string+ "#t" xp 0 2))
+
+(define (xp.print-false object xp)
+  (declare (ignore object))
+  (xp.write-string+ "#f" xp 0 2))
+
+(define (xp.print-symbol object xp)
+  (if (dynamic *print-escape*)
+      (xp.print-default object xp)
+      (let ((mystring  (symbol->string object)))
+	(xp.write-string+ mystring xp 0 (string-length mystring)))))
+
+(define (xp.print-number object xp)
+  (if (and (integer? object)
+	   (eqv? (dynamic *print-base*) 10)
+	   (not (dynamic *print-radix*)))
+      (begin
+        (when (negative? object)
+	  (xp.write-char++ #\- xp)
+	  (setf object (- object)))
+	(xp.print-integer object xp))
+      (xp.print-default object xp)))
+
+(define (xp.print-integer n xp)
+  (let ((quot  (quotient n 10))
+	(rem   (remainder n 10)))
+    (unless (zero? quot)
+      (xp.print-integer quot xp))
+    (xp.write-char++ (string-ref "0123456789" rem) xp)))
+
+(define (xp.print-string object xp)
+  (if (dynamic *print-escape*)
+      (begin
+        (xp.write-char++ #\" xp)
+	(do ((i 0 (1+ i))
+	     (n (string-length object)))
+	    ((= i n))
+	    (let ((c  (string-ref object i)))
+	      (if (or (char=? c #\") (char=? c #\\))
+		  (xp.write-char++ #\\ xp))
+	      (xp.write-char++ c xp)))
+	(xp.write-char++ #\" xp))
+      (xp.write-string+ object xp 0 (string-length object))))
+
+(define (xp.print-character object xp)
+  (if (dynamic *print-escape*)
+      (let ((name  (char-name object)))
+        (xp.write-char++ #\# xp)
+	(xp.write-char++ #\\ xp)
+	(if name
+	    (xp.write-string++ name xp 0 (string-length name))
+	    (xp.write-char++ object xp)))
+      (xp.write-char+ object xp)))
+
+(define (xp.print-vector object xp)
+  (let* ((pretty?  (dynamic *print-pretty*))
+	 (end      (vector-length object)))
+    (pprint-logical-block (xp '() "#(" ")")
+      (do ((i 0 (1+ i)))
+	  ((eqv? i end) '#f)
+	  (when (not (eqv? i 0))
+	    (xp.write-char++ #\space xp)
+	    (if pretty?
+		(xp.pprint-newline+ 'fill xp)))
+	  (pprint-pop)
+	  (xp.write+ (vector-ref object i) xp)
+	  ))))
+
+(define (xp.print-table object xp)
+  (let ((pretty?  (dynamic *print-pretty*)))
+    (pprint-logical-block (xp '() "#<Table" ">")
+      (table-for-each
+        (lambda (key value)
+	  (xp.write-char++ #\space xp)
+	  (if pretty?
+	      (xp.pprint-newline+ 'fill xp))
+	  (pprint-pop)
+	  (xp.write+ (cons key value) xp))
+	object))))
+
+(define (xp.print-pair object xp)
+  (if (dynamic *print-pretty*)
+      (xp.pretty-print-list object xp)
+      (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f)
+	(do ()
+	    ((null? object) '#f)
+	    (xp.write+ (xp.pprint-pop+ object xp) xp)
+	    (when (not (null? object)) (xp.write-char++ #\space xp))))))
+
+(define (xp.print-struct object xp)
+  (if (dynamic *print-structure*)
+      (print-structure-default object xp)
+      (funcall (get-structure-printer (struct-type-descriptor object))
+	       object xp)))
+
+(define (get-structure-printer td)
+  (or (td-printer td)
+      (if (eq? (td-name td) 'struct)
+          (function print-structure-default)
+          (get-structure-printer (td-parent-type td)))))
+
+
+
+(define (print-structure-default object xp)
+  (let* ((td       (struct-type-descriptor object))
+	 (slots    (td-slots td))
+	 (pretty?  (dynamic *print-pretty*)))
+    (pprint-logical-block (xp '() "#<Struct " ">")
+      (prin1 (td-name td) xp)
+      (when (dynamic *print-structure-slots*)
+	(dolist (s slots)
+	  (write-char #\space xp)
+	  (if pretty? (pprint-newline 'fill xp))
+	  (pprint-pop)
+	  (prin1 (sd-name s) xp)
+	  (write-char #\space xp)
+	  (write (funcall (sd-getter-function s) object) xp)))
+      )))
+
+
+;;; This table can't be initialized until after all the functions
+;;; have been defined.
+
+(define *standard-print-dispatch-table*
+  (list (cons (function null?)         (function xp.print-null))
+	(cons (lambda (x) (eq? x '#t)) (function xp.print-true))
+	(cons (function not)           (function xp.print-false))
+	(cons (function symbol?)       (function xp.print-symbol))
+	(cons (function number?)       (function xp.print-number))
+	(cons (function pair?)         (function xp.print-pair))
+	(cons (function string?)       (function xp.print-string))
+	(cons (function char?)         (function xp.print-character))
+	(cons (function struct?)       (function xp.print-struct))
+	(cons (function vector?)       (function xp.print-vector))
+	(cons (function table?)        (function xp.print-table))))
+
+(define (standard-print-dispatch object)
+  (standard-print-dispatch-aux
+     object (dynamic *standard-print-dispatch-table*)))
+
+(define (standard-print-dispatch-aux object table)
+  (cond ((null? table) (function xp.print-default))
+	((funcall (car (car table)) object)
+	 (cdr (car table)))
+	(else
+	 (standard-print-dispatch-aux object (cdr table)))))
+
+(setf (dynamic *print-dispatch*) (function standard-print-dispatch))
+
+
+
+;;;=====================================================================
+;;; Pretty printing formats for code
+;;;=====================================================================
+
+
+;;; The standard prettyprinters for lists dispatch off the CAR of the list.
+
+(define *xp.pair-dispatch-table* (make-table))
+
+(define (xp.pretty-print-list object xp)
+  (funcall (or (table-entry (dynamic *xp.pair-dispatch-table*) (car object))
+	       (if (symbol? (car object)) (function xp.fn-call) '#f)
+	       (lambda (object xp)
+		 (pprint-fill xp object)))
+	   object
+	   xp))
+
+
+;;; Must use pprint-logical-block (no +) in the following three, because they 
+;;; are exported functions.
+;;; *** Note that the argument order on these is backwards; that's the
+;;; *** way it is in Common Lisp....
+
+(define (pprint-linear s object . moreargs)
+  (let* ((colon?  (if (not (null? moreargs)) (pop moreargs) '#t))
+	 (atsign? (if (not (null? moreargs)) (pop moreargs) '#f)))
+    (declare (ignore atsign?))
+    (pprint-logical-block (s object (if colon? "(" "") (if colon? ")" ""))
+      (pprint-exit-if-list-exhausted)
+      (do () ('#f)
+	  (xp.write+ (pprint-pop) s)
+	  (pprint-exit-if-list-exhausted)
+	  (xp.write-char++ #\space s)
+	  (xp.pprint-newline+ 'linear s)))))
+
+(define (pprint-fill s object . moreargs)
+  (let* ((colon?  (if (not (null? moreargs)) (pop moreargs) '#t))
+	 (atsign? (if (not (null? moreargs)) (pop moreargs) '#f)))
+    (declare (ignore atsign?))
+    (pprint-logical-block (s object (if colon? "(" "") (if colon? ")" ""))
+      (pprint-exit-if-list-exhausted)
+      (do () ('#f)
+	  (xp.write+ (pprint-pop) s)
+	  (pprint-exit-if-list-exhausted)
+	  (xp.write-char++ #\space s)
+	  (xp.pprint-newline+ 'fill s)))))
+
+(define (pprint-tabular s object . moreargs)
+  (let* ((colon?  (if (not (null? moreargs)) (pop moreargs) '#t))
+	 (atsign? (if (not (null? moreargs)) (pop moreargs) '#f))
+	(tabsize (or (and (not (null? moreargs)) (pop moreargs)) 16)))
+    (declare (ignore atsign?))
+    (pprint-logical-block (s object (if colon? "(" "") (if colon? ")" ""))
+      (pprint-exit-if-list-exhausted)
+      (do () ('#f)
+	  (xp.write+ (pprint-pop) s)
+	  (pprint-exit-if-list-exhausted)
+	  (xp.write-char++ #\space s)
+	  (xp.pprint-tab+ 'section-relative 0 tabsize s)
+	  (xp.pprint-newline+ 'fill s)))))
+
+
+(define (xp.fn-call object xp)
+  ;; (formatter "~:<~W~^ ~:I~@_~@{~W~^ ~_~}~:>")
+  (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f)
+    (xp.write+ (xp.pprint-pop+ object xp) xp)
+    (xp.pprint-exit-if-list-exhausted+ object)
+    (xp.write-char++ #\space xp)
+    (xp.pprint-indent+ 'current 0 xp)
+    (xp.pprint-newline+ 'miser xp)
+    (xp.write+ (xp.pprint-pop+ object xp) xp)
+    (do ()
+	((null? object) '#f)
+	(xp.write-char++ #\space xp)
+	(xp.pprint-newline+ 'linear xp)
+	(xp.write+ (xp.pprint-pop+ object xp) xp))))
+
+
+;;; Although idiosyncratic, I have found this very useful to avoid large
+;;; indentations when printing out code.
+
+(define (xp.alternative-fn-call object xp)
+  (if (> (string-length (symbol->string (car object))) 12)
+      ;; (formatter "~:<~1I~@{~W~^ ~_~}~:>")
+      (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f)
+        (xp.pprint-indent+ 'block 1 xp)
+	(when (not (null? object))
+	  (xp.write+ (xp.pprint-pop+ object xp) xp)
+	  (do ()
+	      ((null? object) '#f)
+	      (xp.write-char++ #\space xp)
+	      (xp.pprint-newline+ 'linear xp)
+	      (xp.write+ (xp.pprint-pop+ object xp) xp))))
+      (xp.fn-call object xp)))
+
+
+(define (xp.bind-list object xp . args)
+  (declare (ignore args))
+  ;; (formatter "~:<~@{~:/xp:pprint-fill/~^ ~_~}~:>")
+  (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f)
+    (when (not (null? object))
+      (pprint-fill xp (xp.pprint-pop+ object xp) '#t '#f)
+      (do ()
+	  ((null? object) '#f)
+	  (xp.write-char++ #\space xp)
+	  (xp.pprint-newline+ 'linear xp)
+	  (pprint-fill xp (xp.pprint-pop+ object xp) '#t '#f)))))
+
+(define (xp.fbind-list object xp . args)
+  (declare (ignore args))
+  ;; (formatter "~:<~@{~:/xp:pprint-fill/~^ ~_~}~:>")
+  (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f)
+    (when (not (null? object))
+      (pprint-fill xp (xp.pprint-pop+ object xp) '#t '#f)
+      (do ()
+	  ((null? object) '#f)
+	  (xp.write-char++ #\space xp)
+	  (xp.pprint-newline+ 'linear xp)
+	  (xp.block-like (xp.pprint-pop+ object xp) xp)))))
+
+
+(define (xp.block-like object xp . args)
+  (declare (ignore args))
+  ;; (formatter "~:<~1I~^~W~^ ~@_~W~^~@{ ~_~W~^~}~:>")
+  (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f)
+    (xp.pprint-indent+ 'block 1 xp)
+    (xp.pprint-exit-if-list-exhausted+ object)
+    (xp.write+ (xp.pprint-pop+ object xp) xp)
+    (xp.pprint-exit-if-list-exhausted+ object)
+    (xp.write-char++ #\space xp)
+    (xp.pprint-newline+ 'miser xp)
+    (xp.write+ (xp.pprint-pop+ object xp) xp)
+    (xp.pprint-exit-if-list-exhausted+ object)
+    (do ()
+	((null? object) '#f)
+	(xp.write-char++ #\space xp)
+	(xp.pprint-newline+ 'linear xp)
+	(xp.write+ (xp.pprint-pop+ object xp) xp))))
+
+
+(define (xp.print-fancy-fn-call object xp template)
+  (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f)
+    (xp.write+ (xp.pprint-pop+ object xp) xp)
+    (xp.pprint-indent+ 'current 1 xp)
+    (do ((i 0 (1+ i))
+	 (in-first-section '#t))
+	((null? object) '#f)
+	(xp.write-char++ #\space xp)
+	(when (eqv? i (car template))
+	  (xp.pprint-indent+ 'block (cadr template) xp)
+	  (setf template (cddr template))
+	  (setf in-first-section '#f))
+	(pprint-newline (cond ((zero? i) 'miser)
+			      (in-first-section 'fill)
+			      (else 'linear))
+			xp)
+	(xp.write+ (xp.pprint-pop+ object xp) xp))))
+
+(define (xp.let-print object xp)
+  ;; (formatter "~:<~1I~W~^ ~@_~/xp:xp.bind-list/~^~@{ ~_~W~^~}~:>")
+  (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f)
+    (xp.pprint-indent+ 'block 1 xp)
+    (xp.write+ (xp.pprint-pop+ object xp) xp)
+    (xp.pprint-exit-if-list-exhausted+ object)
+    (xp.write-char++ #\space xp)
+    (xp.pprint-newline+ 'miser xp)
+    (xp.bind-list (xp.pprint-pop+ object xp) xp '#f '#f)
+    (xp.pprint-exit-if-list-exhausted+ object)
+    (do ()
+	((null? object) '#f)
+	(xp.write-char++ #\space xp)
+	(xp.pprint-newline+ 'linear xp)
+	(xp.write+ (xp.pprint-pop+ object xp) xp))))
+
+(define (xp.flet-print object xp)
+  (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f)
+    (xp.pprint-indent+ 'block 1 xp)
+    (xp.write+ (xp.pprint-pop+ object xp) xp)
+    (xp.pprint-exit-if-list-exhausted+ object)
+    (xp.write-char++ #\space xp)
+    (xp.pprint-newline+ 'miser xp)
+    (xp.fbind-list (xp.pprint-pop+ object xp) xp '#f '#f)
+    (xp.pprint-exit-if-list-exhausted+ object)
+    (do ()
+	((null? object) '#f)
+	(xp.write-char++ #\space xp)
+	(xp.pprint-newline+ 'linear xp)
+	(xp.write+ (xp.pprint-pop+ object xp) xp))))
+
+(define (xp.cond-print object xp)
+  ;; (formatter "~:<~W~^ ~:I~@_~@{~:/xp:pprint-linear/~^ ~_~}~:>")
+  (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f)
+    (xp.write+ (xp.pprint-pop+ object xp) xp)
+    (xp.pprint-exit-if-list-exhausted+ object)
+    (xp.write-char++ #\space xp)
+    (xp.pprint-indent+ 'current 0 xp)
+    (xp.pprint-newline+ 'miser xp)
+    (pprint-linear xp (xp.pprint-pop+ object xp) '#t '#f)
+    (do ()
+	((null? object) '#f)
+	(xp.write-char++ #\space xp)
+	(xp.pprint-newline+ 'linear xp)
+	(pprint-linear xp (xp.pprint-pop+ object xp) '#t '#f))))
+
+(define (xp.do-print object xp)
+  ;; (formatter "~:<~W~^ ~:I~@_~/xp:xp.bind-list/~^ ~_~:/xp:pprint-linear/ ~1I~^~@{ ~_~W~^~}~:>")
+  (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f)
+    (xp.write+ (xp.pprint-pop+ object xp) xp)
+    (xp.pprint-exit-if-list-exhausted+ object)
+    (xp.write-char++ #\space xp)
+    (xp.pprint-indent+ 'current 0 xp)
+    (xp.pprint-newline+ 'miser xp)
+    (xp.bind-list (xp.pprint-pop+ object xp) xp '#f '#f)
+    (xp.pprint-exit-if-list-exhausted+ object)
+    (xp.write-char++ #\space xp)
+    (xp.pprint-newline+ 'linear xp)
+    (pprint-linear xp (xp.pprint-pop+ object xp) '#t '#f)
+    (xp.write-char++ #\space xp)
+    (xp.pprint-indent+ 'block 1 xp)
+    (do ()
+	((null? object) '#f)
+	(xp.write-char++ #\space xp)
+	(xp.pprint-newline+ 'linear xp)
+	(xp.write+ (xp.pprint-pop+ object xp) xp))))
+
+(define (xp.mvb-print object xp)
+  (xp.print-fancy-fn-call object xp '(1 3 2 1)))
+
+(define (xp.setf-print object xp)
+  ;; (formatter "~:<~W~^ ~:I~@_~@{~W~^ ~:_~W~^ ~_~}~:>")
+  (xp.pprint-logical-block+ (xp object "(" ")" '#f '#t '#f)
+    (xp.write+ (xp.pprint-pop+ object xp) xp)
+    (xp.pprint-exit-if-list-exhausted+ object)
+    (xp.write-char++ #\space xp)
+    (xp.pprint-indent+ 'current 0 xp)
+    (xp.pprint-newline+ 'miser xp)
+    (xp.write+ (xp.pprint-pop+ object xp) xp)
+    (do ()
+	((null? object) '#f)
+	(xp.write-char++ #\space xp)
+	(xp.pprint-newline+ 'fill xp)
+	(xp.write+ (xp.pprint-pop+ object xp) xp)
+	(when (not (null? object))
+	    (xp.write-char++ #\space xp)
+	    (xp.pprint-newline+ 'linear xp)
+	    (xp.write+ (xp.pprint-pop+ object xp) xp)))))
+
+(define (xp.quote-print object xp)
+  (if (and (pair? (cdr object)) (null? (cddr object)))
+      (begin
+         (xp.write-char++ #\' xp)
+	 (xp.write+ (cadr object) xp))
+      (pprint-fill xp object)))
+
+(define (xp.up-print object xp)
+  (xp.print-fancy-fn-call object xp '(0 3 1 1)))
+
+
+;;; Install printers for built-in macros and special forms into the
+;;; standard dispatch table.
+
+(define-local-syntax (define-printer symbol function)
+  `(setf (table-entry (dynamic *xp.pair-dispatch-table*) ',symbol)
+	 (function ,function)))
+
+
+;;; *** Missing support for backquote here.
+
+(define-printer quote xp.quote-print)
+(define-printer lambda xp.block-like)
+(define-printer when xp.block-like)
+(define-printer unless xp.block-like)
+(define-printer cond xp.cond-print)
+(define-printer case xp.block-like)
+(define-printer setf xp.setf-print)
+(define-printer set! xp.setf-print)
+(define-printer let xp.let-print)
+(define-printer let* xp.let-print)
+(define-printer letrec xp.let-print)
+(define-printer flet xp.flet-print)
+(define-printer labels xp.flet-print)
+(define-printer dynamic-let xp.let-print)
+(define-printer block xp.block-like)
+(define-printer do xp.do-print)
+(define-printer dolist xp.block-like)
+(define-printer dotimes xp.block-like)
+(define-printer multiple-value-bind xp.mvb-print)
+(define-printer let/cc xp.block-like)
+(define-printer unwind-protect xp.up-print)
+(define-printer define xp.block-like)
+(define-printer define-syntax xp.block-like)
+(define-printer define-local-syntax xp.block-like)
+(define-printer pprint-logical-block xp.block-like)
+(define-printer xp.pprint-logical-block+ xp.block-like)
+
+;;; Here are some hacks for struct macros.
+
+(define-printer update-slots xp.mvb-print)
+(define-printer make xp.block-like)
diff --git a/support/support.scm b/support/support.scm
new file mode 100644
index 0000000..bdecc4f
--- /dev/null
+++ b/support/support.scm
@@ -0,0 +1,35 @@
+;;; support.scm -- load support files shared by all systems
+;;;
+;;; author :  Sandra Loosemore
+;;; date   :  28 Oct 1991
+;;;
+;;;
+
+
+;;; Keep track of all compilation units defined.
+;;; This has to go here and not in compile.scm because we don't want this
+;;; list reinitialized every time that file is loaded.
+
+(define compilation-units '())
+
+
+;;; Load this file first; it defines the basic compilation system support.
+;;; It doesn't matter if this ends up loading source because we'll compile
+;;; and reload it below.  
+
+(load "$Y2/support/compile.scm")
+
+
+;;; Define a real compilation unit for shared support files.
+
+(define-compilation-unit support
+  (source-filename "$Y2/support/")
+  (unit compile (source-filename "compile.scm"))
+  (unit utils   (source-filename "utils.scm"))
+  (unit xp
+	(unit pprint (source-filename "pprint.scm"))
+	(unit format (source-filename "format.scm")
+	      (require pprint)))
+  )
+
+
diff --git a/support/system.scm b/support/system.scm
new file mode 100644
index 0000000..ac03b10
--- /dev/null
+++ b/support/system.scm
@@ -0,0 +1,51 @@
+;;; system.scm -- haskell system setup
+;;;
+;;; author :  Sandra Loosemore
+;;; date   :  22 Nov 1991
+;;;
+;;; This file loads in the compilation unit definition files for all
+;;; of the components of the haskell system.  
+;;;
+;;; (The compilation unit facility is defined in support/shared/compile.scm.)
+
+
+;;; First load the files containing module definitions.
+;;; *** Add more files to the end of this list.  
+
+(load "$Y2/support/support")
+(load "$Y2/ast/ast")
+(load "$Y2/top/top")
+(load "$Y2/util/haskell-utils")
+(load "$Y2/printers/printers")
+(load "$Y2/parser/parser")
+(load "$Y2/import-export/ie.scm")
+(load "$Y2/tdecl/tdecl.scm")
+(load "$Y2/derived/derived.scm")
+(load "$Y2/prec/prec.scm")
+(load "$Y2/depend/depend.scm")
+(load "$Y2/type/type.scm")
+(load "$Y2/cfn/cfn.scm")
+(load "$Y2/flic/flic.scm")
+(load "$Y2/backend/backend.scm")
+(load "$Y2/runtime/runtime.scm")
+(load "$Y2/csys/csys")
+(load "$Y2/command-interface/command-interface")
+
+;;; Define some functions to actually do the work.  The compilation unit 
+;;; facility has conveniently kept a list of all of the unit definitions,
+;;; so we can just rip through them in sequence.
+
+(define (compile-haskell)
+  (compile-and-load-unit-list compilation-units))
+
+(define (recompile-haskell)
+  (unless (null? remaining-units)
+    (compile-and-load-unit-list remaining-units)))
+
+
+(define (load-haskell)
+  (load-unit-list compilation-units))
+
+(define (reload-haskell)
+  (unless (null? remaining-units)
+    (load-unit-list remaining-units)))
diff --git a/support/utils.scm b/support/utils.scm
new file mode 100644
index 0000000..ab93f6b
--- /dev/null
+++ b/support/utils.scm
@@ -0,0 +1,408 @@
+;;; utils.scm -- utility functions
+;;;
+;;; author :  Sandra Loosemore
+;;; date   :  18 Nov 1991
+;;;
+;;; This file contains miscellaneous functions that are generally useful.
+;;; If you find some missing feature from the base language, this is
+;;; a good place to put it.  Common Lisp-style sequence functions are 
+;;; an example of the sort of thing found here.
+
+
+;;;=====================================================================
+;;; Sequence functions
+;;;=====================================================================
+
+(define (vector-replace to-vec from-vec to start end)
+  (declare (type fixnum to start end)
+	   (type vector to-vec from-vec))
+  (if (and (eq? to-vec from-vec)
+	   (> to start))
+      ;; Right shift in place
+      (do ((from  (1- end) (1- from))
+	   (to    (1- (+ to (- end start)))))
+	  ((< from start) to-vec)
+	  (declare (type fixnum from to))
+	  (setf (vector-ref to-vec to) (vector-ref from-vec from))
+	  (decf to))
+      ;; Normal case, left-to-right
+      (do ((from  start (1+ from)))
+	  ((= from end) to-vec)
+	  (declare (type fixnum from))
+	  (setf (vector-ref to-vec to) (vector-ref from-vec from))
+	  (incf to))))
+
+(define (string-replace to-vec from-vec to start end)
+  (declare (type fixnum to start end)
+	   (type string to-vec from-vec))
+  (if (and (eq? to-vec from-vec)
+	   (> to start))
+      ;; Right shift in place
+      (do ((from  (1- end) (1- from))
+	   (to    (1- (+ to (- end start)))))
+	  ((< from start) to-vec)
+	  (declare (type fixnum from to))
+	  (setf (string-ref to-vec to) (string-ref from-vec from))
+	  (decf to))
+      ;; Normal case, left-to-right
+      (do ((from  start (1+ from)))
+	  ((= from end) to-vec)
+	  (declare (type fixnum from))
+	  (setf (string-ref to-vec to) (string-ref from-vec from))
+	  (incf to))))
+
+(define (string-fill string c start end)
+  (declare (type fixnum start end)
+	   (type string string)
+	   (type char c))
+  (do ((i start (1+ i)))
+      ((= i end) string)
+      (declare (type fixnum i))
+      (setf (string-ref string i) c)))
+
+(define (string-position c string start end)
+  (declare (type fixnum start end)
+	   (type string string)
+	   (type char c))
+  (cond ((= start end) '#f)
+	((char=? (string-ref string start) c) start)
+	(else
+	 (string-position c string (1+ start) end))))
+
+(define (string-position-not-from-end c string start end)
+  (declare (type fixnum start end)
+	   (type string string)
+	   (type char c))
+  (cond ((= start end) '#f)
+	((not (char=? (string-ref string (setf end (1- end))) c))
+	 end)
+	(else
+	 (string-position-not-from-end c string start end))))
+
+(define (string-nreverse string start end)
+  (declare (type fixnum start end)
+	   (type string string))
+  (do ((i start (1+ i))
+       (j (1- end) (1- j)))
+      ((not (< i j)) string)
+      (declare (type fixnum i j))
+    (let ((c (string-ref string i)))
+      (setf (string-ref string i) (string-ref string j))
+      (setf (string-ref string j) c))))
+
+
+(define (string-starts? s1 s2)  ; true is s1 begins s2
+  (and (>= (string-length s2) (string-length s1))
+       (string=? s1 (substring s2 0 (string-length s1)))))
+
+
+;;;=====================================================================
+;;; Table utilities
+;;;=====================================================================
+
+
+(define (table->list table)
+  (let ((l '()))
+       (table-for-each
+	(lambda (key val) (push (cons key val) l)) table)
+       l))
+
+(define (list->table l)
+  (let ((table (make-table)))
+     (dolist (p l)
+	(setf (table-entry table (car p)) (cdr p)))
+     table))
+
+
+
+;;;=====================================================================
+;;; Tuple utilities
+;;;=====================================================================
+
+;;; For future compatibility with a typed language, define 2 tuples with
+;;; a few functions:  (maybe add 3 tuples someday!)
+
+(define-integrable (tuple x y)
+  (cons x y))
+
+(define-integrable (tuple-2-1 x) (car x))  ; Flic-like notation
+(define-integrable (tuple-2-2 x) (cdr x))
+
+(define (map-tuple-2-1 f l)
+  (map (lambda (x) (tuple (funcall f (tuple-2-1 x)) (tuple-2-2 x))) l))
+
+(define (map-tuple-2-2 f l)
+  (map (lambda (x) (tuple (tuple-2-1 x) (funcall f (tuple-2-2 x)))) l))
+
+
+;;;=====================================================================
+;;; List utilities
+;;;=====================================================================
+
+;;; This does an assq using the second half of the tuple as the key.
+
+(define (rassq x l)
+  (if (null? l)
+      '#f
+      (if (eq? x (tuple-2-2 (car l)))
+	  (car l)
+	  (rassq x (cdr l)))))
+
+;;; This is an assoc with an explicit test
+
+(define (assoc/test test-fn x l)
+  (if (null? l)
+      '#f
+      (if (funcall test-fn x (tuple-2-1 (car l)))
+	  (car l)
+	  (assoc/test test-fn x (cdr l)))))
+
+
+
+
+;;; Stupid position function works only on lists, uses eqv?
+
+(define (position item list)
+  (position-aux item list 0))
+
+(define (position-aux item list index)
+  (declare (type fixnum index))
+  (cond ((null? list)
+	 '#f)
+	((eqv? item (car list))
+	 index)
+	(else
+	 (position-aux item (cdr list) (1+ index)))
+	))
+
+
+;;; Destructive delete-if function
+
+(define (list-delete-if f l)
+  (list-delete-if-aux f l l '#f))
+
+(define (list-delete-if-aux f head next last)
+  (cond ((null? next)
+	 ;; No more elements.
+	 head)
+	((not (funcall f (car next)))
+	 ;; Leave this element and do the next.
+	 (list-delete-if-aux f head (cdr next) next))
+	(last
+	 ;; Delete element from middle of list.
+	 (setf (cdr last) (cdr next))
+	 (list-delete-if-aux f head (cdr next) last))
+	(else
+	 ;; Delete element from head of list.
+	 (list-delete-if-aux f (cdr next) (cdr next) last))))
+
+
+;;; Same as the haskell function
+
+(define (concat lists)
+  (if (null? lists)
+      '()
+      (append (car lists) (concat (cdr lists)))))
+
+
+;;; This is a quick & dirty list sort function.
+
+(define (sort-list l compare-fn)
+  (if (or (null? l) (null? (cdr l)))
+      l
+      (insert-sorted compare-fn (car l) (sort-list (cdr l) compare-fn))))
+
+(define (insert-sorted compare-fn e l)
+  (if (null? l)
+      (list e)
+      (if (funcall compare-fn e (car l))
+	  (cons e l)
+	  (cons (car l) (insert-sorted compare-fn e (cdr l))))))
+
+(define (find-duplicates l)
+  (cond ((null? l)
+	 '())
+	((memq (car l) (cdr l))
+	 (cons (car l)
+	       (find-duplicates (cdr l))))
+	(else (find-duplicates (cdr l)))))
+
+;;;  A simple & slow topsort routine.
+;;;  Input:  A list of lists.  Each list is a object consed onto the
+;;;          list of objects it preceeds.
+;;;  Output: Two values: SORTED / CYCLIC & a list of either sorted objects
+;;;                      or a set of components containing the cycle.
+
+(define (topsort l)
+  (let ((changed? '#t)
+	(sorted '())
+	(next '()))
+    (do () ((not changed?) 
+	    (if (null? next)
+		(values 'sorted (nreverse sorted))
+		(values 'cyclic (map (function car) next))))
+      (setf changed? '#f)
+      (setf next '())
+      (dolist (x l)
+        (cond ((topsort-aux (cdr x) sorted)
+	       (push (car x) sorted)
+	       (setf changed? '#t))
+	      (else
+	       (push x next))))
+      (setf l next))))
+
+
+;;; Returns true if x doesn't contain any elements that aren't in sorted.
+;;; equivalent to (null? (set-intersection x sorted)), but doesn't cons
+;;; and doesn't traverse the whole list in the failure case.
+
+(define (topsort-aux x sorted)
+  (cond ((null? x)
+	 '#t)
+	((memq (car x) sorted)
+	 (topsort-aux (cdr x) sorted))
+	(else
+	 '#f)))
+
+(define (set-intersection s1 s2)
+  (if (null? s1)
+      '()
+      (let ((rest (set-intersection (cdr s1) s2)))
+	(if (memq (car s1) s2)
+	    (cons (car s1) rest)
+	    rest))))
+
+;;; remove s2 elements from s1
+
+(define (set-difference s1 s2)
+  (if (null? s1)
+      '()
+      (let ((rest (set-difference (cdr s1) s2)))
+	(if (memq (car s1) s2)
+	    rest
+	    (cons (car s1) rest)))))
+
+
+(define (set-union s1 s2)
+  (if (null? s2)
+      s1
+      (if (memq (car s2) s1)
+	  (set-union s1 (cdr s2))
+	  (cons (car s2) (set-union s1 (cdr s2))))))
+
+
+;;; Destructive list splitter
+
+(define (split-list list n)
+  (declare (type fixnum n))
+  (let ((tail1  (list-tail list (1- n))))
+    (if (null? tail1)
+	(values list '())
+	(let ((tail2  (cdr tail1)))
+	  (setf (cdr tail1) '())
+	  (values list tail2)))))
+
+
+;;; Some string utils
+
+(define (mem-string s l)
+  (and (not (null? l)) (or (string=? s (car l))
+			   (mem-string s (cdr l)))))
+
+(define (ass-string k l)
+  (cond ((null? l)
+	 '#f)
+	((string=? k (caar l))
+	 (car l))
+	(else
+	 (ass-string k (cdr l)))))
+
+
+;;;=====================================================================
+;;; Syntax extensions
+;;;=====================================================================
+
+;;; The mlet macro combines let* and multiple-value-bind into a single
+;;; syntax.
+
+(define-syntax (mlet binders . body)
+  (mlet-body binders body))
+
+(define (mlet-body binders body)
+  (if (null? binders)
+      `(begin ,@body)
+      (let* ((b (car binders))
+	     (var (car b))
+	     (init (cadr b))
+	     (inner-body (mlet-body (cdr binders) body)))
+	(if (pair? var)
+	    (multiple-value-bind (new-vars ignore-decl)
+				 (remove-underlines var)
+	       `(multiple-value-bind ,new-vars
+				     ,init ,@ignore-decl ,inner-body))
+	    `(let ((,var ,init)) ,inner-body)))))
+
+(define (remove-underlines vars)
+  (if (null? vars)
+      (values '() '())
+      (multiple-value-bind (rest ignore-decl) (remove-underlines (cdr vars))
+	(if (not (eq? (car vars) '_))
+	    (values (cons (car vars) rest) ignore-decl)
+	    (let ((var (gensym)))
+	      (values (cons var rest)
+		      `((declare (ignore ,var)) ,@ignore-decl)))))))
+
+
+
+
+;;;=====================================================================
+;;; Other utilities
+;;;=====================================================================
+
+(define (add-extension name ext)
+  (assemble-filename (filename-place name) (filename-name name) ext))
+
+(define (time-execution thunk)
+  (let* ((start-time (get-run-time))
+	 (res (funcall thunk))
+	 (end-time (get-run-time)))
+    (values res (- end-time start-time))))
+
+(define (pprint-flatten code . maybe-port)
+  (pprint-flatten-aux
+    code
+    (if (null? maybe-port) (current-output-port) (car maybe-port))))
+
+(define (pprint-flatten-aux code port)
+  (if (and (pair? code)
+	   (eq? (car code) 'begin))
+      (dolist (c (cdr code))
+	(pprint-flatten-aux c port))
+      (pprint*-aux code port)))
+
+(define (print-flatten code port)
+  (if (and (pair? code)
+	   (eq? (car code) 'begin))
+      (dolist (c (cdr code))
+	(print-flatten c port))
+      (begin
+	(internal-write code port)
+	(internal-newline port))))
+
+
+;;; Like pprint, but print newline after instead of before.
+
+(define (pprint* object . maybe-port)
+  (pprint*-aux
+    object
+    (if (null? maybe-port) (current-output-port) (car maybe-port))))
+
+(define (pprint*-aux object port)
+  (dynamic-let ((*print-pretty*  '#t))
+    (prin1 object port))
+  (terpri port))
+
+;;; This reads stuff from a string.  (Better error checks needed!)
+
+(define (read-lisp-object str)
+  (call-with-input-string str (lambda (port) (read port))))