Import to github.

9 files changed, 2602 insertions, 0 deletions

diff --git a/cl-support/PORTING b/cl-support/PORTING
new file mode 100644
index 0000000..2114be5
--- /dev/null
+++ b/cl-support/PORTING
@@ -0,0 +1,105 @@
+Here are the steps involved in porting to a new Common Lisp implementation.
+
+(0) Find the executable you want to use.  If possible, use an image
+    that doesn't have stuff like CLX, CLOS, a snazzy editor, and the
+    like loaded, since we don't use any of that stuff.
+
+    Put an environment variable in the haskell-development script to point 
+    to the lisp you want to run.
+
+(1) You must add appropriate conditionalizations to cl-init.lisp and 
+    cl-definitions.lisp in this directory.  Look for places where there
+    are #+ things for the other dialects.
+
+    As a matter of style, try to make an explicit case for each Lisp
+    instead of using #- to test for it *not* being a particular dialect.
+    This will prevent confusion on future ports.
+
+    You may also need/want to add conditionals to the primitive 
+    implementation files in the runtime directory.
+
+    Do not add #+/#- conditionalizations to any other random .scm
+    files, since we want to keep this implementation-dependent stuff 
+    centralized.
+
+(2) Make subdirectories to hold compiled files in each of the source
+    directories.  The name of the subdirectory must match the constant
+    lisp-implementation-name in cl-definitions.lisp.
+
+(3) Try compiling the Haskell system (by loading cl-init.lisp) and
+    fix any compilation warnings that happen.  (Hopefully there won't
+    be any.)
+
+    You probably want to build a system initially with the default
+    compiler settings and verbose compiler diagnostics.  This will make 
+    any problems that show up later easier to debug.  Also, it is
+    helpful to capture all the messages in a dribble file to make it
+    easier to verify that everything went OK.
+
+(4) Try compiling the prelude using (compile/prelude *prelude-unit*).
+    You need to create a subdirectory in the progs/prelude directory
+    to hold the output files, and define $PRELUDEBIN to point at
+    this directory (see the haskell-setup script).
+
+    The important thing at this point is that the prelude makes it all 
+    the way through the codegen phase and produces Lisp code.  Don't worry
+    too much now if the Lisp compiler has trouble digesting the output.
+
+    Once you get to this stage, it's time to start messing with
+    compiler optimize proclamations.  We generally use (speed 3) and
+    (safety 0).  Also, you should figure out how to suppress any
+    compiler messages (e.g., set *compile-print* and *compile-verbose*
+    to false).  We usually leave *compile-verbose* on during compilation
+    of the Haskell compiler, but turn it off later so that people don't
+    get messages from the Lisp compiler when running Haskell programs.
+
+(5) Make a subdirectory in the com directory and make the following set 
+    of scripts there:
+
+    clean -- remove all binary files.  Also change the main com/clean
+      script to invoke this.
+    compile -- recompile everything with the right compiler flags (see 
+      step 5).
+    build-prelude -- run the prelude through the haskell compiler.
+      This should save the old compiled prelude files as old-prelude.*
+      case something goes wrong.
+    savesys -- load the compiled prelude and save a core file.
+      This should also be careful not to overwrite an existing file.
+
+    Look at the scripts that have already been written for other Lisps
+    for hints.
+
+    At some point you also need to put a README file in this directory.
+
+
+(6) Now it's time to get serious about getting the prelude to compile.
+    Use the clean, compile, and build-prelude scripts you just wrote.
+
+    Some compilers have a hard time dealing with the large pieces of
+    Lisp code produced for the prelude.  You will probably need to do 
+    something to make the heap bigger.  (And, make sure the machine
+    you are using to do the build on has plenty of swap space.)  You 
+    may also need to tweak the chunk-size parameters to force the 
+    output to be split up into smaller pieces.
+
+    It's OK to leave the prelude interface file as a source file, or
+    to compile it with low speed optimizations.  On the other hand,
+    the prelude code file ought to be processed with as many speed
+    optimizations as possible.
+
+(7) Build a new executable using the "savesys" script and take it for
+    a test drive.
+
+(8) You must also hack the emacs interface file, emacs-tools/haskell.el,
+    to recognize when it's gotten into the debugger or break loop.
+    To test your new executable with the emacs stuff, you must
+    define the environment variable HASKELLPROG to point at it, or
+    set the emacs variable haskell-program-name.
+
+(9) If you want to use the Haskell->CLX interface, you'll have to
+    mess with equivalents of the build-xlib and savesys-xlib scripts.
+    There is some system-dependent code in xlibclx.scm to set up an
+    error handler -- make sure you have conditionalized this appropriately
+    for your Lisp system.
+
+
diff --git a/cl-support/README b/cl-support/README
new file mode 100644
index 0000000..5553e4a
--- /dev/null
+++ b/cl-support/README
@@ -0,0 +1,3 @@
+This directory contains Common-Lisp-syntax files to set up a more
+Scheme-like environment.  Load cl-init.lisp and it will suck in all
+the rest.
diff --git a/cl-support/cl-definitions.lisp b/cl-support/cl-definitions.lisp
new file mode 100644
index 0000000..8727679
--- /dev/null
+++ b/cl-support/cl-definitions.lisp
@@ -0,0 +1,1351 @@
+;;; cl-definitions.lisp -- mumble compatibility package for Common Lisp
+;;;
+;;; author :  Sandra Loosemore
+;;; date   :  11 Oct 1991
+;;;
+;;; You must load cl-setup and cl-support before trying to compile this 
+;;; file.
+
+(in-package "MUMBLE-IMPLEMENTATION")
+
+
+;;;=====================================================================
+;;; Syntax
+;;;=====================================================================
+
+(define-mumble-import quote)
+(define-mumble-import function)
+
+;;; Lambda lists have to have dot syntax converted to &rest.
+
+(define-mumble-macro mumble::lambda (lambda-list &rest body)
+  `(function (lambda ,(mung-lambda-list lambda-list) ,@body)))
+
+(defun mung-lambda-list (lambda-list)
+  (cond ((consp lambda-list)
+	 (let ((last  (last lambda-list)))
+	   (if (null (cdr last))
+	       lambda-list
+	       `(,@(ldiff lambda-list last) ,(car last) &rest ,(cdr last)))))
+	((null lambda-list)
+	 '())
+	(t
+	 `(&rest ,lambda-list))))
+
+
+;;; We only funcall and apply things that are real functions.
+
+
+;;; Gag.  Lucid needs to see the procedure declaration to avoid putting
+;;; a coerce-to-procedure check in, but there's a compiler bug that causes
+;;; it to barf if the function is a lambda form.
+
+#+lucid
+(define-mumble-macro mumble::funcall (fn . args)
+  (if (and (consp fn) (eq (car fn) 'mumble::lambda))
+      `(funcall ,fn ,@args)
+      `(funcall (the system::procedure ,fn) ,@args)))
+
+#+(or cmu allegro akcl lispworks mcl)
+(define-mumble-macro mumble::funcall (fn . args)
+  `(funcall (the function ,fn) ,@args))
+
+#+wcl
+(define-mumble-macro mumble::funcall (fn . args)
+  `(funcall (the lisp:procedure ,fn) ,@args))
+
+#-(or lucid cmu allegro akcl mcl lispworks wcl)
+(missing-mumble-definition mumble::funcall)
+
+
+;;; Could make this declare its fn argument too
+
+(define-mumble-import apply)
+
+(define-mumble-synonym mumble::map mapcar)
+(define-mumble-synonym mumble::for-each mapc)
+(define-mumble-import some)
+(define-mumble-import every)
+(define-mumble-import notany)
+(define-mumble-import notevery)
+(define-mumble-synonym mumble::procedure? functionp)
+
+
+(define-mumble-import if)
+(define-mumble-import when)
+(define-mumble-import unless)
+
+
+;;; COND and CASE differ from Common Lisp because of using "else" instead 
+;;; of "t" as the fall-through case.
+
+(define-mumble-import mumble::else)
+
+(define-mumble-macro mumble::cond (&rest cases)
+  (let ((last    (car (last cases))))
+    (if (eq (car last) 'mumble::else)
+	`(cond ,@(butlast cases) (t ,@(cdr last)))
+	`(cond ,@cases))))
+
+(define-mumble-macro mumble::case (data &rest cases)
+  (let ((last  (car (last cases))))
+    (if (eq (car last) 'mumble::else)
+	`(case ,data ,@(butlast cases) (t ,@(cdr last)))
+	`(case ,data ,@cases))))
+
+
+(define-mumble-import and)
+(define-mumble-import or)
+(define-mumble-import not)
+
+(define-mumble-macro mumble::set! (variable value)
+  `(setq ,variable ,value))
+(define-mumble-import setf)
+
+
+;;; AKCL's SETF brokenly tries to macroexpand the place
+;;; form before looking for a define-setf-method.  Redefine the
+;;; internal function to do the right thing.
+
+#+akcl
+(defun system::setf-expand-1 (place newvalue env)
+  (multiple-value-bind (vars vals stores store-form access-form)
+      (get-setf-method place env)
+    (declare (ignore access-form))
+    `(let* ,(mapcar #'list
+                    (append vars stores)
+                    (append vals (list newvalue)))
+       ,store-form)))
+
+
+;;; Allegro has renamed this stuff as per ANSI CL.
+
+#+allegro
+(eval-when (eval compile load)
+  (setf (macro-function 'define-setf-method)
+	(macro-function 'define-setf-expander))
+  (setf (symbol-function 'get-setf-method)
+	(symbol-function 'get-setf-expansion))
+  )
+
+(define-mumble-import let)
+(define-mumble-import let*)
+
+(define-mumble-macro mumble::letrec (bindings &rest body)
+  `(let ,(mapcar #'car bindings)
+     ,@(mapcar #'(lambda (b) (cons 'setq b)) bindings)
+     (locally ,@body)))
+
+(define-mumble-import flet)
+(define-mumble-import labels)
+
+(define-mumble-macro mumble::dynamic-let (bindings &rest body)
+  `(let ,bindings
+     (declare (special ,@(mapcar #'car bindings)))
+     ,@body))
+
+(define-mumble-macro mumble::dynamic (name)
+  `(locally (declare (special ,name)) ,name))
+
+(define-setf-method mumble::dynamic (name)
+  (let ((store  (gensym)))
+    (values nil
+	    nil
+	    (list store)
+	    `(locally (declare (special ,name)) (setf ,name ,store))
+	    `(locally (declare (special ,name)) ,name))))
+
+
+(define-mumble-macro mumble::begin (&rest body)
+  `(progn ,@body))
+
+(define-mumble-import block)
+(define-mumble-import return-from)
+
+(define-mumble-import do)
+(define-mumble-import dolist)
+(define-mumble-import dotimes)
+
+(define-mumble-import values)
+(define-mumble-import multiple-value-bind)
+
+(define-mumble-macro mumble::let/cc (variable &rest body)
+  (let ((tagvar  (gensym)))
+    `(let* ((,tagvar   (gensym))
+	    (,variable (let/cc-aux ,tagvar)))
+	(catch ,tagvar (locally ,@body)))))
+
+(defun let/cc-aux (tag)
+  #'(lambda (&rest values)
+      (throw tag (values-list values))))
+
+
+(define-mumble-import unwind-protect)
+
+(define-mumble-import declare)
+(define-mumble-import ignore)
+
+
+;;; IGNORABLE is part of ANSI CL but not implemented by Lucid yet.
+;;; IGNORE in Lucid seems to behave like what ANSI CL says IGNORABLE 
+;;; should do, but there doesn't seem to be any way to rename it.
+
+#+(or lucid akcl lispworks wcl)
+(progn
+  (proclaim '(declaration mumble::ignorable))
+  (define-mumble-import mumble::ignorable))
+
+#+(or cmu mcl allegro)
+(define-mumble-import cl:ignorable)
+
+#-(or lucid cmu allegro akcl mcl lispworks wcl)
+(missing-mumble-definition mumble::ignorable)
+
+
+(define-mumble-import type)
+
+
+
+;;;=====================================================================
+;;; Definitions
+;;;=====================================================================
+
+
+;;; *** This shouldn't really do a DEFPARAMETER, since that proclaims
+;;; *** the variable SPECIAL and makes any LETs of the variable do
+;;; *** special binding rather than lexical binding.  But if you just
+;;; *** SETF the variable, you'll get a compiler warning about an
+;;; *** undeclared free variable on every reference!!!  Argggh.
+
+(define-mumble-macro mumble::define (pattern &rest value)
+  (if (consp pattern)
+      `(defun ,(car pattern) ,(mung-lambda-list (cdr pattern)) ,@value)
+      `(defparameter ,pattern ,(car value))))
+
+(define-mumble-macro mumble::define-integrable (pattern &rest value)
+  (if (consp pattern)
+      `(progn
+	 (eval-when (eval compile load)
+	   (proclaim '(inline ,(car pattern))))
+	 (defun ,(car pattern) ,(mung-lambda-list (cdr pattern)) ,@value))
+      `(defconstant ,pattern ,(car value))))
+
+
+(define-mumble-macro mumble::define-syntax (pattern . body)
+  `(defmacro ,(car pattern) ,(mung-lambda-list (cdr pattern)) ,@body))
+
+(define-mumble-macro mumble::define-local-syntax (pattern . body)
+  `(eval-when (eval compile)
+     (defmacro ,(car pattern) ,(mung-lambda-list (cdr pattern)) ,@body)))
+
+
+(define-mumble-macro mumble::define-setf (getter setter)
+  `(define-setf-method ,getter (&rest subforms)
+     (define-setf-aux ',setter ',getter subforms)))
+
+(defun define-setf-aux (setter getter subforms)
+  (let ((temps    nil)
+	(tempvals nil)
+	(args     nil)
+	(store  (gensym)))
+    (dolist (x subforms)
+      (if (constantp x)
+	  (push x args)
+	  (let ((temp  (gensym)))
+	    (push temp temps)
+	    (push x tempvals)
+	    (push temp args))))
+    (setq temps (nreverse temps))
+    (setq tempvals (nreverse tempvals))
+    (setq args (nreverse args))
+    (values temps
+	    tempvals
+	    (list store)
+	    `(,setter ,store ,@args)
+	    `(,getter ,@args))))
+
+
+;;; Declaring variables special will make the compiler not proclaim
+;;; about references to them.
+;;; A proclamation works to disable undefined function warnings in 
+;;; most Lisps.  Harlequin seems to offer no way to shut up these warnings.
+;;; In allegro, we have to work around a bug in the compiler's handling
+;;; of PROCLAIM.
+
+(define-mumble-macro mumble::predefine (pattern)
+  `(eval-when (eval compile)
+     #+allegro (let ((excl::*compiler-environment* nil))
+		 (do-predefine ',pattern))
+     #-allegro (do-predefine ',pattern)
+     ))
+
+(eval-when (eval compile load)
+  (defun do-predefine (pattern)
+    (if (consp pattern)
+        (proclaim `(ftype (function ,(mung-decl-lambda-list (cdr pattern)) t)
+			  ,(car pattern)))
+	(proclaim `(special ,pattern))))
+  (defun mung-decl-lambda-list (lambda-list)
+    (cond ((consp lambda-list)
+	   (cons 't (mung-decl-lambda-list (cdr lambda-list))))
+	  ((null lambda-list)
+	   '())
+	  (t
+	   '(&rest t))))
+  )
+
+
+;;; CMUCL doesn't complain about function redefinitions, but Lucid does.
+
+#+(or cmu akcl mcl lispworks wcl)
+(define-mumble-macro mumble::redefine (pattern . value)
+  `(mumble::define ,pattern ,@value))
+
+#+lucid
+(define-mumble-macro mumble::redefine (pattern . value)
+  `(let ((lcl:*redefinition-action*  nil))
+     (mumble::define ,pattern ,@value)))
+
+#+allegro
+(define-mumble-macro mumble::redefine (pattern . value)
+  `(let ((excl:*redefinition-warnings*  nil))
+     (mumble::define ,pattern ,@value)))
+
+#-(or cmu lucid allegro akcl mcl lispworks wcl)
+(missing-mumble-definition mumble::redefine)
+
+
+#+(or cmu akcl mcl lispworks wcl)
+(define-mumble-macro mumble::redefine-syntax (pattern . body)
+  `(mumble::define-syntax ,pattern ,@body))
+
+#+lucid
+(define-mumble-macro mumble::redefine-syntax (pattern . body)
+  `(eval-when (eval compile load)
+     (let ((lcl:*redefinition-action*  nil))
+       (mumble::define-syntax ,pattern ,@body))))
+
+#+allegro
+(define-mumble-macro mumble::redefine-syntax (pattern . body)
+  `(eval-when (eval compile load)
+     (let ((excl:*redefinition-warnings*  nil))
+       (mumble::define-syntax ,pattern ,@body))))
+  
+#-(or cmu lucid allegro akcl mcl lispworks wcl)
+(missing-mumble-definition mumble::redefine-syntax)
+
+
+
+;;;=====================================================================
+;;; Equivalence
+;;;=====================================================================
+
+(define-mumble-function-inline mumble::eq? (x y)
+  (eq x y))
+(define-mumble-function-inline mumble::eqv? (x y)
+  (eql x y))
+
+(define-mumble-function mumble::equal? (x1 x2)
+  (cond ((eql x1 x2)
+	 t)
+	((consp x1)
+	 (and (consp x2)
+	      (mumble::equal? (car x1) (car x2))
+	      (mumble::equal? (cdr x1) (cdr x2))))
+	((simple-string-p x1)
+	 (and (simple-string-p x2)
+	      (string= x1 x2)))
+	((simple-vector-p x1)
+	 (and (simple-vector-p x2)
+	      (eql (length (the simple-vector x1))
+		   (length (the simple-vector x2)))
+	      (every #'mumble::equal?
+		     (the simple-vector x1)
+		     (the simple-vector x2))))
+	(t nil)))
+
+
+;;;=====================================================================
+;;; Lists
+;;;=====================================================================
+
+(define-mumble-function-inline mumble::pair? (x)
+  (consp x))
+
+(define-mumble-import cons)
+
+
+;;; Can't import this directly because of type problems.
+
+(define-mumble-synonym mumble::list list)
+
+(define-mumble-function-inline mumble::make-list (length &optional (init nil))
+  (the list
+       (make-list length :initial-element init)))
+
+(define-mumble-import car)
+(define-mumble-import cdr)
+(define-mumble-import caar)
+(define-mumble-import cadr)
+(define-mumble-import cadr)
+(define-mumble-import cddr)
+(define-mumble-import caaar)
+(define-mumble-import caadr)
+(define-mumble-import caadr)
+(define-mumble-import caddr)
+(define-mumble-import cdaar)
+(define-mumble-import cdadr)
+(define-mumble-import cdadr)
+(define-mumble-import cdddr)
+(define-mumble-import caaaar)
+(define-mumble-import caaadr)
+(define-mumble-import caaadr)
+(define-mumble-import caaddr)
+(define-mumble-import cadaar)
+(define-mumble-import cadadr)
+(define-mumble-import cadadr)
+(define-mumble-import cadddr)
+(define-mumble-import cdaaar)
+(define-mumble-import cdaadr)
+(define-mumble-import cdaadr)
+(define-mumble-import cdaddr)
+(define-mumble-import cddaar)
+(define-mumble-import cddadr)
+(define-mumble-import cddadr)
+(define-mumble-import cddddr)
+
+(define-mumble-function-inline mumble::null? (x)
+  (null x))
+
+(define-mumble-function mumble::list? (x)
+  (cond ((null x) t)
+	((consp x) (mumble::list? (cdr x)))
+	(t nil)))
+
+(define-mumble-function-inline mumble::length (x)
+  (the fixnum (length (the list x))))
+
+(define-mumble-import append)
+(define-mumble-import nconc)
+
+(define-mumble-function-inline mumble::reverse (x)
+  (the list (reverse (the list x))))
+(define-mumble-function-inline mumble::nreverse (x)
+  (the list (nreverse (the list x))))
+
+(define-mumble-function-inline mumble::list-tail (list n)
+  (nthcdr n list))
+(define-mumble-function-inline mumble::list-ref (list n)
+  (nth n list))
+
+(define-mumble-import last)
+(define-mumble-import butlast)
+
+(define-setf-method mumble::list-ref (list n)
+  (get-setf-method `(nth ,n ,list)))
+
+(define-mumble-function-inline mumble::memq (object list)
+  (member object list :test #'eq))
+(define-mumble-function-inline mumble::memv (object list)
+  (member object list))
+(define-mumble-function-inline mumble::member (object list)
+  (member object list :test #'mumble::equal?))
+
+;;; *** The Lucid compiler is not doing anything inline for assq so
+;;; *** I'm rewriting this  -- jcp
+(define-mumble-function mumble::assq (object list)
+  (if (null list)
+      nil
+      (if (eq object (caar list))
+          (car list)
+	  (mumble::assq object (cdr list)))))
+	
+(define-mumble-function-inline mumble::assv (object list)
+  (assoc object list))
+(define-mumble-function-inline mumble::assoc (object list)
+  (assoc object list :test #'mumble::equal?))
+
+(define-mumble-import push)
+(define-mumble-import pop)
+
+(define-mumble-synonym mumble::list-copy copy-list)
+
+
+;;;=====================================================================
+;;; Symbols
+;;;=====================================================================
+
+(define-mumble-function-inline mumble::symbol? (x)
+  (symbolp x))
+(define-mumble-synonym mumble::symbol->string symbol-name)
+
+(define-mumble-function-inline mumble::string->symbol (x)
+  (intern x))
+
+
+;;; We want a gensym that follows the new ANSI CL gensym-name-stickiness
+;;; decision.
+
+#+(or lucid akcl wcl)
+(define-mumble-function mumble::gensym (&optional (prefix "G"))
+  (gensym prefix))
+
+#+(or cmu allegro mcl lispworks)
+(define-mumble-import gensym)
+
+#-(or lucid akcl wcl cmu allegro mcl lispworks)
+(missing-mumble-definition mumble::gensym)
+
+(define-mumble-function mumble::gensym? (x)
+  (and (symbolp x)
+       (not (symbol-package x))))
+
+(defun symbol-append (&rest symbols)
+  (intern (apply #'concatenate 'string (mapcar #'symbol-name symbols))))
+(define-mumble-import symbol-append)
+
+
+;;;=====================================================================
+;;; Characters
+;;;=====================================================================
+
+(define-mumble-function-inline mumble::char? (x)
+  (characterp x))
+
+(define-mumble-synonym mumble::char=? char=)
+(define-mumble-synonym mumble::char<? char<)
+(define-mumble-synonym mumble::char>? char>)
+(define-mumble-synonym mumble::char>=? char>=)
+(define-mumble-synonym mumble::char<=? char<=)
+
+(define-mumble-synonym mumble::char-ci=? char-equal)
+(define-mumble-synonym mumble::char-ci<? char-lessp)
+(define-mumble-synonym mumble::char-ci>? char-greaterp)
+(define-mumble-synonym mumble::char-ci>=? char-not-lessp)
+(define-mumble-synonym mumble::char-ci<=? char-not-greaterp)
+
+(define-mumble-synonym mumble::char-alphabetic? alpha-char-p)
+(define-mumble-synonym mumble::char-numeric? digit-char-p)
+
+(define-mumble-function mumble::char-whitespace? (c)
+  (member c '(#\space #\tab #\newline #\linefeed #\page #\return)))
+
+(define-mumble-synonym mumble::char-upper-case? upper-case-p)
+(define-mumble-synonym mumble::char-lower-case? lower-case-p)
+
+(define-mumble-synonym mumble::char->integer char-code)
+(define-mumble-synonym mumble::integer->char code-char)
+
+(define-mumble-import char-upcase)
+(define-mumble-import char-downcase)
+(define-mumble-import char-name)
+
+(define-mumble-synonym mumble::char->digit digit-char-p)
+
+
+;;;=====================================================================
+;;; Strings
+;;;=====================================================================
+
+(define-mumble-function-inline mumble::string? (x)
+  (simple-string-p x))
+
+(define-mumble-function-inline mumble::make-string
+      (length &optional (init nil init-p))
+  (the simple-string
+       (if init-p
+	   (make-string length :initial-element init)
+	   (make-string length))))
+
+(define-mumble-function-inline mumble::string (char &rest more-chars)
+  (the simple-string (coerce (cons char more-chars) 'string)))
+
+(define-mumble-function-inline mumble::string-length (string)
+  (the fixnum (length (the simple-string string))))
+
+(define-mumble-function-inline mumble::string-ref (x n)
+  (the character (schar (the simple-string x) (the fixnum n))))
+
+(define-setf-method mumble::string-ref (string n)
+  (get-setf-method `(schar ,string ,n)))
+
+(define-mumble-synonym mumble::string=? string=)
+(define-mumble-synonym mumble::string<? string<)
+(define-mumble-synonym mumble::string>? string>)
+(define-mumble-synonym mumble::string<=? string<=)
+(define-mumble-synonym mumble::string>=? string>=)
+
+(define-mumble-synonym mumble::string-ci=? string-equal)
+(define-mumble-synonym mumble::string-ci<? string-lessp)
+(define-mumble-synonym mumble::string-ci>? string-greaterp)
+(define-mumble-synonym mumble::string-ci<=? string-not-greaterp)
+(define-mumble-synonym mumble::string-ci>=? string-not-lessp)
+
+(define-mumble-function-inline mumble::substring (string start end)
+  (the simple-string (subseq (the simple-string string) start end)))
+
+(define-mumble-function-inline mumble::string-append
+      (string &rest more-strings)
+  (declare (type simple-string string))
+  (the simple-string (apply #'concatenate 'string string more-strings)))
+
+(define-mumble-function-inline mumble::string->list (string)
+  (the list (coerce (the simple-string string) 'list)))
+
+(define-mumble-function-inline mumble::list->string (list)
+  (the simple-string (coerce (the list list) 'string)))
+
+(define-mumble-function-inline mumble::string-copy (string)
+  (the simple-string (copy-seq (the simple-string string))))
+
+(define-mumble-import string-upcase)
+(define-mumble-import string-downcase)
+
+
+;;;=====================================================================
+;;; Vectors
+;;;=====================================================================
+
+(define-mumble-function-inline mumble::vector? (x)
+  (simple-vector-p x))
+
+(define-mumble-function-inline mumble::make-vector
+      (length &optional (init nil init-p))
+  (declare (type fixnum length))
+  (the simple-vector
+       (if init-p
+	   (make-array length :initial-element init)
+	   (make-array length))))
+
+
+;;; Can't import directly because types are incompatible.
+
+(define-mumble-synonym mumble::vector vector)
+
+(define-mumble-function-inline mumble::vector-length (vector)
+  (the fixnum (length (the simple-vector vector))))
+
+(define-mumble-function-inline mumble::vector-ref (x n)
+  (svref (the simple-vector x) (the fixnum n)))
+
+(define-setf-method mumble::vector-ref (vector n)
+  (get-setf-method `(svref ,vector ,n)))
+
+(define-mumble-function-inline mumble::vector->list (vector)
+  (the list (coerce (the simple-vector vector) 'list)))
+
+(define-mumble-function-inline mumble::list->vector (list)
+  (the simple-vector (coerce (the list list) 'simple-vector)))
+
+(define-mumble-function-inline mumble::vector-copy (vector)
+  (the simple-vector (copy-seq (the simple-vector vector))))
+
+
+;;;=====================================================================
+;;; Numbers
+;;;=====================================================================
+
+(define-mumble-synonym mumble::number? numberp)
+(define-mumble-synonym mumble::integer? integerp)
+(define-mumble-synonym mumble::rational? rationalp)
+(define-mumble-synonym mumble::float? floatp)
+
+(define-mumble-function-inline mumble::fixnum? (x)
+  (typep x 'fixnum))
+
+(define-mumble-synonym mumble::exact->inexact float)
+
+(define-mumble-import =)
+(define-mumble-import <)
+(define-mumble-import >)
+(define-mumble-import <=)
+(define-mumble-import >=)
+
+(define-mumble-synonym mumble::zero? zerop)
+(define-mumble-function-inline mumble::positive? (x)
+  (> x 0))
+(define-mumble-function-inline mumble::negative? (x)
+  (< x 0))
+
+(define-mumble-import min)
+(define-mumble-import max)
+
+(define-mumble-import +)
+(define-mumble-import *)
+(define-mumble-import -)
+(define-mumble-import /)
+
+(define-mumble-synonym mumble::quotient floor)
+(define-mumble-synonym mumble::remainder rem)
+(define-mumble-synonym mumble::modulo mod)
+
+(define-mumble-function-inline mumble::floor (x)
+  (if (floatp x) (ffloor x) (floor (the rational x))))
+(define-mumble-function-inline mumble::ceiling (x)
+  (if (floatp x) (fceiling x) (ceiling (the rational x))))
+(define-mumble-function-inline mumble::truncate (x)
+  (if (floatp x) (ftruncate x) (truncate (the rational x))))
+(define-mumble-function-inline mumble::round (x)
+  (if (floatp x) (fround x) (round (the rational x))))
+
+(define-mumble-synonym mumble::floor->exact floor)
+(define-mumble-synonym mumble::ceiling->exact ceiling)
+(define-mumble-synonym mumble::truncate->exact truncate)
+(define-mumble-synonym mumble::round->exact round)
+
+(define-mumble-import 1+)
+(define-mumble-import 1-)
+(define-mumble-import incf)
+(define-mumble-import decf)
+
+(define-mumble-function mumble::number->string (number &optional (radix 10))
+  (let ((*print-base*  radix))
+    (prin1-to-string number)))
+
+(define-mumble-function mumble::string->number (string &optional (radix 10))
+  (let ((*read-base* radix))
+    (read-from-string string)))
+
+(define-mumble-import expt)
+
+
+
+;;;=====================================================================
+;;; Tables
+;;;=====================================================================
+
+(define-mumble-synonym mumble::table? hash-table-p)
+
+(define-mumble-function-inline mumble::make-table ()
+  (make-hash-table :test #'eq))
+
+(define-mumble-function-inline mumble::table-entry (table key)
+  (gethash key table))
+
+(define-setf-method mumble::table-entry (table key)
+  (get-setf-method `(gethash ,key ,table)))
+
+(define-mumble-synonym mumble::table-for-each maphash)
+
+(define-mumble-function mumble::copy-table (old-table)
+  (let ((new-table  (make-hash-table :test #'eq
+				     :size (1+ (hash-table-count old-table)))))
+    (maphash #'(lambda (key val) (setf (gethash key new-table) val))
+	     old-table)
+    new-table))
+
+
+;;;=====================================================================
+;;; I/O
+;;;=====================================================================
+
+(define-mumble-function-inline mumble::call-with-input-file (string proc)
+  (with-open-file (stream (expand-filename string) :direction :input)
+    (funcall (the function proc) stream)))
+
+(define-mumble-function-inline mumble::call-with-output-file (string proc)
+  (with-open-file (stream (expand-filename string)
+			  :direction :output :if-exists :new-version)
+    (funcall (the function proc) stream)))
+
+(define-mumble-function-inline mumble::call-with-input-string (string proc)
+  (with-input-from-string (stream string)
+     (funcall (the function proc) stream)))
+
+(define-mumble-function-inline mumble::call-with-output-string (proc)
+  (with-output-to-string (stream)
+    (funcall (the function proc) stream)))
+
+(define-mumble-synonym mumble::input-port? input-stream-p)
+(define-mumble-synonym mumble::output-port? output-stream-p)
+
+(define-mumble-function-inline mumble::current-input-port ()
+  *standard-input*)
+(define-mumble-function-inline mumble::current-output-port ()
+  *standard-output*)
+
+(define-mumble-function-inline mumble::open-input-file (string)
+  (open (expand-filename string) :direction :input))
+
+(define-mumble-function-inline mumble::open-output-file (string)
+  (open (expand-filename string) :direction :output :if-exists :new-version))
+
+
+(define-mumble-synonym mumble::close-input-port close)
+(define-mumble-synonym mumble::close-output-port close)
+
+(defvar *eof-object* (make-symbol "EOF"))
+
+(define-mumble-function-inline mumble::read
+      (&optional (port *standard-input*))
+  (read port nil *eof-object*))
+
+(define-mumble-function-inline mumble::read-char
+      (&optional (port *standard-input*))
+  (read-char port nil *eof-object*))
+
+(define-mumble-function-inline mumble::peek-char
+      (&optional (port *standard-input*))
+  (peek-char nil port nil *eof-object*))
+
+(define-mumble-function-inline mumble::read-line
+      (&optional (port *standard-input*))
+  (read-line port nil *eof-object*))
+
+(define-mumble-function-inline mumble::eof-object? (x)
+  (eq x *eof-object*))
+
+
+;;;=====================================================================
+;;; Printer
+;;;=====================================================================
+
+(define-mumble-function mumble::internal-write (object port)
+  (write object :stream port))
+(define-mumble-function-inline mumble::internal-output-width (port)
+  (declare (ignore port))
+  nil)
+(define-mumble-function-inline mumble::internal-output-position (port)
+  (declare (ignore port))
+  nil)
+(define-mumble-synonym mumble::internal-write-char write-char)
+(define-mumble-function-inline mumble::internal-write-string
+                               (string port start end)
+  (write-string string port :start start :end end))
+(define-mumble-synonym mumble::internal-newline terpri)
+(define-mumble-synonym mumble::internal-fresh-line fresh-line)
+(define-mumble-synonym mumble::internal-finish-output finish-output)
+(define-mumble-synonym mumble::internal-force-output force-output)
+(define-mumble-synonym mumble::internal-clear-output clear-output)
+
+(define-mumble-function mumble::internal-write-to-string (object)
+  (write-to-string object))
+
+
+(define-mumble-function-inline mumble::internal-warning (string)
+  (warn "~a" string))
+
+(define-mumble-function-inline mumble::internal-error (string)
+  (error "~a" string))
+
+
+;;; Printer stuff used directly by the pretty printer
+
+(define-mumble-import *print-escape*)
+(define-mumble-import *print-circle*)
+(define-mumble-import *print-pretty*)
+(define-mumble-import *print-level*)
+(define-mumble-import *print-length*)
+(define-mumble-import *print-base*)
+(define-mumble-import *print-radix*)
+
+
+;;; These functions and variables are all defined with the XP stuff.  But,
+;;; let's export all the symbols from the mumble package.
+
+(define-mumble-import mumble::write)
+(define-mumble-import mumble::print)
+(define-mumble-import mumble::prin1)
+(define-mumble-import mumble::princ)
+(define-mumble-import mumble::pprint)
+(define-mumble-import mumble::prin1-to-string)
+(define-mumble-import mumble::princ-to-string)
+(define-mumble-import mumble::write-char)
+(define-mumble-import mumble::write-string)
+(define-mumble-import mumble::write-line)
+(define-mumble-import mumble::terpri)
+(define-mumble-import mumble::fresh-line)
+(define-mumble-import mumble::finish-output)
+(define-mumble-import mumble::force-output)
+(define-mumble-import mumble::clear-output)
+(define-mumble-import mumble::display)
+(define-mumble-import mumble::newline)
+(define-mumble-import mumble::*print-shared*)
+(define-mumble-import mumble::*print-dispatch*)
+(define-mumble-import mumble::*print-right-margin*)
+(define-mumble-import mumble::*print-miser-width*)
+(define-mumble-import mumble::*print-lines*)
+(define-mumble-import mumble::*default-right-margin*)
+(define-mumble-import mumble::*last-abbreviated-printing*)
+(define-mumble-import mumble::*print-structure*)
+(define-mumble-import mumble::*print-structure-slots*)
+(define-mumble-import mumble::standard-print-dispatch)
+(define-mumble-import mumble::pprint-newline)
+(define-mumble-import mumble::pprint-logical-block)
+(define-mumble-import mumble::pprint-pop)
+(define-mumble-import mumble::pprint-exit-if-list-exhausted)
+(define-mumble-import mumble::pprint-indent)
+(define-mumble-import mumble::pprint-tab)
+(define-mumble-import mumble::pprint-fill)
+(define-mumble-import mumble::pprint-linear)
+(define-mumble-import mumble::pprint-tabular)
+(define-mumble-import mumble::format)
+(define-mumble-import mumble::warning)
+(define-mumble-import mumble::error)
+
+
+;;; These are keywords for pprint-newline.
+
+(define-mumble-import mumble::linear)
+(define-mumble-import mumble::fill)
+(define-mumble-import mumble::miser)
+(define-mumble-import mumble::mandatory)
+
+;;; These are keywords for pprint-indent
+
+;; (define-mumble-import mumble::block)  ; already imported as special form
+(define-mumble-import mumble::current)
+
+;;; These are keywords for pprint-tab
+
+(define-mumble-import mumble::line)
+(define-mumble-import mumble::section)
+(define-mumble-import mumble::line-relative)
+(define-mumble-import mumble::section-relative)
+
+
+;;;=====================================================================
+;;; System Interface
+;;;=====================================================================
+
+(define-mumble-import macroexpand-1)
+(define-mumble-import macroexpand)
+
+
+;;; WITH-COMPILATION-UNIT is an ANSI CL feature that isn't yet
+;;; supported by all Lisps.
+
+#+lucid
+(define-mumble-macro mumble::with-compilation-unit (options &body body)
+  (declare (ignore options))
+  `(lcl:with-deferred-warnings ,@body))
+
+#+(or cmu mcl allegro lispworks)
+(define-mumble-import with-compilation-unit)
+
+#+(or akcl wcl)
+(define-mumble-macro mumble::with-compilation-unit (options &body body)
+  (declare (ignore options))
+  `(progn ,@body))
+
+#-(or lucid allegro cmu akcl mcl lispworks wcl)
+(missing-mumble-definition mumble::with-compilation-unit)
+
+
+(define-mumble-function mumble::eval (form &optional compile-p)
+  (if compile-p
+      (mumble::with-compilation-unit ()
+        (eval-compiling-functions form))
+      (eval form)))
+
+
+;;; Simply doing (funcall (compile nil `(lambda () ,form))) would work
+;;; except that top-level-ness actions would be lost (causing extraneous
+;;; warning messages about global variables whose references are compiled
+;;; before a previous predefine is executed, etc).  So make an attempt
+;;; to process nested top-level forms in order.  This doesn't look for
+;;; all of the common-lispy things that might show up in macro expansions,
+;;; but it's close enough.
+
+(defun eval-compiling-functions (form)
+  (if (atom form)
+      (eval form)
+      (let ((fn  (car form)))
+	(cond ((or (eq fn 'mumble::begin)
+		   (eq fn 'progn))
+	       (do ((forms (cdr form) (cdr forms)))
+		   ((null (cdr forms)) (eval-compiling-functions (car forms)))
+		   (eval-compiling-functions (car forms))))
+	      ((eq fn 'mumble::define)
+	       (if (consp (cadr form))
+		   (compile-define form)
+		   (compile-other form)))
+	      ((eq fn 'mumble::define-integrable)
+	       (if (consp (cadr form))
+		   (progn
+		     (proclaim `(inline ,(car (cadr form))))
+		     (compile-define form))
+		   (compile-other form)))
+	      ((eq fn 'mumble::predefine)
+	       (do-predefine (cadr form)))
+	      ((macro-function fn)
+	       (eval-compiling-functions (macroexpand-1 form)))
+	      (t
+	       (compile-other form))))))
+
+(defun compile-define (form)
+  (let ((name  (car (cadr form)))
+	(args  (mung-lambda-list (cdr (cadr form))))
+	(body  (cddr form)))
+    (compile name `(lambda ,args ,@body))
+    name))
+
+(defun compile-other (form)
+  (funcall (compile nil `(lambda () ,form))))
+
+
+;;; Load and compile-file aren't directly imported from the host
+;;; Common Lisp because we want to do our own defaulting of file
+;;; name extensions.
+
+(define-mumble-function mumble::load (filename)
+  (setq filename (expand-filename filename))
+  (if (string= (mumble::filename-type filename) "")
+      (let ((source-file  (build-source-filename filename))
+	    (binary-file  (build-binary-filename filename)))
+	(if (and (probe-file binary-file)
+		 (> (file-write-date binary-file)
+		    (file-write-date source-file)))
+	    (load binary-file)
+	    (load source-file)))
+      (load filename)))
+
+
+;;; This is used to control OPTIMIZE declarations in a somewhat more
+;;; portable way -- different implementations may need slightly different
+;;; combinations.
+;;; 0 = do as little as possible when compiling code
+;;; 1 = use "default" compiler settings
+;;; 2 = omit safety checks and do "easy" speed optimizations.
+;;; 3 = do as much as possible; type inference, inlining, etc.  May be slow.
+;;; #f = don't mess with optimize settings.
+
+(defvar *code-quality* nil)
+(define-mumble-import *code-quality*)
+
+(defun code-quality-hack (q)
+  (cond ((eql q 0)
+	 (proclaim '(optimize (speed 1) (safety 3) (compilation-speed 3)
+			      #+cmu (ext:debug 1)  
+                              #+(or mcl allegro lispworks) (debug 1)
+			      )))
+	((eql q 1)
+	 (proclaim '(optimize (speed 1) (safety 1) (compilation-speed 3)
+			      #+cmu (ext:debug 1)
+                              #+(or mcl allegro lispworks) (debug 1)
+			      )))
+	((eql q 2)
+	 (proclaim '(optimize (speed 3) (safety 0) (compilation-speed 3)
+			      #+cmu (ext:debug 0)
+                              #+(or mcl allegro lispworks) (debug 0)
+			      )))
+	((eql q 3)
+	 (proclaim '(optimize (speed 3) (safety 0) (compilation-speed 0)
+			      #+cmu (ext:debug 0)
+                              #+(or mcl allegro lispworks) (debug 0)
+			      )))
+	(t
+	 (warn "Bogus *code-quality* setting ~s." q))))
+
+
+;;; If we don't do this, code generated with high code-quality settings
+;;; can't be interrupted with ^C.
+
+#+allegro
+(setf compiler:generate-interrupt-checks-switch
+      #'(lambda (safety space speed debug)
+	  (declare (ignore safety space speed debug))
+	  t))
+
+
+;;; Note that we expect the binary filename (if supplied) to be
+;;; relative to the current directory, not to the source filename.
+;;; Lucid and AKCL (and maybe other implementations) merge the :output-file
+;;; pathname with the source filename, but the merge by expand-filename
+;;; should prevent it from doing anything.
+
+(define-mumble-function mumble::compile-file (filename &optional binary)
+  (if *code-quality* (code-quality-hack *code-quality*))
+  (setq filename (expand-filename filename))
+  (if (string= (mumble::filename-type filename) "")
+      (setq filename (build-source-filename filename)))
+  (if binary
+      (compile-file filename :output-file (expand-filename binary))
+      (compile-file filename)))
+
+
+;;; See cl-init.lisp for initialization of *lisp-binary-file-type*.
+
+(defconstant source-file-type ".scm")
+(defconstant binary-file-type *lisp-binary-file-type*)
+(define-mumble-import source-file-type)
+(define-mumble-import binary-file-type)
+
+
+(defun build-source-filename (filename)
+  (mumble::assemble-filename filename filename source-file-type))
+
+(defun build-binary-filename (filename)
+  (mumble::assemble-filename filename filename binary-file-type))
+
+(proclaim '(ftype (function (simple-string) simple-string)
+		  mumble::filename-place
+		  mumble::filename-name
+		  mumble::filename-type
+		  expand-filename))
+
+(proclaim '(ftype (function (simple-string simple-string simple-string)
+			    simple-string)
+		  mumble::assemble-filename))
+
+(define-mumble-function mumble::assemble-filename (place name type)
+  (concatenate 'string
+	       (mumble::filename-place place)
+	       (mumble::filename-name name)
+	       (mumble::filename-type type)))
+
+(define-mumble-function mumble::filename-place (filename)
+  (declare (simple-string filename))
+  (let ((slash  (position #\/ filename :from-end t)))
+    (if slash
+	(subseq filename 0 (1+ slash))
+	"")))
+
+(define-mumble-function mumble::filename-name (filename)
+  (declare (simple-string filename))
+  (let* ((slash  (position #\/ filename :from-end t))
+	 (beg    (if slash (1+ slash) 0))
+	 (dot    (position #\. filename :start beg)))
+    (if (or slash dot)
+	(subseq filename beg (or dot (length filename)))
+	filename)))
+
+(define-mumble-function mumble::filename-type (filename)
+  (declare (simple-string filename))
+  (let* ((slash  (position #\/ filename :from-end t))
+	 (beg    (if slash (1+ slash) 0))
+	 (dot    (position #\. filename :start beg)))
+    (if dot
+	(subseq filename dot (length filename))
+	"")))
+
+
+;;; This function is called by all functions that pass filenames down
+;;; to the operating system.  It does environment variable substitution
+;;; and merging with *default-pathname-defaults* (set by the cd function).
+;;; Since this function translates mumble's notion of pathnames into
+;;; a lower-level representation, this function should never need to
+;;; be called outside of this file.
+
+(defun expand-filename (filename)
+  (declare (simple-string filename))
+  (namestring
+    (merge-pathnames
+      (fix-filename-syntax 
+        (if (eql (schar filename 0) #\$)
+	    (let* ((end    (length filename))
+		   (slash  (or (position #\/ filename) end))
+		   (new    (mumble::getenv (subseq filename 1 slash))))
+	      (if new
+		  (concatenate 'string new (subseq filename slash end))
+		  filename))
+	    filename)
+        ))))
+
+
+;;; On non-unix machines, may need to change the mumble unix-like filename
+;;; syntax to whatever the normal syntax used by the implementation is.
+
+#+mcl
+(defun fix-filename-syntax (filename)
+  (substitute #\: #\/ filename))
+
+#-mcl
+(defun fix-filename-syntax (filename)
+  filename)
+
+
+;;; AKCL's compile-file merges the output pathname against the input
+;;; pathname.  If the output pathname doesn't have an explicit directory
+;;; but the input pathname does, the wrong thing will happen.  This
+;;; hack is so that expand-filename will always put a directory
+;;; specification on both pathnames.
+;;; Lucid CL does similar merging, but *default-pathname-defaults*
+;;; already defaults to the truename of the current directory.
+
+#+akcl
+(setf *default-pathname-defaults* (truename "./"))
+
+
+;;; WCL's *default-pathname-defaults* is OK except that it has a
+;;; type of .lisp, which is inappropriate.
+
+#+wcl
+(setf *default-pathname-defaults*
+      (make-pathname :directory
+		     (pathname-directory *default-pathname-defaults*)))
+
+#+(or mcl lispworks)
+(setf *default-pathname-defaults*
+      (truename *default-pathname-defaults*))
+
+
+(define-mumble-function mumble::file-exists? (filename)
+  (probe-file (expand-filename filename)))
+
+(define-mumble-function mumble::file-write-date (filename)
+  (file-write-date (expand-filename filename)))
+
+(define-mumble-synonym mumble::current-date get-universal-time)
+
+(define-mumble-function mumble::get-run-time ()
+  (/ (get-internal-run-time) (float internal-time-units-per-second)))
+
+
+;;; Get environment variables
+
+#+lucid
+(progn
+  (mumble::predefine (mumble::getenv string))
+  (define-mumble-synonym mumble::getenv lcl:environment-variable))
+
+#+cmu
+(define-mumble-function mumble::getenv (string)
+  (let ((symbol  (intern string (find-package "KEYWORD"))))
+    (cdr (assoc symbol extensions:*environment-list*))))
+
+#+(or akcl allegro lispworks)
+(define-mumble-function mumble::getenv (string)
+  (system::getenv string))
+
+#+wcl
+(define-mumble-function mumble::getenv (string)
+  (lisp:getenv string))
+
+
+;;; Hmmm.  The Mac doesn't have environment variables, so we'll have to
+;;; roll our own.
+
+#+mcl
+(progn
+  (defvar *environment-alist* '())
+  (define-mumble-function mumble::getenv (string)
+    (cdr (assoc string *environment-alist* :test #'string=)))
+  )
+
+
+#-(or lucid allegro cmu akcl mcl lispworks wcl)
+(missing-mumble-definition mumble::getenv)
+
+
+;;; Change working directory.
+;;; This stores a directory pathname in *default-pathname-defaults*.
+;;; See also expand-filename.
+
+(define-mumble-function mumble::cd (filename)
+  (if (not (eql (schar filename (1- (length filename))) #\/))
+      (setq filename (concatenate 'string filename "/")))
+  (setq *default-pathname-defaults* (pathname (expand-filename filename))))
+ 
+
+;;; Leave Lisp
+
+#+lucid
+(define-mumble-synonym mumble::exit lcl:quit)
+
+#+allegro
+(define-mumble-synonym mumble::exit excl:exit)
+
+#+cmu
+(define-mumble-synonym mumble::exit  extensions:quit)
+
+#+akcl
+(define-mumble-synonym mumble::exit lisp:bye)
+
+#+mcl
+(define-mumble-synonym mumble::exit ccl:quit)
+
+#+lispworks
+(define-mumble-synonym mumble::exit lw:bye)
+
+#+wcl
+(define-mumble-synonym mumble::exit lisp:quit)
+
+    
+#-(or lucid allegro cmu akcl mcl lispworks wcl)
+(missing-mumble-definition mumble::exit)
+
+
+
+;;;=====================================================================
+;;; Reader support
+;;;=====================================================================
+
+
+;;; Make the default readtable recognize #f and #t.
+;;; CMUCL's loader rebinds *readtable* when loading file, so can't
+;;; setq it here; hack the default readtable instead.
+
+#+(or cmu mcl allegro lispworks)
+(defparameter *mumble-readtable* *readtable*)
+
+#+(or lucid akcl wcl)
+(progn
+  (defparameter *mumble-readtable* (copy-readtable nil))
+  (setq *readtable* *mumble-readtable*)
+  )
+
+#-(or lucid allegro cmu akcl mcl lispworks wcl)
+(missing-mumble-definition *mumble-readtable*)
+
+
+;;; Lucid's debugger uses the standard readtable rather than *readtable*
+;;; unless you do this magic trick.
+
+#+lucid
+(sys:add-debugger-binding '*readtable* *mumble-readtable*)
+
+
+
+(set-dispatch-macro-character #\# #\f
+    #'(lambda (stream subchar arg)
+	(declare (ignore stream subchar arg))
+	nil))
+
+(set-dispatch-macro-character #\# #\t
+    #'(lambda (stream subchar arg)
+	(declare (ignore stream subchar arg))
+	t))
+
+
+
+;;;=====================================================================
+;;; Random stuff
+;;;=====================================================================
+
+(defconstant mumble::lisp-implementation-name *lisp-implementation-name*)
+(define-mumble-import mumble::lisp-implementation-name)
+
+(define-mumble-function mumble::identify-system ()
+  (format nil "~a version ~a on ~a"
+	  (or (lisp-implementation-type)
+	      "Generic Common Lisp")
+	  (or (lisp-implementation-version)
+	      "Generic")
+	  (or (machine-type)
+	      "Generic Machine")))
+
+(defconstant mumble::left-to-right-evaluation t)
+(define-mumble-import mumble::left-to-right-evaluation)
+
+
+#+excl
+(define-mumble-function mumble::gc-messages (onoff)
+  (setf (sys:gsgc-switch :print) onoff))
+#+cmu
+(define-mumble-function mumble::gc-messages (onoff)
+  (setf extensions:*gc-verbose* onoff))
+#+(or lispworks akcl wcl mcl)
+(define-mumble-function mumble::gc-messages (onoff)
+  onoff)   ; can't figure out if they have a hook or not
+#+lucid
+(define-mumble-function mumble::gc-messages (onoff)
+  (setf lcl:*gc-silence* (not onoff))
+  onoff)
+
+
+#-(or lucid cmu allegro akcl mcl lispworks wcl)
+(missing-mumble-definition mumble::gc-messages)
+
+
+(define-mumble-import identity)
diff --git a/cl-support/cl-init.lisp b/cl-support/cl-init.lisp
new file mode 100644
index 0000000..4d78cde
--- /dev/null
+++ b/cl-support/cl-init.lisp
@@ -0,0 +1,170 @@
+;;; cl-init.lisp -- initialize Common Lisp, loading cl-specific files.
+;;;
+;;; author :  Sandra Loosemore
+;;; date   :  23 Oct 1991
+;;;
+;;; All of the files loaded here are assumed to be regular Common Lisp
+;;; files.
+
+(in-package "MUMBLE-IMPLEMENTATION")
+
+
+;;; Turn off bogus warnings and messages!!!
+
+;;; Lucid complains if files don't start with IN-PACKAGE.
+#+lucid
+(setq lcl:*warn-if-no-in-package* '())
+
+
+;;; CMU CL prints too many compiler progress messages.
+#+cmu
+(progn
+  (setq *compile-print* '())
+  (setq *load-verbose* t)
+  )
+
+
+;;; AKCL complains if any package operations appear at top-level
+;;; after any other code.
+;;; Also prints useless notes about when it does tail recursion elimination.
+#+akcl
+(progn
+  (setq compiler:*suppress-compiler-notes* t)
+  (setq compiler:*compile-verbose* t)
+  (setq *load-verbose* t)
+  (setq compiler::*compile-ordinaries* t)
+  (si:putprop 'make-package nil 'compiler::package-operation)
+  (si:putprop 'shadow nil 'compiler::package-operation)
+  (si:putprop 'shadowing-import nil 'compiler::package-operation)
+  (si:putprop 'export nil 'compiler::package-operation)
+  (si:putprop 'unexport nil 'compiler::package-operation)
+  (si:putprop 'use-package nil 'compiler::package-operation)
+  (si:putprop 'unuse-package nil 'compiler::package-operation)
+  (si:putprop 'import nil 'compiler::package-operation)
+  (si:putprop 'provide nil 'compiler::package-operation)
+  (si:putprop 'require nil 'compiler::package-operation)
+  )
+
+
+;;; Allegro also issues too many messages.
+;;; ***We really ought to rename the defstructs that give the package
+;;; locked errors....
+
+#+allegro
+(progn
+  (setf *compile-print* nil)
+  (setf compiler:*cltl1-compile-file-toplevel-compatibility-p* nil)
+  (setq excl:*enable-package-locked-errors* nil)
+  (setf excl:*load-source-file-info* nil)
+  (setf excl:*record-source-file-info* nil)
+  (setf excl:*load-xref-info* nil)
+  (setf excl:*record-source-file-info* nil)
+  )
+
+
+;;; Harlequin Lispworks prints too many messages too.
+
+#+lispworks
+(progn
+  (setf *compile-print* nil)
+  (setf *load-print* nil)
+  (lw:toggle-source-debugging nil)
+  )
+
+
+;;; Load up definitions
+
+(defvar *lisp-source-file-type* ".lisp")
+(defvar *lisp-binary-file-type*
+  #+lucid
+  (namestring (make-pathname :type (car lcl:*load-binary-pathname-types*)))
+  #+allegro
+  (concatenate 'string "." excl:*fasl-default-type*)
+  #+cmu
+  (concatenate 'string "." (c:backend-fasl-file-type c:*backend*))
+  #+akcl
+  ".o"
+  #+mcl
+  ".fasl"
+  #+lispworks
+  ".wfasl"
+  #+wcl
+  ".o"
+  #-(or lucid allegro cmu akcl mcl lispworks wcl)
+  (error "Don't know how to initialize *LISP-BINARY-FILE-TYPE*.")
+  )
+
+(defvar *lisp-implementation-name*
+  #+lucid "lucid"
+  #+(and allegro next) "allegro-next"
+  #+(and allegro (not next)) "allegro"
+  #+cmu "cmu"
+  #+akcl "akcl"
+  #+mcl "mcl"
+  #+lispworks "lispworks"
+  #+wcl "wcl"
+  #-(or lucid allegro cmu akcl mcl lispworks wcl)
+  (error "Don't know how to initialize *LISP-IMPLEMENTATION-NAME*.")
+  )
+
+
+
+
+;;; Note that this assumes that the current directory is $Y2.
+;;; Environment variables in pathnames may not be supported by the
+;;; host Lisp.
+
+#-mcl (progn
+        (defvar *support-directory* "cl-support/")
+        (defvar *support-binary-directory*
+          (concatenate 'string 
+                       *support-directory* 
+                       *lisp-implementation-name*
+                       "/")))
+
+(defun load-compiled-cl-file (filename)
+  (let ((source-file (concatenate 'string
+				  *support-directory*
+				  filename
+				  *lisp-source-file-type*))
+	(binary-file (concatenate 'string
+				  *support-binary-directory*
+				  filename
+				  *lisp-binary-file-type*)))
+    (if (or (not (probe-file binary-file))
+	    (< (file-write-date binary-file) (file-write-date source-file)))
+	(compile-file source-file :output-file (merge-pathnames binary-file)))
+    (load binary-file)))
+
+
+;;; Do NOT change the load order of these files.
+
+(load-compiled-cl-file "cl-setup")
+(load-compiled-cl-file "cl-support")
+(load-compiled-cl-file "cl-definitions")
+(load-compiled-cl-file "cl-types")
+(load-compiled-cl-file "cl-structs")
+
+
+;;; It would be nice if at this point we could switch *package*
+;;; over to the right package.  But because *package* is rebound while 
+;;; this file is being loaded, it will get set back to whatever it was 
+;;; anyway.  Bummer.  Well, let's at least make the package that we want 
+;;; to use.
+
+(make-package "MUMBLE-USER" :use '("MUMBLE"))
+
+
+;;; Compile and load the rest of the system.  (The Lucid compiler is fast
+;;; enough to make it practical to compile things all the time.)
+
+(eval-when (eval compile load)
+  (setf *package* (find-package "MUMBLE-USER")))
+
+(load "$Y2/support/system")
+(compile-haskell)
+
+
+;;; All done
+
+(write-line "Remember to do (in-package \"MUMBLE-USER\")!")
diff --git a/cl-support/cl-setup.lisp b/cl-support/cl-setup.lisp
new file mode 100644
index 0000000..361963c
--- /dev/null
+++ b/cl-support/cl-setup.lisp
@@ -0,0 +1,30 @@
+;;; cl-setup.lisp -- set up mumble environment in Common Lisp
+;;;
+;;; author :  Sandra Loosemore
+;;; date   :  10 Oct 1991
+;;;
+;;; This file must be loaded before either compiling or loading
+;;; the cl-definitions file.
+
+
+;;; The mumble package exports only those symbols that have definitions
+;;; in mumble.  Many of these symbols shadow built-in CL definitions.
+;;; Programs that use mumble should use the mumble package in place of
+;;; (rather than in addition to) the CL package.
+
+(unless (find-package "MUMBLE")
+  (make-package "MUMBLE" :use nil))
+
+
+;;; The actual implementation of the mumble compatibility library happens
+;;; in the MUMBLE-IMPLEMENTATION package.  We'll explicitly package-qualify
+;;; all symbols from the MUMBLE package that it references, and rely
+;;; on the definitional macros to arrange to export them from the MUMBLE
+;;; package.
+
+(unless (find-package "MUMBLE-IMPLEMENTATION")
+  (make-package "MUMBLE-IMPLEMENTATION" :use '("LISP")))
+
+
+
+
diff --git a/cl-support/cl-structs.lisp b/cl-support/cl-structs.lisp
new file mode 100644
index 0000000..0d57693
--- /dev/null
+++ b/cl-support/cl-structs.lisp
@@ -0,0 +1,699 @@
+;;; cl-structs.lisp -- extended structure definitions
+;;;
+;;; author :  Sandra Loosemore
+;;; date   :  19 Aug 1992
+;;;
+
+
+;;;====================================================================
+;;; Basic structure types
+;;;====================================================================
+
+
+;;; Use this hash table for mapping names -> type descriptors
+
+(defvar *struct-lookup-table* (make-hash-table :test #'eq))
+
+(defmacro lookup-type (name)
+  `(gethash ,name *struct-lookup-table*))
+
+
+;;; Do NOT add or remove slots from these DEFSTRUCTS without also
+;;; changing the bootstrap code below!!!
+;;; Do NOT try to give these structs complicated defaulting behavior!!!
+
+;;; All of our objects are subtypes of STRUCT.
+
+
+(mumble::predefine (mumble::write object . maybe-stream))
+
+(defun print-struct-object (object stream depth)
+  (declare (ignore depth))
+  (mumble::write object stream)
+;  (format stream "#<Struct ~a>" (td-name (struct-type-descriptor object)))
+  )
+
+
+;;; Note that non-exported slots are prefixed with % to prevent
+;;; accidental slot name collisions.
+
+(defstruct (struct
+	     (:print-function print-struct-object)
+	     (:predicate      struct?)
+	     (:constructor    nil)   ; never instantiated directly
+	     (:copier         nil))
+  (type-descriptor nil :type t)
+  (%bits 0 :type fixnum)
+  )
+
+
+(defstruct (type-descriptor
+	     (:include struct
+		       (type-descriptor (lookup-type 'type-descriptor)))
+	     (:conc-name td-)
+	     (:constructor create-type-descriptor ())
+	     (:predicate nil)
+	     (:copier nil))
+  (name nil :type symbol)
+  (slots nil :type list)         ; all slots, including inherited
+  (parent-type nil :type t)
+  (printer nil :type t)
+  (%local-slots nil :type list)   ; "real" structure slots
+  (%bits-used 0 :type fixnum)
+  (%constructor nil :type symbol)
+  )
+
+(defstruct (slot-descriptor
+	     (:include struct
+		       (type-descriptor (lookup-type 'slot-descriptor)))
+	     (:conc-name sd-)
+	     (:constructor create-slot-descriptor ())
+	     (:predicate nil)
+	     (:copier nil))
+  (name nil :type symbol)
+  (type nil :type t)
+  (default nil :type t)
+  (getter nil :type symbol)
+  (%bit nil :type (mumble::maybe fixnum))
+  (%read-only? nil :type mumble::bool)
+  (%required? nil :type mumble::bool)
+  (%uninitialized? nil :type mumble::bool))
+
+
+;;; Helper function for bootstrapping.
+
+(defun create-slot-simple (prefix name type default
+			    &optional read-only? required? uninitialized?)
+  (let ((sd  (create-slot-descriptor)))
+    (setf (sd-name sd) name)
+    (setf (sd-type sd) type)
+    (setf (sd-default sd) default)
+    (setf (sd-getter sd) (symbol-append prefix name))
+    (setf (sd-%read-only? sd) read-only?)
+    (setf (sd-%required? sd) required?)
+    (setf (sd-%uninitialized? sd) uninitialized?)
+    sd))
+
+
+;;; Initialize descriptors for the predefined struct types.
+
+(let ((struct-td  (setf (lookup-type 'struct)
+			(create-type-descriptor)))
+      (type-td    (setf (lookup-type 'type-descriptor)
+			(create-type-descriptor)))
+      (slot-td    (setf (lookup-type 'slot-descriptor)
+			(create-type-descriptor))))
+  ;; struct
+  (setf (td-type-descriptor struct-td) type-td)
+  (setf (td-name struct-td) 'struct)
+  (setf (td-%bits-used struct-td) 0)
+  ;; type-descriptor
+  (setf (td-type-descriptor type-td) type-td)
+  (setf (td-name type-td) 'type-descriptor)
+  (setf (td-%local-slots type-td)
+	(list (create-slot-simple 'td- 'name 'symbol nil)
+	      (create-slot-simple 'td- 'slots 'list nil)
+	      (create-slot-simple 'td- 'parent-type 't nil)
+	      (create-slot-simple 'td- 'printer 't nil)
+	      (create-slot-simple 'td- '%local-slots 'list nil)
+	      (create-slot-simple 'td- '%bits-used 'fixnum 0)
+	      (create-slot-simple 'td- '%constructor 'symbol nil)
+	      ))
+  (setf (td-slots type-td) (td-%local-slots type-td))
+  (setf (td-%bits-used type-td) 0)
+  (setf (td-%constructor type-td) 'create-type-descriptor)
+  (setf (td-parent-type type-td) struct-td)
+  ;; slot-descriptor
+  (setf (td-type-descriptor slot-td) type-td)
+  (setf (td-name slot-td) 'slot-descriptor)
+  (setf (td-%local-slots slot-td)
+	(list (create-slot-simple 'sd- 'name 'symbol nil)
+	      (create-slot-simple 'sd- 'type 't nil)
+	      (create-slot-simple 'sd- 'default 't nil)
+	      (create-slot-simple 'sd- 'getter 'symbol nil)
+	      (create-slot-simple 'sd- '%bit '(mumble::maybe fixnum) nil)
+	      (create-slot-simple 'sd- '%read-only? 'mumble::bool nil)
+	      (create-slot-simple 'sd- '%required? 'mumble::bool nil)
+	      (create-slot-simple 'sd- '%uninitialized? 'mumble::bool nil)
+	      ))
+  (setf (td-slots slot-td) (td-%local-slots slot-td))
+  (setf (td-%bits-used slot-td) 0)
+  (setf (td-%constructor slot-td) 'create-slot-descriptor)
+  (setf (td-parent-type type-td) struct-td)
+  )
+
+
+
+;;;=====================================================================
+;;; Support for bit slots
+;;;=====================================================================
+
+(eval-when (eval compile load)
+  (defconstant max-bits (integer-length most-positive-fixnum)))
+
+(defvar *bit-slot-getters* (make-array max-bits))
+(defvar *bit-slot-setters* (make-array max-bits))
+
+(defmacro bit-slot-getter (i) `(svref *bit-slot-getters* ,i))
+(defmacro bit-slot-setter (i) `(svref *bit-slot-setters* ,i))
+
+(defmacro define-bit-accessors ()
+  (let ((results  nil))
+    (dotimes (i max-bits)
+      (let ((getter   (intern (format nil "GET-BIT-~a" i)))
+	    (setter   (intern (format nil "SET-BIT-~a" i)))
+	    (mask     (ash 1 i)))
+	(push
+	  `(progn
+	     (mumble::define-integrable (,getter x)
+               (not (eql (the fixnum
+			      (logand (the fixnum (struct-%bits x))
+				      (the fixnum ,mask)))
+			 0)))
+	     (mumble::define-integrable (,setter v x)
+	       (setf (struct-%bits x)
+		     (if v
+			 (the fixnum
+			      (logior (the fixnum (struct-%bits x))
+				      (the fixnum ,mask)))
+			 (the fixnum
+			      (logandc2 (the fixnum (struct-%bits x))
+					(the fixnum ,mask)))))
+	       v)
+	     (setf (bit-slot-getter ,i) ',getter)
+	     (setf (bit-slot-setter ,i) ',setter))
+	  results)))
+    `(progn ,@results)))
+
+(define-bit-accessors)
+
+
+
+
+;;;=====================================================================
+;;; Random helper functions
+;;;=====================================================================
+
+(defun quoted? (x)
+  (and (consp x) (eq (car x) 'quote)))
+
+(defun quoted-value (x)
+  (cadr x))
+
+(defun unknown-type-error (type)
+  (error "Struct type ~s has not been defined." type))
+
+(defun unknown-slot-error (type slot)
+  (error "Struct type ~s has no slot named ~s." type slot))
+
+(defun lookup-type-descriptor (type)
+  (or (lookup-type type)
+      (unknown-type-error type)))
+
+(defun lookup-slot-descriptor (type slot)
+  (let ((td  (lookup-type-descriptor type)))
+    (or (find slot (td-slots td) :key #'sd-name)
+	(unknown-slot-error type slot))))
+
+(defun slot-getter-name (type slot)
+  (sd-getter (lookup-slot-descriptor type slot)))
+
+(defun sd-getter-function (sd)
+  (symbol-function (sd-getter sd)))
+  
+
+
+;;;=====================================================================
+;;; Struct-slot macro
+;;;=====================================================================
+
+;;; Note that this can be SETF'ed only if type and slot are quoted.
+
+(defmacro struct-slot (type slot object)
+  (if (and (quoted? type) (quoted? slot))
+      (struct-slot-compiletime (quoted-value type) (quoted-value slot) object)
+      (progn
+	(warn "Type and/or slot argument to STRUCT-SLOT not constant.")
+	`(struct-slot-runtime ,type ,slot ,object))))
+
+(defun struct-slot-compiletime (type slot object)
+  (let ((sd  (lookup-slot-descriptor type slot)))
+    `(the ,(sd-type sd) (,(sd-getter sd) (the ,type ,object)))))
+
+(defun struct-slot-runtime (type slot object)
+  (let ((sd  (lookup-slot-descriptor type slot)))
+    ;; *** Could insert explicit type checks here.
+    (funcall (sd-getter-function sd) object)))
+  
+
+;;;=====================================================================
+;;; Make macro and support
+;;;=====================================================================
+
+(defmacro make (type . inits)
+  (make-aux type inits))
+
+;;; Turn the call to MAKE into a call to the boa constructor.
+;;; The arguments to the BOA constructor are those slots that have
+;;; the required? flag set to true.  If initializers for other slots
+;;; are provided, turn these into SETFs.  Bit attributes are always 
+;;; handled via SETF.
+
+(defun make-aux (type inits)
+  (let* ((td           (lookup-type-descriptor type))
+	 (boa          (td-%constructor td))
+	 (slots        (td-slots td))
+	 (tempvar      (gensym))
+	 (setfs        '())
+	 (bits-inits   '())
+	 (slot-inits   '()))
+    (check-slot-inits type inits)
+    (dolist (s slots)
+      (let* ((name           (sd-name s))
+	     (supplied?      (mumble::assq name inits))
+	     (required?      (sd-%required? s))
+	     (uninitialized? (sd-%uninitialized? s))
+	     (init           (if supplied?
+				 (progn
+				   ;; *** Maybe want to suppress this warning.
+				   ;;(when (not required?)
+				   ;;  (override-slot-init-warning type name))
+				   (cadr supplied?))
+				 (progn
+				   ;; *** Maybe want to suppress this warning.
+				   (when (and required? (not uninitialized?))
+				     (missing-slot-init-warning type name))
+				   (sd-default s)))))
+	(cond ((sd-%bit s)
+	       (cond ((or (eq init 'nil) (equal init '(quote nil)))
+		      ;; do nothing, bit already defaults to 0
+		      )
+		     ((and uninitialized? (not supplied?) required?)
+		      ;; no default or init supplied, leave uninitialized
+		      )
+		     ((constantp init)
+		      ;; it must be a non-false constant, set bit to 1
+		      (push (ash 1 (sd-%bit s)) bits-inits))
+		     (t
+		      ;; have to do runtime test
+		      (push `(the fixnum (if ,init ,(ash 1 (sd-%bit s)) 0))
+			    bits-inits))))
+	      ((and required? (not uninitialized?))
+	       ;; The constructor takes the value as a positional argument.
+	       (push init slot-inits))
+	      (supplied?
+	       ;; Make a setf.  
+	       ;; No point in putting the same value in twice.
+	       (unless (and (constantp init) (equal init (sd-default s)))
+		 (push `(setf (,(sd-getter s) ,tempvar) ,init) setfs)))
+	      (t nil))))
+    (unless (null bits-inits)
+      (push `(setf (struct-%bits ,tempvar)
+		   ,(cond ((null (cdr bits-inits))
+			   (car bits-inits))
+			  ((every #'constantp bits-inits)
+			   (apply #'logior bits-inits))
+			  (t
+			   `(the fixnum (logior ,@(nreverse bits-inits))))))
+	    setfs))
+    (if (null setfs)
+	`(,boa ,@(nreverse slot-inits))
+	`(let ((,tempvar  (,boa ,@(nreverse slot-inits))))
+	   ,@(nreverse setfs)
+	   ,tempvar))))
+
+(defun override-slot-init-warning (type name)
+  (warn "Overriding default for slot ~s in MAKE ~s."
+	name type))
+
+(defun missing-slot-init-warning (type name)
+  (warn "No initializer or default for slot ~s in MAKE ~s."
+	name type))
+
+(defun check-slot-inits (type inits)
+  (dolist (i inits)
+    (lookup-slot-descriptor type (car i))))
+
+
+
+;;;====================================================================
+;;; Update-slots macro
+;;;====================================================================
+
+;;; Note that type is a literal here.
+;;; *** Could be smarter about merging setters for bit slots.
+
+(defmacro update-slots (type exp . inits)
+  (let ((temp  (gensym)))
+    `(let ((,temp  ,exp))
+       ,@(mapcar #'(lambda (i)
+		     `(setf (struct-slot ',type ',(car i) ,temp) ,(cadr i)))
+		 inits))))
+
+
+
+;;;====================================================================
+;;; With-slots macro
+;;;====================================================================
+
+;;; Note that type is a literal here.
+;;; ***Could be smarter about merging accesses for bit slots.
+
+(defmacro mumble::with-slots (type slots exp . body)
+  (let ((temp  (gensym)))
+    `(let* ((,temp  ,exp)
+	    ,@(mapcar #'(lambda (s)
+			  `(,s  (struct-slot ',type ',s ,temp)))
+		      slots))
+       ,@body)))
+
+
+;;;====================================================================
+;;; Define-struct macro
+;;;====================================================================
+
+
+;;; The rather strange division here is so that the call to MAKE
+;;; works right.
+;;; All INSTALL-STRUCT-TYPE does is fill in and install the type
+;;; descriptor object.
+
+(defmacro define-struct (name . fields)
+  (multiple-value-bind (include type-template slots prefix predicate)
+      (parse-struct-fields name fields)
+    `(progn
+       (eval-when (eval compile load)
+	 (install-struct-type
+	   ',name
+	   ',include
+	   ',prefix
+	   (make ,type-template)
+	   ',slots))
+       (define-struct-aux ,name ,include ,prefix ,predicate))))
+
+
+;;; This is the macro that actually creates the DEFSTRUCT expansion.
+
+(defmacro define-struct-aux (name include prefix predicate)
+  (let* ((td           (lookup-type name))
+	 (slots        (td-slots td))
+	 (local-slots  (td-%local-slots td))
+	 (bit-slots    (remove-if-not #'sd-%bit slots)))
+    `(progn
+       ;; Make the struct definition.
+       ;; *** could put the type descriptor for the default in a
+       ;; *** global variable; it might speed up reference.
+       (defstruct (,name
+		    (:include ,include
+			      (type-descriptor (lookup-type ',name)))
+		    (:conc-name ,prefix)
+		    ;; Disable the default keyword constructor.
+		    ;; If you do this in AKCL, it will complain about
+		    ;; the BOA constructor.  Bogus!!!
+		    ;; If you do this in WCL, it will just quietly ignore
+		    ;; the BOA.
+		    #-(or akcl wcl) (:constructor nil)
+		    (:constructor ,(td-%constructor td) ,(make-boa-args slots))
+		    (:predicate ,predicate)
+		    (:copier    nil))
+	 ,@(mapcar
+	    #'(lambda (s)
+		`(,(sd-name s) ,(sd-default s)
+		  ;; CMU common lisp initializes &aux boa constructor
+		  ;; slots to NIL instead of leaving them uninitialized,
+		  ;; and then complains if this doesn't match the declared
+		  ;; slot type.  I think this is a bug, not a feature, but
+		  ;; here's a workaround for it.
+		  :type
+		  #+cmu ,(if (sd-%uninitialized? s)
+			     `(or ,(sd-type s) null)
+			     (sd-type s))
+		  #-cmu ,(sd-type s)
+	          ;; Can make slots read-only only if a setf-er is not 
+		  ;; required by MAKE.
+		  :read-only ,(and (sd-%read-only? s) (sd-%required? s))))
+	    local-slots))
+       ;; Make accessor functions for bit slots.
+       ,@(mapcar
+	  #'(lambda (s)
+	      (let ((place  (symbol-append prefix (sd-name s)))
+		    (getter (bit-slot-getter (sd-%bit s)))
+		    (setter (bit-slot-setter (sd-%bit s))))
+		`(progn
+		   (mumble::define-integrable (,place x) (,getter x))
+		   ,@(unless (sd-%read-only? s)
+		       `((mumble::define-setf ,place ,setter))))
+		))
+	  bit-slots)
+	 ',name)
+      ))
+
+
+
+;;; Determine which arguments to make explicit to the boa constructor.
+;;; Basically, expect an explicit initializer for any slot that does not 
+;;; have a default supplied.
+;;; Supplying slot names as &aux parameters to a boa constructor is
+;;; supposed to suppress initialization.
+
+(defun make-boa-args (slots)
+  (let ((required-args      '())
+	(uninitialized-args '()))
+    (dolist (s slots)
+      (when (and (sd-%required? s) (not (sd-%bit s)))
+	(if (sd-%uninitialized? s)
+	    (push (sd-name s) uninitialized-args)
+	    (push (sd-name s) required-args))))
+    ;; Gag.  AKCL does the wrong thing with &AUX arguments; defstruct sticks
+    ;; another &AUX at the end of the lambda list.  Looks like it will do
+    ;; the right thing if you just omit the uninitialized arguments from
+    ;; the boa arglist entirely.
+    #+akcl (nreverse required-args)
+    #-akcl   
+    (if (null uninitialized-args)
+	(nreverse required-args)
+	`(,@(nreverse required-args) &aux ,@(nreverse uninitialized-args)))
+    ))
+
+
+;;; Install the type descriptor, filling in all the slots.
+
+(defun install-struct-type (name include prefix td slots)
+  (let* ((parent-type  (lookup-type-descriptor include))
+	 (bits-used    (td-%bits-used parent-type))
+	 (local-slots  '())
+	 (all-slots    '()))
+    (dolist (s slots)
+      (multiple-value-bind
+	  (slot-name type default bit read-only? required? uninitialized?)
+	  (parse-slot-fields name s)
+	(let ((sd   (create-slot-simple
+		      prefix slot-name type default
+		      read-only? required? uninitialized?)))
+	  (push sd all-slots)
+	  (cond (bit
+		 (if (eql bits-used max-bits)
+		     (error "Too many bit slots in DEFINE-STRUCT ~s." name))
+		 (setf (sd-%bit sd) bits-used)
+		 (incf bits-used))
+		(t
+		 (push sd local-slots))))))
+    (setf local-slots (nreverse local-slots))
+    (setf (td-name td) name)
+    (setf (td-slots td) (append (td-slots parent-type) (nreverse all-slots)))
+    (setf (td-%local-slots td) local-slots)
+    (setf (td-%bits-used td) bits-used)
+    (setf (td-%constructor td) (symbol-append '%create- name))
+    (setf (td-parent-type td) parent-type)
+    (setf (lookup-type name) td)))
+
+
+;;; Struct field parsing.
+
+(defun parse-struct-fields (name fields)
+  (when (not (symbolp name))
+    (error "Structure name ~s is not a symbol." name))
+  (let ((include         nil)
+	(type-template   nil)
+	(slots           nil)
+	(prefix          nil)
+	(predicate       nil))
+    (dolist (f fields)
+      (cond ((not (consp f))
+	     (unknown-field-error f name))
+	    ((eq (car f) 'include)
+	     (if include
+		 (duplicate-field-error 'include name)
+		 (setf include (cadr f))))
+	    ((eq (car f) 'type-template)
+	     (if type-template
+		 (duplicate-field-error 'type-template name)
+		 (setf type-template (cadr f))))
+	    ((eq (car f) 'slots)
+	     (if slots
+		 (duplicate-field-error 'slots name)
+		 (setf slots (cdr f))))
+	    ((eq (car f) 'prefix)
+	     (if prefix
+		 (duplicate-field-error 'prefix name)
+		 (setf prefix (cadr f))))
+	    ((eq (car f) 'predicate)
+	     (if predicate
+		 (duplicate-field-error 'predicate name)
+		 (setf predicate (cadr f))))
+	    (t
+	     (unknown-field-error f name))))
+    (values
+      (or include 'struct)
+      (or type-template
+	  (and include
+	       (td-name (td-type-descriptor (lookup-type-descriptor include))))
+	  'type-descriptor)
+      (or slots '())
+      (or prefix (symbol-append name '-))
+      predicate)))
+
+(defun unknown-field-error (f name)	     
+  (error "Unknown field ~s in DEFINE-STRUCT ~s." f name))
+
+(defun duplicate-field-error (f name)
+  (error "Field ~s appears more than once in DEFINE-STRUCT ~s." f name))
+
+
+
+;;; Parsing for slot specifications.
+
+(defun parse-slot-fields (struct-name slot)
+  (let ((name           nil)
+	(type           t)
+	(default        '*default-slot-default*)
+	(bit            nil)
+	(read-only?     nil)
+	(required?      t)
+	(uninitialized? nil))
+    (if (or (not (consp slot))
+	    (not (symbolp (setf name (car slot)))))
+	(invalid-slot-error slot struct-name))
+    (dolist (junk (cdr slot))
+      (cond ((eq (car junk) 'type)
+	     (setf type (cadr junk)))
+	    ((eq (car junk) 'default)
+	     (setf default (cadr junk))
+	     (setf required? nil))
+	    ((eq (car junk) 'bit)
+	     (setf bit (cadr junk)))
+	    ((eq (car junk) 'read-only?)
+	     (setf read-only? (cadr junk)))
+	    ((eq (car junk) 'uninitialized?)
+	     (setf uninitialized? (cadr junk)))
+	    (t
+	     (invalid-slot-error slot struct-name))))
+    (values
+      name
+      type
+      default
+      bit
+      read-only?
+      required?
+      uninitialized?
+      )))
+
+;;; Some implementations of DEFSTRUCT complain if the default value
+;;; for a slot doesn't match the declared type of that slot, even if
+;;; the default is never used.
+;;; Using this variable as the default init form for such slots should
+;;; suppress such warnings.
+
+(defvar *default-slot-default* nil)
+
+(defun invalid-slot-error (slot struct-name)
+  (error "Invalid slot syntax ~s in DEFINE-STRUCT ~s." slot struct-name))
+
+
+
+;;;=====================================================================
+;;; Printer hooks
+;;;=====================================================================
+
+;;; Here is the macro for associating a printer with a structure type.
+
+(defmacro define-struct-printer (type function)
+  `(define-struct-printer-aux ',type (function ,function)))
+
+(defun define-struct-printer-aux (type function)
+  (let ((td  (lookup-type-descriptor type)))
+    (setf (td-printer td) function)
+    type))
+
+
+;;;=====================================================================
+;;; Imports
+;;;=====================================================================
+
+
+;;; Generic stuff
+
+(define-mumble-import struct)
+(define-mumble-import struct?)
+(define-mumble-import struct-type-descriptor)
+
+
+;;; Predefined types, slots, and accessors
+;;; Note:  not all slots are exported.
+
+(define-mumble-import type-descriptor)
+(define-mumble-import name)
+(define-mumble-import slots)
+(define-mumble-import parent-type)
+(define-mumble-import printer)
+(define-mumble-import td-name)
+(define-mumble-import td-slots)
+(define-mumble-import td-parent-type)
+(define-mumble-import td-printer)
+
+(define-mumble-import slot-descriptor)
+(define-mumble-import name)
+(define-mumble-import type)
+(define-mumble-import default)
+(define-mumble-import getter)
+(define-mumble-import sd-name)
+(define-mumble-import sd-type)
+(define-mumble-import sd-default)
+(define-mumble-import sd-getter)
+
+
+;;; Utility functions
+
+(define-mumble-import lookup-type-descriptor)
+(define-mumble-import lookup-slot-descriptor)
+(define-mumble-import sd-getter-function)
+
+
+;;; Macros
+
+(define-mumble-import make)
+(define-mumble-import struct-slot)
+(define-mumble-import define-struct)
+(define-mumble-import mumble::with-slots)
+(define-mumble-import update-slots)
+(define-mumble-import define-struct-printer)
+
+
+;;; Field names for define-struct
+
+(define-mumble-import include)
+(define-mumble-import type-template)
+(define-mumble-import slots)
+(define-mumble-import prefix)
+(define-mumble-import predicate)
+
+
+;;; Field names for slot options
+
+(define-mumble-import type)
+(define-mumble-import default)
+(define-mumble-import bit)
+(define-mumble-import read-only?)
+(define-mumble-import uninitialized?)
+
+
diff --git a/cl-support/cl-support.lisp b/cl-support/cl-support.lisp
new file mode 100644
index 0000000..4f82ce2
--- /dev/null
+++ b/cl-support/cl-support.lisp
@@ -0,0 +1,86 @@
+;;; cl-support.lisp -- compile-time support for building mumble
+;;;
+;;; author :  Sandra Loosemore
+;;; date   :  10 Oct 1991
+;;;
+;;; This file must be loaded before compiling the cl-definitions file.
+;;; However, it is not needed when loading the compiled file.
+
+(in-package "MUMBLE-IMPLEMENTATION")
+
+
+;;; Use this macro for defining an exported mumble function.
+
+(defmacro define-mumble-function (name &rest stuff)
+  `(progn
+     (eval-when (eval compile load) (export (list ',name) "MUMBLE"))
+     (defun ,name ,@stuff)))
+
+
+;;; This is similar, but also does some stuff to try to inline the
+;;; function definition.  
+
+(defmacro define-mumble-function-inline (name &rest stuff)
+  `(progn
+     (eval-when (eval compile load) (export (list ',name) "MUMBLE"))
+#+lcl
+     (lcl:defsubst ,name ,@stuff)
+#-lcl
+     (progn
+       (proclaim '(inline ,name))
+       (defun ,name ,@stuff))
+     ',name))
+
+
+;;; Use this macro for defining an exported mumble macro.
+
+(defmacro define-mumble-macro (name &rest stuff)
+  `(progn
+     (eval-when (eval compile load) (export (list ',name) "MUMBLE"))
+     (defmacro ,name ,@stuff)))
+
+
+;;; Use this macro for importing a random symbol into the MUMBLE
+;;; package.  This is useful for things that can share directly with
+;;; built-in Common Lisp definitions.
+
+(defmacro define-mumble-import (name)
+  `(progn
+     (eval-when (eval compile load) (import (list ',name) "MUMBLE"))
+     (eval-when (eval compile load) (export (list ',name) "MUMBLE"))
+     ',name))
+
+
+;;; Use this macro for defining a function in the MUMBLE package that
+;;; is a synonym for some Common Lisp function.  Try to do some stuff
+;;; to make the function compile inline.
+
+(defmacro define-mumble-synonym (name cl-name)
+  `(progn
+     (eval-when (eval compile load) (export (list ',name) "MUMBLE"))
+     (setf (symbol-function ',name) (symbol-function ',cl-name))
+#+lcl
+     (lcl:def-compiler-macro ,name (&rest args)
+       (cons ',cl-name args))
+     ',name))
+
+
+
+;;; Use this macro to define a type synonym.
+
+(defmacro define-mumble-type (name &rest stuff)
+  `(progn
+     (eval-when (eval compile load) (export (list ',name) "MUMBLE"))
+     (deftype ,name ,@stuff)))
+
+
+;;; This macro is used to signal a compile-time error in situations
+;;; where an implementation-specific definition is missing.
+
+(defmacro missing-mumble-definition (name)
+  (error "No definition has been provided for ~s." name))
+
+
+
+
+
diff --git a/cl-support/cl-types.lisp b/cl-support/cl-types.lisp
new file mode 100644
index 0000000..6fb625e
--- /dev/null
+++ b/cl-support/cl-types.lisp
@@ -0,0 +1,90 @@
+;;; cl-types.lisp -- type-related stuff
+;;;
+;;; author :  Sandra Loosemore
+;;; date   :  5 Oct 1992
+;;;
+
+
+;;; Export CL symbols for type names
+
+(define-mumble-import t)
+
+#+lucid
+(define-mumble-type mumble::procedure () 'system::procedure)
+#+(or cmu akcl allegro mcl lispworks)
+(define-mumble-type mumble::procedure () 'function)
+#+wcl
+(define-mumble-type mumble::procedure () 'lisp:procedure)
+#-(or lucid cmu akcl allegro mcl lispworks wcl)
+(missing-mumble-definition procedure)
+
+(define-mumble-type mumble::pair () 'cons)
+
+(define-mumble-import null)
+
+(define-mumble-type mumble::list (&optional element-type)
+  ;; *** Common Lisp provides no way to make use of the element type
+  ;; *** without using SATISFIES.
+  (declare (ignore element-type))
+  'list)
+
+(define-mumble-import symbol)
+
+(define-mumble-type mumble::char () 'character)
+(define-mumble-type mumble::string () 'simple-string)
+(define-mumble-type mumble::vector () 'simple-vector)
+
+(define-mumble-import number)
+(define-mumble-import integer)
+(define-mumble-import rational)
+(define-mumble-import float)
+(define-mumble-import fixnum)
+
+(define-mumble-type mumble::int () 'fixnum)
+
+(define-mumble-type mumble::table (&optional key-type value-type)
+  ;; *** Common Lisp provides no way to make use of the element type
+  ;; *** without using SATISFIES.
+  (declare (ignore key-type value-type))
+  'hash-table)
+
+
+;;; Extensions
+
+(define-mumble-type mumble::enum (&rest values)
+  `(member ,@values))
+
+(define-mumble-type mumble::tuple (&rest element-types)
+  ;; *** Common Lisp provides no way to make use of the element type
+  ;; *** without using SATISFIES.
+  (let ((n  (length element-types)))
+    (cond ((< n 2)
+	   (error "Too few arguments to TUPLE type specifier."))
+	  ((eql n 2)
+	   'cons)
+	  (t
+	   'simple-vector))))
+
+(define-mumble-type mumble::bool () 't)
+
+(define-mumble-type mumble::alist (&optional key-type value-type)
+  `(mumble::list (tuple ,key-type ,value-type)))
+
+(define-mumble-type mumble::maybe (type)
+  `(or ,type null))
+
+
+
+;;; Functions, etc.
+
+(define-mumble-import the)
+(define-mumble-synonym mumble::subtype? subtypep)
+
+(define-mumble-function-inline mumble::is-type? (type object)
+  (typep object type))
+
+(define-mumble-macro mumble::typecase (data &rest cases)
+  (let ((last  (car (last cases))))
+    (if (eq (car last) 'mumble::else)
+	`(typecase ,data ,@(butlast cases) (t ,@(cdr last)))
+	`(typecase ,data ,@cases))))
diff --git a/cl-support/wcl-patches.lisp b/cl-support/wcl-patches.lisp
new file mode 100644
index 0000000..3e9395c
--- /dev/null
+++ b/cl-support/wcl-patches.lisp
@@ -0,0 +1,68 @@
+(in-package "LISP")
+
+
+;;; The default version of this function has a bug with relative
+;;; pathnames.
+
+(defun pathname->string (p)
+  (let ((dirlist (pathname-directory p)))
+    (format nil "~A~{~A/~}~A~A~A"
+            (case (car dirlist)
+              (:absolute "/")
+              (:relative "./")
+              (:up "../")
+              (t ""))
+            (cdr dirlist)
+            (nil->empty-string (pathname-name p))
+            (if (null (pathname-type p)) "" ".")
+            (nil->empty-string (pathname-type p)))))
+
+
+;;; The default version of this function defaults the C file to the
+;;; wrong directory -- LOAD can't find it.
+
+(defun my-comf (file &key
+                  (output-file (merge-pathnames ".o" file))
+                  (c-file (merge-pathnames ".c" output-file))
+                  (verbose *compile-verbose*)
+                  (print *compile-print*)
+                  (config *config*)
+                  (pic? *pic?*)
+                  only-to-c?)
+  (old-comf file
+	    :output-file output-file
+	    :c-file c-file
+	    :verbose verbose
+	    :print print
+	    :config config
+	    :pic? pic?
+	    :only-to-c? only-to-c?))
+
+(when (not (fboundp 'old-comf))
+  (setf (symbol-function 'old-comf) #'comf)
+  (setf (symbol-function 'comf) #'my-comf))
+
+
+;;; WCL's evaluator tries to macroexpand everything before executing
+;;; anything.  Unfortunately, this does the wrong thing with
+;;; top-level PROGN's -- it tries to expand macros in subforms before
+;;; executing earlier subforms that set up stuff required to do the
+;;; the expansion properly.
+
+(defun eval-1 (form venv fenv tenv benv)
+  (let ((new-form  (macroexpand form *eval-macro-env*)))
+    (if (and (consp new-form)
+	     (eq (car new-form) 'progn))
+	(do ((forms (cdr new-form) (cdr forms)))
+	    ((null (cdr forms)) (eval-1 (car forms) venv fenv tenv benv))
+	    (eval-1 (car forms) venv fenv tenv benv))
+	(let ((expansion (expand new-form)))
+	  (when (and (listp expansion)
+		     (eq (car expansion) 'define-function))
+	    (setf (get (second (second expansion))
+		       :function-definition)
+		  form))
+	  (eval/5 expansion venv fenv tenv benv))
+      )))
+
+