diff --git a/assembler/assem.lisp b/assembler/assem.lisp
deleted file mode 100644
index 0811ac163aece2131b8d012e4149a6cc96108328..0000000000000000000000000000000000000000
--- a/assembler/assem.lisp
+++ /dev/null
@@ -1,697 +0,0 @@
-;;; -*- Log: clc.log; Package: Compiler -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; Assembler for the Common Lisp Compiler.  This file deals with turning
-;;; LAP code into binary code and dumping the results in the right places.
-;;; There also ulilities for dealing with the various output files.
-;;; 
-
-;;; Written by many hands: Joe Ginder, Scott Fahlman, Dave Dill,
-;;; Walter van Roggen, and Skef Wholey.
-
-;;; Currently maintained by Scott Fahlman.
-
-(in-package 'compiler :use '(system))
-
-(import '(lisp::%fasl-code-format))
-
-;;; Version number.
-
-(defparameter assembler-version "2.0")
-(defparameter target-fasl-code-format 3)
-
-(proclaim '(special compiler-version target-machine target-system
-		    *compile-to-lisp* *lisp-package* *keyword-package*))
-
-
-
-(defvar function-name nil
-  "Holds a symbol that names the function currently being compiled,
-  or nil if between functions.")
-
-;;; Output streams:
-;;; If a stream is NIL, don't produce that kind of output.
-(defvar *clc-fasl-stream* nil)
-(defvar *clc-lap-stream* nil)
-(defvar *clc-err-stream* nil)
-
-;;; Stuff we keep track of for the error log:
-
-(defvar functions-with-errors nil
-  "A list of all functions that did not compile properly due to errors in
-  the code.")
-
-(defvar error-count 0
-  "The number of errors generated during this compilation.")
-
-(defvar warning-count 0
-  "The number of warnings generated during this compilation.")
-
-(defvar unknown-functions nil
-  "List of functions called but not yet seen and not built-in.  The user
-  is informed of any function still on this list at the end of a file
-  compilation.")
-
-(defvar unknown-free-vars nil
-  "A list of all variables referenced free in the compilation, but not
-  bound or declared special anywhere.  These are assumed to be special
-  variables, but are listed in a warning message at the end of the
-  compilation.")
-
-(defvar *verbose* t
-  "If nil, only true error messages and warnings go to the error stream.
-  If non-null, prints a message as each function is compiled.")
-
-(defvar *compile-to-lisp* nil
-  "If non-null, stuff compiled definitions into the compiler's own Lisp
-  environment.")
-
-(defvar *clc-input-stream* nil)
-(defvar *input-filename* nil "Truename of file being compiled.")
-(defvar *compiler-is-reading* nil
-  "This is true only if we are actually doing a read from *clc-input-stream*.
-  #, (in the reader) looks at this.")
-
-  
-;;; The Line-Length of the lap stream...
-(defvar *lap-line-length*)
-
-;;; The defined-from string for functions defined in the current source file:
-(defvar *current-defined-from*)
-
-
-;;;; Error Reporting:
-
-;;; CLC-MUMBLE is just a format print to the error stream.
-
-(defun clc-mumble (string &rest args)
-  (when *clc-err-stream*
-    (apply #'format *clc-err-stream* string args)))
-
-
-;;; A COMMENT is something the user might like to know, but that will
-;;; probably not affect the correctness of his code.
-
-(defun clc-comment (string &rest args)
-  (when *clc-err-stream*
-    (if (or (not function-name) (eq function-name 'lisp::top-level-form))
-	(format *clc-err-stream* "Comment between functions:~%  ")
-	(format *clc-err-stream* "Comment in ~S:~%  " function-name))
-    (apply #'format *clc-err-stream* string args)
-    (terpri *clc-err-stream*)))
-
-
-;;; A WARNING is something suspicious in the user's code that probably
-;;; signals some form of lossage, but that may be ignored if the user
-;;; knows what he is doing.
-
-(defun clc-warning (string &rest args)
-  (when *clc-err-stream*
-    (incf warning-count)
-    (if (or (not function-name) (eq function-name 'lisp::top-level-form))
-	(format *clc-err-stream* "Warning between functions:~%  ")
-	(format *clc-err-stream* "Warning in ~S:~%  " function-name))
-    (apply #'format *clc-err-stream* string args)
-    (terpri *clc-err-stream*)))
-
-
-;;; An ERROR is a problem in the user's code that will definitely cause some
-;;; lossage.  The compiler attempts to go on with the compilation so that
-;;; as many errors as possible can be caught per compilation.
-
-(defun clc-error (string &rest args)
-  (when *clc-err-stream*
-    (incf error-count)
-    (cond ((or (not function-name) (eq function-name 'lisp::top-level-form))
-	   (format *clc-err-stream* "Error between functions:~%  ")
-	   (pushnew function-name functions-with-errors))
-	  (t
-	   (format *clc-err-stream* "Error in ~S:~%  " function-name)))
-    (apply #'format *clc-err-stream* string args)
-    (terpri *clc-err-stream*)))
-
-
-;;; Keep the internal real and run times in these vars so that we can report
-;;; the elapsed time.
-(defvar *start-real-time*)
-(defvar *start-run-time*)
-
-;;; Start-Assembly  --  Internal
-;;;
-;;;    This function is called before assembling each batch of stuff.  It
-;;; writes out the fasl file header and does other random stuff.  It is
-;;; assumed that all the streams are initialized at this point.
-;;;
-(defun start-assembly ()
-  (let* ((host (machine-instance))
-	 (now (get-universal-time))
-	 (now-string (universal-time-to-string now))
-	 (in-string (if *input-filename* (namestring *input-filename*)))
-	 (then (if *input-filename*
-		   (file-write-date *input-filename*)))
-	 (then-string (if then (universal-time-to-string then)))
-	 (where (cond ((not *clc-input-stream*)
-		       (format nil "Lisp on ~A, machine ~A" now-string host))
-		      (in-string
-		       (format nil "~A ~A" in-string now-string))
-		      ((not then)
-		       (format nil "~S on ~A, machine ~A" *clc-input-stream*
-			       now-string host))
-		      (t
-		       (format nil "~A ~A" in-string then-string)))))
-    
-    ;; Set the defined-from string:
-    (setq *current-defined-from* (format nil "~A ~D" where (or then now)))
-
-    (when *input-filename*
-      (setq *start-real-time* (get-internal-real-time))
-      (setq *start-run-time* (get-internal-run-time))
-      (clc-mumble "Error output from ~A.~@
-		  Compiled on ~A by CLC version ~A.~2%"
-		  where now-string compiler-version))
-
-    (when *clc-lap-stream*
-      (setq *lap-line-length* (or (lisp::line-length *clc-lap-stream*) 80))
-      (format *clc-lap-stream*
-	      "~:[Unreadble~;Readable~] LAP output from ~A.~@
-	      Compiled on ~A by CLC version ~A.~%"
-	      *print-readable-lap* where now-string compiler-version))
-  
-    (when *clc-fasl-stream*
-      (format *clc-fasl-stream* "FASL FILE output from ~A~@
-	      Compiled ~A on ~A~@
-	      Compiler ~A, Assembler ~A, Lisp ~A~@
-	      Targeted for ~A/~A, FASL code format ~D~%"
-	      where now-string host compiler-version assembler-version
-	      (lisp-implementation-version) target-machine target-system
-	      c::target-fasl-code-format)
-      (start-fasl-file))))
-
-;;; Also the ten-dozenth place this is defined...
-(defun universal-time-to-string (ut)
-  (multiple-value-bind (sec min hour day month year)
-		       (decode-universal-time ut)
-    (format nil "~D-~A-~2,'0D ~D:~2,'0D:~2,'0D"
-	    day (svref '#("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug"
-			  "Sep" "Oct" "Nov" "Dec")
-		       (1- month))
-	    (rem year 100)
-	    hour min sec)))
-
-(defun elapsed-time-to-string (it)
-  (let ((tsec (truncate it internal-time-units-per-second)))
-    (multiple-value-bind (tmin sec)
-			 (truncate tsec 60)
-      (multiple-value-bind (thr min)
-			   (truncate tmin 60)
-	(format nil "~D:~2,'0D:~2,'0D" thr min sec)))))
-
-
-;;; Finish-Assembly  --  Internal
-;;;
-;;;
-(defun finish-assembly ()
-  (when *clc-fasl-stream* (terminate-fasl-file))
-  
-  ;; All done.  Let the post-mortems begin.
-  (when *input-filename*
-    (clc-mumble "~%Finished compilation of file ~S.~%"
-		(namestring *input-filename*))
-    (clc-mumble "~S Errors, ~S Warnings.~%" error-count warning-count)
-    (clc-mumble "Elapsed time ~A, run time ~A.~2%"
-		(elapsed-time-to-string (- (get-internal-real-time)
-					   *start-real-time*))
-		(elapsed-time-to-string (- (get-internal-run-time)
-					   *start-run-time*))))
-    
-  (when functions-with-errors
-    (clc-mumble "Errors were detected in the following functions:~% ~S~%"
-		(nreverse functions-with-errors)))
-  (when unknown-functions
-    (clc-mumble
-     "These symbols were called as functions but not declared or defined:~% ~S~%"
-     (nreverse unknown-functions)))
-  (do* ((p NIL)
-	(l unknown-free-vars (cdr l))
-	(a (car l) (car l)))
-       ((null l))
-    (if (get a 'globally-special-in-compiler)
-	(cond (p (rplacd p (cdr l))
-		 (setq l p))
-	      (T (setq unknown-free-vars (cdr l))
-		 (setq p NIL)))
-	(setq p l)))
-  (when unknown-free-vars
-    (clc-mumble
-     "The following variables, assumed to be special, are referenced~@
-     but never declared:~% ~S~%"
-     (nreverse unknown-free-vars))))
-
-;;;; Fasl dumping stuff:
-
-;;; Next slot to be filled in the fasload table.  Reset at the start of
-;;; each new FASL file.
-(defvar fop-table-counter 0)
-
-;;; For speed, we keep the table index for each symbol in a property
-;;; under that symbol, rather than in an A-list.  All the symbols with
-;;; FOP-TABLE-INDEX properties are kept on this list, so that we can
-;;; clean up when a new FASL file is started.
-(defvar fop-table-symbol-list nil)
-
-;;; FOP-TABLE-PACKAGE-LIST is an a-list mapping packages to their fop-table
-;;; indices.  Each entry is (package . index).
-(defvar fop-table-package-list nil)
-
-;;; When we dump lists and strings, we look for them in this hashtable.
-;;; If we find what we are looking for, we just push the thing from the
-;;; table.  If it isn't there, we dump the object and then enter it.
-(defvar *table-table* (make-hash-table :test #'equal))
-
-;;; If true, then we must dump stuff so that it neither adds to nor refers
-;;; the table.  This is used by the forms which need to be available
-;;; at cold load time.
-(defvar *hands-off-table* nil)
-
-;;; Dump a single byte to the *CLC-FASL-STREAM* file.  We buffer these until
-;;; we collect 512 of them, and then write-string them to the FASL stream.
-(defvar *dump-byte-buffer* (make-array 512 :element-type '(mod 256)))
-(defvar *dump-byte-index*)
-
-
-(defun dump-dump-byte-buffer ()
-  (write-string *dump-byte-buffer* *clc-fasl-stream*
-		:start 0 :end *dump-byte-index*)
-  (setq *dump-byte-index* 0))
-
-(defmacro dump-byte (b)
-  `(progn
-    (if (= *dump-byte-index* 512)
-	(dump-dump-byte-buffer))
-    (setf (aref *dump-byte-buffer* *dump-byte-index*) (logand ,b #x+FF))
-    (incf *dump-byte-index*)))
-
-
-;;; Put out the code for one FASL-format operator.
-
-(defun dump-fop (fs)
-  (let ((val (get fs 'lisp::fop-code)))
-    (if (null val)
-	(error "Compiler bug: ~S not a legal fasload operator." fs)
-	(dump-byte val))))
-
-
-(defmacro dump-fop* (n byte-fop word-fop)
-  `(cond ((< ,n 256)
-	  (dump-fop ',byte-fop)
-	  (dump-byte ,n))
-	 (t
-	  (dump-fop ',word-fop)
-	  (quick-dump-number ,n 4))))
-
-;;; Dump out number NUM as BYTES bytes.
-
-(defun quick-dump-number (num bytes)
-  (do ((n num (ash n -8))
-       (i bytes (1- i)))
-      ((= i 0))
-    (dump-byte (logand n #o377))))
-
-;;; Start-Fasl-File  --  Internal
-;;;
-;;;    Set up fasdumper state and finish off the header.  The "FASL FILE"
-;;; header should already be written.  Called by Start-Assembly.
-;;;
-(defun start-fasl-file ()
-  ;; We now have a virgin FOP-TABLE, so clean up any old stuff.
-  (setq fop-table-counter 0)
-  ;; Just in case this didn't get cleaned up after an earlier compile.
-  (cond (fop-table-symbol-list
-	 (do ((sl fop-table-symbol-list (cdr sl)))
-	     ((null sl) (setq fop-table-symbol-list nil))
-	   (remprop (car sl) 'lisp::fop-table-index))))
-  ;; Clear the package alist.
-  (setq fop-table-package-list nil)
-  ;; And the table hashtable.
-  (clrhash *table-table*)
-  ;; Reset the dump-byte buffer
-  (setq *dump-byte-index* 0)
-  ;; Print header stuff.
-  (dump-byte 255)
-  ;; Perq code format.
-  (dump-fop 'lisp::fop-code-format)
-  (dump-byte c::target-fasl-code-format))
-
-;;; Terminate-Fasl-File  --  Internal
-;;;
-;;;    Finish off the current fasl group and clean up.  Called from 
-;;; Finish-Assembly.
-;;;
-(defun terminate-fasl-file ()
-  (dump-fop 'lisp::fop-verify-empty-stack)
-  (dump-fop 'lisp::fop-verify-table-size)
-  (quick-dump-number fop-table-counter 4)
-  (dump-fop 'lisp::fop-end-group)
-  (dump-dump-byte-buffer)
-  (do ((sl fop-table-symbol-list (cdr sl)))
-      ((null sl) (setq fop-table-symbol-list nil))
-    (remprop (car sl) 'lisp::fop-table-index)))
-  
-;;; Fasl-Dump-Cold-Load-Form  --  Internal
-;;;
-;;;    Similar to fasl-dump-form, except that the form is to be evaluated
-;;; at cold load time when in cold load.  This is used to dump package
-;;; frobbing forms.
-;;;
-(defun fasl-dump-cold-load-form (form)
-  (dump-fop 'lisp::fop-normal-load)
-  (let ((*hands-off-table* t))
-    (dump-object form))
-  (dump-fop 'lisp::fop-eval-for-effect)
-  (dump-fop 'lisp::fop-maybe-cold-load))
-
-
-;;; Dump-Object  -- Internal
-;;;
-;;;    Dump an object of any type.  This function dispatches to the correct
-;;; type-specific dumping function.  Table entry and lookup for non-immediate
-;;; objects other than lists and symbols is done here.
-;;;
-(defun dump-object (x)
-  (cond
-   ((listp x)
-    (cond ((null x)
-	   (dump-fop 'lisp::fop-empty-list))
-	  ((eq (car x) '%eval-at-load-time)
-	   (load-time-eval x))
-	  (t
-	   (dump-list x))))
-   ((symbolp x)
-    (if (eq x t) 
-	(dump-fop 'lisp::fop-truth)
-	(dump-symbol x)))
-   ((fixnump x) (dump-integer x))
-   ((characterp x) (dump-character x))
-   ((typep x 'short-float) (dump-short-float x))
-   (t
-    ;;
-    ;; Look for it in the table; if it is there, push it, otherwise
-    ;; dump it.
-    (let ((index (gethash x *table-table*)))
-      (cond
-       ((and index (not *hands-off-table*))
-	(dump-fop* index lisp::fop-byte-push lisp::fop-push))
-       (t
-	(typecase x
-	  (vector
-	   (cond ((stringp x) (dump-string x))
-		 ((subtypep (array-element-type x) '(unsigned-byte 16))
-		  (dump-i-vector x))
-		 (t
-		  (dump-vector x))))
-	  (array (dump-array x))
-	  (number
-	   (etypecase x
-	     (ratio (dump-ratio x))
-	     (complex (dump-complex x))
-;	     (single-float (dump-single-float x))
-	     (long-float (dump-long-float x))
-	     (integer (dump-integer x))))
-	  (compiled-function (dump-function x))
-	  (t
-	   (clc-error "This object cannot be dumped into a fasl file:~%  ~S" x)
-	   (dump-object nil)))
-	;;
-	;; If wasn't in the table, put it there...
-	(unless *hands-off-table*
-	  (dump-fop 'lisp::fop-pop)
-	  (dump-fop* fop-table-counter lisp::fop-byte-push lisp::fop-push)
-	  (setf (gethash x *table-table*) fop-table-counter)
-	  (incf fop-table-counter))))))))
-
-;;;; Number Dumping:
-
-;;; Dump a ratio
-
-(defun dump-ratio (x)
-  (dump-object (numerator x))
-  (dump-object (denominator x))
-  (dump-fop 'lisp::fop-ratio))
-
-;;; Or a complex...
-
-(defun dump-complex (x)
-  (dump-object (realpart x))
-  (dump-object (imagpart x))
-  (dump-fop 'lisp::fop-complex))
-
-;;; Dump an integer.
-
-(defun dump-integer (n)
-  (let* ((bytes (compute-bytes n)))
-    (cond ((= bytes 1)
-	   (dump-fop 'lisp::fop-byte-integer)
-	   (dump-byte n))
-	  ((< bytes 5)
-	   (dump-fop 'lisp::fop-word-integer)
-	   (quick-dump-number n 4))
-	  ((< bytes 256)
-	   (dump-fop 'lisp::fop-small-integer)
-	   (dump-byte bytes)
-	   (quick-dump-number n bytes))
-	  (t (dump-fop 'lisp::fop-integer)
-	     (quick-dump-number bytes 4)
-	     (quick-dump-number n bytes)))))
-
-;;; Compute how many bytes it will take to represent signed integer N.
-
-(defun compute-bytes (n)
-  (truncate (+ (integer-length n) 8) 8))
-
-;;;
-;;; These two are almost exactly alike, and could easily be the same function.
-
-(defun dump-short-float (x)
-  (multiple-value-bind (f exponent sign) (decode-float x)
-    (let ((mantissa (truncate (scale-float (* f sign) (float-precision f)))))
-      (dump-fop 'lisp::fop-float)
-      (dump-byte (1+ (integer-length exponent)))
-      (quick-dump-number exponent (compute-bytes exponent))
-      (dump-byte (1+ (integer-length mantissa)))
-      (quick-dump-number mantissa (compute-bytes mantissa)))))
-
-#|
-(defun dump-single-float (x)
-  (multiple-value-bind (f exponent sign) (decode-float x)
-    (let ((mantissa (truncate (scale-float (* f sign) (float-precision f)))))
-      (dump-fop 'lisp::fop-float)
-      (dump-byte (1+ (integer-length exponent)))
-      (dump-byte exponent)
-      (dump-byte (1+ (integer-length mantissa)))
-      (quick-dump-number mantissa (compute-bytes mantissa)))))
-|#
-;;; For long-floats we're careful that the dumped mantissa actually
-;;; has 63 significant bits, so the fasloader can recognize it as such.
-
-(defun dump-long-float (x)
-  (multiple-value-bind (f exponent sign) (decode-float x)
-    (let ((mantissa (truncate (scale-float (* f sign) (float-precision f)))))
-      (dump-fop 'lisp::fop-float)
-      (dump-byte (1+ (integer-length exponent)))
-      (quick-dump-number exponent (compute-bytes exponent))
-      (dump-byte (1+ (integer-length mantissa)))
-      (quick-dump-number mantissa (compute-bytes mantissa)))))
-
-;;;; Symbol Dumping:
-
-(defun dump-symbol (s)
-  (let ((number (get s 'lisp::fop-table-index)))
-    (if (and number (not *hands-off-table*))
-	;; Symbol is already in the table.  Just dump the index.
-	(dump-fop* number lisp::fop-byte-push lisp::fop-push)
-	;; Got to dump the symbol and put it into the table.
-	(let* ((pname (symbol-name s))
-	       (pname-length (length pname))
-	       (pkg (symbol-package s)))
-	  (cond ((null pkg)
-		 ;; Symbol is uninterned.
-		 (dump-fop* pname-length lisp::fop-uninterned-small-symbol-save
-			    lisp::fop-uninterned-symbol-save))
-		((eq pkg *package*)
-		 ;; Symbol is in current default package.  Just dump it.
-		 (dump-fop* pname-length lisp::fop-small-symbol-save
-			    lisp::fop-symbol-save))
-		((eq pkg *lisp-package*)
-		 (dump-fop* pname-length lisp::fop-lisp-small-symbol-save
-			    lisp::fop-lisp-symbol-save))
-		((eq pkg *keyword-package*)
-		 ;; Symbol is in current default package.  Just dump it.
-		 (dump-fop* pname-length lisp::fop-keyword-small-symbol-save
-			    lisp::fop-keyword-symbol-save))
-		(t
-		 ;; We have to dump this symbol with a package specifier.
-		 (let ((entry (assq pkg fop-table-package-list)))
-		   ;; Put the package into the table unless it's already there.
-		   (unless entry
-		     (unless *hands-off-table*
-		       (dump-fop 'lisp::fop-normal-load))
-		     (dump-string (package-name pkg))
-		     (dump-fop 'lisp::fop-package)
-		     (dump-fop 'lisp::fop-pop)
-		     (unless *hands-off-table*
-		       (dump-fop 'lisp::fop-maybe-cold-load))
-		     (setq entry (cons pkg fop-table-counter))
-		     (push entry fop-table-package-list)
-		     (incf fop-table-counter))
-		   (setq entry (cdr entry))
-		   (cond
-		    ((< pname-length 256)
-		     (dump-fop* entry
-				lisp::fop-small-symbol-in-byte-package-save
-				lisp::fop-small-symbol-in-package-save)
-		     (dump-byte pname-length))
-		    (t
-		     (dump-fop* entry
-				lisp::fop-symbol-in-byte-package-save
-				lisp::fop-symbol-in-package-save)
-		     (quick-dump-number pname-length 4))))))
-	  ;; Finish dumping the symbol and put it in table.
-	  (do ((index 0 (1+ index)))
-	      ((= index pname-length))
-	    (dump-byte (char-code (schar pname index))))
-	  (unless *hands-off-table*
-	    (setf (get s 'lisp::fop-table-index) fop-table-counter))
-	  (push s fop-table-symbol-list)
-	  (setq fop-table-counter (1+ fop-table-counter))))))
-
-;;; Dumper for lists.
-
-(defun dump-list (list)
-  (if (null list)
-      (dump-fop 'lisp::fop-empty-list)
-      (let ((index (gethash list *table-table*)))
-	(cond ((and index (not *hands-off-table*))
-	       (dump-fop* index lisp::fop-byte-push lisp::fop-push))
-	      (t
-	       (do ((l list (cdr l))
-		    (n 0 (1+ n)))
-		   ((atom l)
-		    (cond ((null l)
-			   (terminate-undotted-list n))
-			  (t (dump-object l)
-			     (terminate-dotted-list n))))
-		 (dump-object (car l)))
-	       (unless *hands-off-table*
-		 (dump-fop 'lisp::fop-pop)
-		 (dump-fop* fop-table-counter lisp::fop-byte-push
-			    lisp::fop-push)
-		 (setf (gethash list *table-table*) fop-table-counter)
-		 (incf fop-table-counter)))))))
-
-(defun terminate-dotted-list (n)
-  (case n
-    (1 (dump-fop 'lisp::fop-list*-1))
-    (2 (dump-fop 'lisp::fop-list*-2))
-    (3 (dump-fop 'lisp::fop-list*-3))
-    (4 (dump-fop 'lisp::fop-list*-4))
-    (5 (dump-fop 'lisp::fop-list*-5))
-    (6 (dump-fop 'lisp::fop-list*-6))
-    (7 (dump-fop 'lisp::fop-list*-7))
-    (8 (dump-fop 'lisp::fop-list*-8))
-    (T (do ((nn n (- nn 255)))
-	   ((< nn 256)
-	    (dump-fop 'lisp::fop-list*)
-	    (dump-byte nn))
-	 (dump-fop 'lisp::fop-list*)
-	 (dump-byte 255)))))
-
-;;; If N > 255, must build list with one list operator, then list* operators.
-
-(defun terminate-undotted-list (n)
-    (case n
-      (1 (dump-fop 'lisp::fop-list-1))
-      (2 (dump-fop 'lisp::fop-list-2))
-      (3 (dump-fop 'lisp::fop-list-3))
-      (4 (dump-fop 'lisp::fop-list-4))
-      (5 (dump-fop 'lisp::fop-list-5))
-      (6 (dump-fop 'lisp::fop-list-6))
-      (7 (dump-fop 'lisp::fop-list-7))
-      (8 (dump-fop 'lisp::fop-list-8))
-      (T (cond ((< n 256)
-		(dump-fop 'lisp::fop-list)
-		(dump-byte n))
-	       (t (dump-fop 'lisp::fop-list)
-		  (dump-byte 255)
-		  (do ((nn (- n 255) (- nn 255)))
-		      ((< nn 256)
-		       (dump-fop 'lisp::fop-list*)
-		       (dump-byte nn))
-		    (dump-fop 'lisp::fop-list*)
-		    (dump-byte 255)))))))
-
-;;;; Array dumping:
-
-;;; Named G-vectors get their subtype field set at load time.
-
-(defun dump-vector (obj)
-  (cond ((and (simple-vector-p obj)
-	      (= (%primitive get-vector-subtype obj)
-		 %g-vector-structure-subtype))
-	 (normal-dump-vector obj)
-	 (dump-fop 'lisp::fop-structure))
-	(t
-	 (normal-dump-vector obj))))
-
-(defun normal-dump-vector (v)
-  (do ((index 0 (1+ index))
-       (length (length v)))
-      ((= index length)
-       (dump-fop* length lisp::fop-small-vector lisp::fop-vector))
-    (dump-object (aref v index))))
-
-;;; Dump a string.
-
-(defun dump-string (s)
-  (let ((length (length s)))
-    (dump-fop* length lisp::fop-small-string lisp::fop-string)
-    (dotimes (i length)
-      (dump-byte (char-code (char s i))))))
-
-;;; Dump-Array  --  Internal
-;;;
-;;;    Dump a multi-dimensional array.  Someday when we figure out what
-;;; a displaced array looks like, we can fix this.
-;;;
-(defun dump-array (array)
-  (unless (zerop (%primitive header-ref array %array-displacement-slot))
-    (clc-error "Attempt to dump an array with a displacement, you lose big.")
-    (dump-object nil)
-    (return-from dump-array nil))
-
-  (let ((rank (array-rank array)))
-    (dotimes (i rank)
-      (dump-integer (array-dimension array i)))
-    (dump-object (%primitive header-ref array %array-data-slot))
-    (dump-fop 'lisp::fop-array)
-    (quick-dump-number rank 4)))
-
-
-;;; Dump a character.
-
-(defun dump-character (ch)
-  (cond
-   ((string-char-p ch)
-    (dump-fop 'lisp::fop-short-character)
-    (dump-byte (char-code ch)))
-   (t
-    (dump-fop 'lisp::fop-character)
-    (dump-byte (char-code ch))
-    (dump-byte (char-bits ch))
-    (dump-byte (char-font ch)))))
-
diff --git a/assembler/assembler.lisp b/assembler/assembler.lisp
deleted file mode 100644
index 7f4377292ee1808f9352b794d00f2b459342a341..0000000000000000000000000000000000000000
--- a/assembler/assembler.lisp
+++ /dev/null
@@ -1,1693 +0,0 @@
-;;; -*- Mode: Lisp; Package: Compiler; Log: clc.log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; Spice Lisp is currently incomplete and under active development.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; A user-level assembler for the ROMP.
-;;; Written by Skef Wholey.
-;;;
-;;; This program processes a file of lispy assembly code and produces a Lisp
-;;; FASL file.  It will be used primarily for coding the assembler support
-;;; routines, but later might be used by applications programmers to speed up
-;;; inner loops.
-;;;
-;;; The file to be assembled consists of Lisp forms.  Most forms are simply
-;;; evaluated -- macro definitions, constant declarations, and things like that
-;;; are made this way.  Three forms are treated specially:
-;;;   Define-Miscop, which defines a miscop,
-;;;   Define-Assembler-Routine, which defines a random piece of assembly code,
-;;;   Defun-In-Assembly-Code, which defines a Lisp-callable function.
-;;;
-(in-package "COMPILER")
-
-(export 'assemble-file)
-
-(import '(lisp::define-fop lisp::fop-assembler-routine
-			   lisp::fop-fixup-miscop-routine
-			   lisp::fop-fixup-user-miscop-routine
-			   lisp::fop-fixup-assembler-routine
-			   lisp::fop-fun)
-	(find-package 'compiler))
-
-;;; %%% Unixfy external definitions, references
-;;; %%% Possibly help enforce 8 character uniqueness lossage
-;;; %%% Data blocks
-;;; %%% Tied down things
-
-
-(defvar *undefined-labels* ()
-  "List of all undefined labels in the current file.")
-
-(defvar *defined-labels* ()
-  "List of all defined labels in the current file.")
-
-(defparameter romp-assembler-version "1.0")
-
-;;; The ROMP instruction set database for the user-level assembler.
-
-;;; All the stuff we need to know about an instruction is held in a structure
-;;; hanging off of its %Instruction-Info property.
-
-(defstruct (romp-info (:print-function print-romp-info)
-		      (:constructor make-romp-info (name format opcode)))
-  name				; symbolic name
-  format			; ROMP format
-  opcode)			; numeric opcode
-
-(defun print-romp-info (structure stream depth)
-  (declare (ignore depth))
-  (format stream "#<The ~S instruction>" (romp-info-name structure)))
-
-(defmacro def-romp-instr (name format opcode)
-  `(setf (get ',name '%instruction-info)
-	 (make-romp-info ',name ',format ,opcode)))
-
-
-;;; The half dozen "instruction formats" described in the ROMP architecture
-;;; guide aren't really sufficient for our purposes -- we've added a couple.
-;;; The formats are:
-;;;	JI  4 bit opcode, 4 bit N, 8 bits jump offset
-;;;     X   4 bit opcode, 3 register fields
-;;;     DS  4 bit opcode, 4 bit N, 2 registers
-;;;	R   8 bit opcode, 2 registers
-;;;	R1  8 bit opcode, 4 bit N, 1 register
-;;;	R2  8 bit opcode, 1 register, 4 bit N
-;;;     BI  8 bit opcode, 1 register, 20 bits jump offset
-;;;	BA  8 bit opcode, 24 bits absolute jump address
-;;;	D   8 bit opcode, 2 registers, 16 bit N
-;;;	SR  12 bit opcode, 1 register
-;;;	SN  12 bit opcode, 4 bit N
-
-
-;;; Storage Access instructions:
-
-(def-romp-instr lcs  ds #x04)
-(def-romp-instr lc   d  #xCE)
-(def-romp-instr lhas ds #x05)
-(def-romp-instr lha  d  #xCA)
-(def-romp-instr lhs  r  #xEB)
-(def-romp-instr lh   d  #xDA)
-(def-romp-instr ls   ds #x07)
-(def-romp-instr l    d  #xCD)
-(def-romp-instr lm   d  #xC9)
-(def-romp-instr tsh  d  #xCF)
-(def-romp-instr stcs ds #x01)
-(def-romp-instr stc  d  #xDE)
-(def-romp-instr sths ds #x02)
-(def-romp-instr sth  d  #xDC)
-(def-romp-instr sts  ds #x03)
-(def-romp-instr st   d  #xDD)
-(def-romp-instr stm  d  #xD9)
-
-;;; Address Computation instructions:
-
-(def-romp-instr cal  d  #xC8)
-(def-romp-instr cal16 d #xC2)
-(def-romp-instr cau  d  #xD8)
-(def-romp-instr cas  x  #x06)
-(def-romp-instr ca16 r  #xF3)
-(def-romp-instr inc  r2 #x91)
-(def-romp-instr dec  r2 #x93)
-(def-romp-instr lis  r2 #xA4)
- 
-;;; Branching instructions:
-
-(def-romp-instr bala ba #x8A)
-(def-romp-instr balax ba #x8B)
-(def-romp-instr bali bi #x8C)
-(def-romp-instr balix bi #x8D)
-(def-romp-instr balr r  #xEC)
-(def-romp-instr balrx r #xED)
-(def-romp-instr jb   ji #x01)
-(def-romp-instr bb   bi #x8E)
-(def-romp-instr bbx  bi #x8F)
-(def-romp-instr bbr  r1 #xEE)
-(def-romp-instr bbrx r1 #xEF)
-(def-romp-instr jnb  ji #x00)
-(def-romp-instr bnb  bi #x88)
-(def-romp-instr bnbx bi #x89)
-(def-romp-instr bnbr r  #xE8)
-(def-romp-instr bnbrx r  #xe9)
-
-;;; Trap instructions:
-
-(def-romp-instr ti   d  #xCC)
-(def-romp-instr tgte r  #xBD)
-(def-romp-instr tlt  r  #xBE)
-
-;;; Move and Insert instructions.
-
-(def-romp-instr mc03 r  #xF9)
-(def-romp-instr mc13 r  #xFA)
-(def-romp-instr mc23 r  #xFB)
-(def-romp-instr mc33 r  #xFC)
-(def-romp-instr mc30 r  #xFD)
-(def-romp-instr mc31 r  #xFE)
-(def-romp-instr mc32 r  #xFF)
-(def-romp-instr mftb r  #xBC)
-(def-romp-instr mftbil r2 #x9D)
-(def-romp-instr mftbiu r2 #x9C)
-(def-romp-instr mttb r  #xBF)
-(def-romp-instr mttbil r2 #x9F)
-(def-romp-instr mttbiu r2 #x9E)
-
-;;; Arithmetic instructions.
-
-(def-romp-instr a    r  #xE1)
-(def-romp-instr ae   r  #xF1)
-(def-romp-instr aei  d  #xD1)
-(def-romp-instr ai   d  #xC1)
-(def-romp-instr ais  r2 #x90)
-(def-romp-instr abs  r  #xE0)
-(def-romp-instr onec r  #xF4)
-(def-romp-instr twoc r  #xE4)
-(def-romp-instr c    r  #xB4)
-(def-romp-instr cis  r2 #x94)
-(def-romp-instr ci   d  #xD4)
-(def-romp-instr cl   r  #xB3)
-(def-romp-instr cli  d  #xD3)
-(def-romp-instr exts r  #xB1)
-(def-romp-instr s    r  #xE2)
-(def-romp-instr sf   r  #xB2)
-(def-romp-instr se   r  #xF2)
-(def-romp-instr sfi  d  #xD2)
-(def-romp-instr sis  r2 #x92)
-(def-romp-instr d    r  #xB6)
-(def-romp-instr m    r  #xE6)
-
-;;; Logical instructions.
-
-(def-romp-instr clrbl r2 #x99)
-(def-romp-instr clrbu r2 #x98)
-(def-romp-instr setbl r2 #x9B)
-(def-romp-instr setbu r2 #x9A)
-(def-romp-instr n     r  #xE5)
-(def-romp-instr nilz  d  #xC5)
-(def-romp-instr nilo  d  #xC6)
-(def-romp-instr niuz  d  #xD5)
-(def-romp-instr niuo  d  #xD6)
-(def-romp-instr o     r  #xE3)
-(def-romp-instr oil   d  #xC4)
-(def-romp-instr oiu   d  #xC3)
-(def-romp-instr x     r  #xE7)
-(def-romp-instr xil   d  #xC7)
-(def-romp-instr xiu   d  #xD7)
-(def-romp-instr clz   r  #xF5)
-
-;;; Shifting instructions.
-
-(def-romp-instr sar   r  #xB0)
-(def-romp-instr sari  r2 #xA0)
-(def-romp-instr sari16 r2 #xA1)
-(def-romp-instr sr    r  #xB8)
-(def-romp-instr sri   r2 #xA8)
-(def-romp-instr sri16 r2 #xA9)
-(def-romp-instr srp   r  #xB9)
-(def-romp-instr srpi  r2 #xAC)
-(def-romp-instr srpi16 r2 #xAD)
-(def-romp-instr sl    r  #xBA)
-(def-romp-instr sli   r2 #xAA)
-(def-romp-instr sli16 r2 #xAB)
-(def-romp-instr slp   r  #xBB)
-(def-romp-instr slpi  r2 #xAE)
-(def-romp-instr slpi16 r2 #xAF)
-
-;;; Special Purpose Register Manipulation instructions.
-
-(def-romp-instr mtmq  sr #xB5A)
-(def-romp-instr mfmq  sr #x96A)
-(def-romp-instr mtcsr sr #xB5F)
-(def-romp-instr mfcsr sr #x96F)
-(def-romp-instr clrcb sn #x95F)
-(def-romp-instr setcb sn #x97F)
-
-;;; Execution Control instructions.
-
-(def-romp-instr lps   d  #xD0)
-(def-romp-instr svc   d  #xC0)
-
-(defvar *produce-unixy-cruft* nil
-  "If T, the LAP file will have stuff that should be legal food for a unixy
-  assembler.")
-
-
-;;; PRINT-FILE-HEADER prints assorted information at the start of an
-;;; ascii output file.
-
-(defun print-file-header (stream output-type input-namestring)
-  (format stream
-	  "~%;;; ~A output for file ~A."
-	  output-type input-namestring)
-  (format stream
-	  "~%;;; Assembled by assembler version ~A.~%"
-	  romp-assembler-version))
-
-(defun assemble-file (input-pathname
-		      &key (output-file t) (error-file t) (listing-file nil)
-		           ((:unixy-lap-file *produce-unixy-cruft*) nil))
-  "Assembles the file named by the Input-Pathname."
-  (declare (optimize (speed 3) (safety 0)))
-  (let* ((*clc-input-stream*
-	  (open (merge-pathnames input-pathname ".romp") :direction :input))
-	 (*clc-fasl-stream*
-	  (if output-file
-	      (open (if (eq output-file t)
-			(make-pathname :defaults input-pathname :type "fasl")
-			output-file)
-		    :if-exists :new-version
-		    :direction :output
-		    :element-type '(unsigned-byte 8))))
-	 (error-file-stream
-	  (if error-file
-	      (open (if (eq error-file t)
-			(make-pathname :defaults input-pathname :type "err")
-			error-file)
-		    :if-exists :new-version
-		    :direction :output)))
-	 (*clc-err-stream*
-	  (if error-file
-	      (make-broadcast-stream error-file-stream *standard-output*)
-	      *standard-output*))
-	 (*clc-lap-stream*
-	  (if listing-file
-	      (open (if (eq listing-file t)
-			(make-pathname :defaults input-pathname
-				       :type (if *produce-unixy-cruft*
-						 "s"
-						 "list"))
-			listing-file)
-		    :if-exists :new-version
-		    :direction :output)))
-	 (error-count 0)
-	 (warning-count 0)
-	 (assembly-won nil)
-	 (input-namestring (namestring input-pathname))
-	 (*defined-labels* ())
-	 (*undefined-labels* ())
-	 (*package* (find-package "COMPILER")))
-    (unwind-protect
-      (progn
-	;; Initialize the files.
-	(when output-file
-	  (format *clc-fasl-stream*
-		  "FASL FILE output from ~A~%" input-namestring)
-	  (start-fasl-file)
-	  (fasl-dump-cold-load-form '(in-package "COMPILER")))
-	(if error-file
-	    (print-file-header error-file-stream "Error" input-namestring))
-	(if (and listing-file (not *produce-unixy-cruft*))
-	    (print-file-header *clc-lap-stream* "Listing" input-namestring))
-	;; All set up.  Let the festivities begin.	    
-	(clc-mumble "~%Starting assembly of file ~S.~%" input-namestring)
-	(assembler-loop)
-	;; All done.  Let the post-mortems begin.
-	(clc-mumble "~2%Finished assembly of file ~S." input-namestring)
-	(clc-mumble "~%~S Errors, ~S Warnings." error-count warning-count)
-	(dolist (label *defined-labels*)
-	  (setq *undefined-labels*
-		(delete label *undefined-labels* :test #'eq)))
-	(if (> (length *undefined-labels*) 0)
-	    (clc-mumble "~%~S Undefined labels in file ~S: ~{~%	~S~}."
-			(length *undefined-labels*) input-namestring
-			*undefined-labels*))
-	(terpri)
-	(setq assembly-won t))
-      ;; Close files.  Unwind-Protect makes sure that these get closed even
-      ;; if compilation is aborted.  If the assembly did not win, abort the fasl
-      ;; file instead of writing out a whole lot of useless stuff.
-      (close *clc-input-stream*)
-      (when (streamp *clc-fasl-stream*)
-	(terminate-fasl-file)
-	(close *clc-fasl-stream* :abort (not assembly-won)))
-      (when error-file-stream (close error-file-stream))
-      (when (streamp *clc-lap-stream*) (close *clc-lap-stream*)))))
-
-(defvar *unique-thing* '(*unique-thing*))
-
-(defun assembler-loop ()
-  (do ((form (read *clc-input-stream* nil *unique-thing*)
-	     (read *clc-input-stream* nil *unique-thing*)))
-      ((eq form *unique-thing*))
-    (process-assembler-form form)))
-
-(defun process-assembler-form (form)
-  (declare (optimize (speed 3) (safety 0)))
-  (cond ((atom form))
-	((eq (car form) 'define-miscop)
-	 (process-define-miscop form))
-	((eq (car form) 'define-user-miscop)
-	 (process-define-user-miscop form))
-	((eq (car form) 'define-assembler-routine)
-	 (process-define-assembler-routine form))
-	((eq (car form) 'defun-in-assembly-code)
-	 (process-defun-in-assembly-code form))
-	((macro-function (car form))
-	 (process-assembler-form (macroexpand form)))
-	((or (functionp (car form)) (special-form-p (car form)))
-	 (eval form))
-	(t
-	 (eval form))))
-
-;;; There are three kinds of labels:
-;;;  Local labels, which are used within a miscop or routine.
-;;;  External labels, which are used between routines.
-;;;  Absolute labels, which might not be used at all.
-;;;
-;;; Labels appear as symbols in the code, and information about a label is
-;;; stored on that symbol's property list.  The kind of label, either LOCAL,
-;;; EXTERNAL, or ABSOLUTE, is store on the %LABEL-KIND property.  The location
-;;; of the label, is stored on the %LABEL-LOCATION property.  For local labels,
-;;; the location is the offset in halfwords from the beginning of the routine.
-;;; The locations of external labels is left unresolved until load time.  The
-;;; location of absolute labels the byte address of the code they address.
-;;;
-;;; Labels may be referenced in one of four ways:
-;;;  JI, which means the reference is from a JI relative branch instruction.
-;;;  BI, which means the reference is from a BI relative branch instruction.
-;;;  BA, which means the reference is from a BA absolute branch instruction.
-;;;  L, which means the reference is from a pair of CA instructions.
-;;;
-;;; When each routine is assembled and dumped, the locations of any external
-;;; labels defined in it are also dumped.  The locations of any external labels
-;;; it defines are dumped as well.  When all files making up the system are
-;;; loaded, the routines are "linked" by resolving the external references.
-
-
-(defvar *local-labels* ()
-  "List of labels local to this routine.")
-
-(defvar *external-labels* ()
-  "List of external labels defined by this routine.  Each definition is of the
-  form (Label . Location).")
-
-(defvar *external-references* ()
-  "List of external references made by this routine.  Each reference is of the
-  form (Type Label Location).")
-
-;;; Define-XXX-Label defines a label at the given location.
-
-(defun define-local-label (label location)
-  (declare (optimize (speed 3) (safety 0)))
-  (when (get label '%label-kind)
-    (clc-error "~S is already a defined label." label))
-  (push label *local-labels*)
-  (push label *defined-labels*)
-  (setf (get label '%label-kind) 'local)
-  (setf (get label '%label-location) location))
-
-(defun define-external-label (label location)
-  (declare (optimize (speed 3) (safety 0)))
-  (when (get label '%label-kind)
-    (clc-error "~S is already a defined label." label))
-  (push (cons label location) *external-labels*)
-  (push label *defined-labels*)
-  (setf (get label '%label-kind) 'external)
-  (setf (get label '%label-location) location))
-
-
-;;; Reference-Label references a label in the given way.  If a location can
-;;; sensibly be returned, it is.  Otherwise, 0 is returned and the reference
-;;; is added to the list of references to be resolved at load time.  The
-;;; Location parameter is the halfword offset in the current routine at
-;;; which the reference is made.
-
-(defun reference-label (label how location)
-  (declare (optimize (speed 3) (safety 0)))
-  (when (and (not (memq label *defined-labels*))
-	     (not (memq label *undefined-labels*)))
-    (push label *undefined-labels*))
-  (case (get label '%label-kind)
-    ((local external)			; treated the same at this point
-     (case how
-       ((bi ji)
-	(get label '%label-location))
-       ((ba l)
-	(push `(,how ,label ,location)
-	      *external-references*)
-	0)))
-    (absolute
-     (case how
-       ((bi ji)
-	(push `(,how ,label ,location)
-	      *external-references*)
-	0)
-       ((ba l)
-	(get label '%label-location))))
-    (T
-     (push `(,how ,label ,location) *external-references*)
-     0)))
-
-
-;;; Short-Jump-P is used by the jump optimizer to determine if a branch can be
-;;; turned into a Jump.  The Location of the branching instruction and the
-;;; label that is the destination of the jump are given.  Note that if the thing
-;;; is 128 words away, we'll be able to short jump to it after the halfword is
-;;; optimizied out of the branching instruction.
-
-(defun short-jump-p (location label)
-  (declare (fixnum location))
-  (case (get label '%label-kind)
-    ((local external)
-     (<= -128 (the fixnum (- (the fixnum (get label '%label-location))
-			     location)) 128))
-    (t
-     nil)))
-
-
-;;; Clean-Up-Labels nukes the properties of labels defined in the
-;;; current routine.
-
-(defun clean-up-labels ()
-  (declare (optimize (speed 3) (safety 0)))
-  (dolist (label *local-labels*)
-    (remprop label '%label-kind)
-    (remprop label '%label-location))
-  (dolist (label *external-labels*)
-    (remprop (car label) '%label-kind)
-    (remprop (car label) '%label-location)))
-
-;;; Process-XXX does a little special stuff and calls Assemble-Top-Level-List
-;;; to spit out code.
-
-(defun process-define-miscop (form)
-  (let ((function-name (cadr form))
-	(*local-labels* '())
-	(*external-labels* '())
-	(*external-references* '())
-	(body (cddr form)))
-    (define-external-label function-name 0)
-    (unwind-protect
-      (assemble-top-level-list function-name body)
-      (clean-up-labels))
-    (dump-fop 'lisp::fop-fixup-miscop-routine)
-    (clc-mumble "~%~S assembled." function-name)))
-
-(defun process-define-user-miscop (form)
-  (let ((function-name (cadr form))
-	(*local-labels* '())
-	(*external-labels* '())
-	(*external-references* '())
-	(body (cddr form)))
-    (define-external-label function-name 0)
-    (unwind-protect
-      (assemble-top-level-list function-name body)
-      (clean-up-labels))
-    (dump-fop 'lisp::fop-fixup-user-miscop-routine)
-    (clc-mumble "~%~S assembled." function-name)))
-
-(defun process-define-assembler-routine (form)
-  (let ((function-name (cadr form))
-	(*local-labels* '())
-	(*external-labels* '())
-	(*external-references* '())
-	(body (cddr form)))
-    (define-external-label function-name 0)
-    (unwind-protect
-      (assemble-top-level-list function-name body)
-      (clean-up-labels))
-    (dump-fop 'lisp::fop-fixup-assembler-routine)
-    (clc-mumble "~%~S assembled." function-name)))
-
-(defun process-defun-in-assembly-code (form)
-  (declare (ignore form))
-  (clc-error "Defun-In-Assembly-Code is not yet implemented."))
-
-;;; Pass 1.  We just fly down the list, expanding macros and finding addresses
-;;; of the labels.  The macroexpanded code is put into *pass1-list*.  Each
-;;; element of that list is either a cons of the instruction's byte offset from
-;;; the start of the routine and the instruction or a label.
-
-(defvar *pass1-list* '())
-
-;;; Assemble-Top-Level-List performs both passes, writing out the length in
-;;; bytes of the function before anything else.  The Process-mumbles count on
-;;; the length in bytes to be written out that way.
-
-(defun assemble-top-level-list (function-name list)
-  (let ((*pass1-list* '()))
-    (do ((list list (cdr list))
-	 (location 0))
-	((null list)
-	 (setq *pass1-list* (nreverse *pass1-list*))
-	 (setq location (optimize-jumps location))
-	 (dump-fop 'lisp::fop-assembler-routine)
-	 (quick-dump-number (ash location 1) 4)
-	 (pass2-top-level-list)
-	 (let ((*hands-off-table* t))
-	   (dump-fop 'lisp::fop-normal-load)
-	   (dump-object function-name)
-	   (dump-object *external-labels*)
-	   (dump-object *external-references*)
-	   (dump-fop 'lisp::fop-maybe-cold-load)))
-      (setq location (assemble-one-instruction (car list) location)))))
-
-;;; Symbols in the instruction list are labels -- keywords are external labels.
-;;; Lists that don't begin with an instruction mnemonic are macroexpanded and
-;;; expected to return a list of instructions.
-
-(defun assemble-one-instruction (inst location)
-  (declare (optimize (speed 3) (safety 0)))
-  (cond ((atom inst)
-	 (if (keywordp inst)
-	     (define-external-label inst location)
-	     (define-local-label inst location))
-	 (push inst *pass1-list*))
-	(t
-	 (let ((info (get (car inst) '%instruction-info)))
-	   (cond (info
-		  (push (cons location inst) *pass1-list*)
-		  (case (romp-info-format info)
-		    ((ji x ds r r1 r2 sr sn)
-		     (setq location (+ location 1)))
-		    ((bi ba d)
-		     (setq location (+ location 2)))))
-		 ((macro-function (car inst))
-		  (dolist (inst (macroexpand inst))
-		    (setq location (assemble-one-instruction inst location))))
-		 (t
-		  (clc-error "~S is a bad instruction list." inst))))))
-  location)
-
-;;; Jump optimizer.  We turn BI branches into JI branches if we can.  Currently
-;;; we punt on the possibility that the halfword saved by optimizing a branch
-;;; might make possible optimization of branches already processed, since such
-;;; computation chews up a lot of time for relatively little gain.  We return
-;;; the new number of halfwords in the *Pass1-List*.
-
-(defun optimize-jumps (length)
-  (declare (optimize (speed 3) (safety 0)))
-  (do* ((list *pass1-list* (cdr list))
-	(stuff (car list) (car list))
-	(instp (consp stuff) (consp stuff))
-	(location (if instp (car stuff)) (if instp (car stuff)))
-	(inst (if instp (cdr stuff)) (if instp (cdr stuff))))
-       ((null list) length)
-    (when (and instp
-	       (or (eq (car inst) 'bb) (eq (car inst) 'bnb))
-	       (<= 8 (eval (cadr inst)) 15)
-	       (short-jump-p location (caddr inst)))
-      (setf (car inst) (cdr (assoc (car inst) '((bb . jb) (bnb . jnb)))))
-      (setf (cadr inst) (- (cadr inst) 8))
-      (setq length (1- length))
-      (dolist (stiff (cdr list))
-	(if (consp stiff)
-	    (setf (car stiff) (1- (car stiff)))))
-      (dolist (label *local-labels*)
-	(let ((loc (get label '%label-location)))
-	  (when (> loc location)
-	    (setf (get label '%label-location) (1- loc)))))
-      (dolist (label *external-labels*)
-	(let ((loc (cdr label)))
-	  (when (> loc location)
-	    (setf (cdr label) (1- loc))
-	    (setf (get (car label) '%label-location) (1- loc))))))))
-
-;;; Pass 2.  We fly down the list created in pass 1, and interpret the
-;;; instructions according to their format.  We spit the binary code out to the
-;;; *Clc-Fasl-Stream*, and listing information out to *Clc-Lap-Stream* using
-;;; Dump-Instruction.
-
-(defun pass2-top-level-list ()
-  (declare (optimize (speed 3) (safety 0)))
-  (when *clc-lap-stream*
-    (if *produce-unixy-cruft*
-	(format *clc-lap-stream* "~2%~(~A~):" (unixfy function-name))
-	(format *clc-lap-stream* "~2%                    ~S~%" function-name)))
-  (dolist (stuff *pass1-list*)
-    (if (atom stuff)
-	(dump-instruction stuff)
-	(let* ((location (car stuff))
-	       (inst (cdr stuff))
-	       (name (car inst))
-	       (args (cdr inst))
-	       (info (get name '%instruction-info))
-	       (opcode (romp-info-opcode info)))
-	  (case (romp-info-format info)
-	    (ji
-	     (let* ((n (car args))
-		    (n-value (eval n))
-		    (ji (cadr args))
-		    (ji-value (reference-label ji 'ji location)))
-	       (cond ((not (and n ji))
-		      (clc-error "Bad JI format instruction: ~S." inst))
-		     ((not (<= 0 n-value 7))
-		      (clc-error "N field out of range in ~S." inst))
-		     (t
-		      (let ((distance (- ji-value location)))
-			(unless (<= -128 distance 127)
-			  (clc-error "Out of range JI branch in ~S." inst))
-			(dump-instruction
-			 inst (logior (ash opcode 3) n-value)
-			      (logand distance 255)))))))
-	    (x
-	     (let* ((ra (car args))
-		    (ra-value (eval-register ra))
-		    (rb (cadr args))
-		    (rb-value (eval-register rb))
-		    (rc (caddr args))
-		    (rc-value (eval-register rc)))
-	       (cond ((not (and ra-value rb-value rc-value))
-		      (clc-error "Too few or illegal registers specified in ~S."
-				 inst))
-		     (t
-		      (dump-instruction
-		       inst (logior (ash opcode 4) ra-value)
-		            (logior (ash rb-value 4) rc-value))))))
-	    (ds
-	     (let* ((rb (car args))
-		    (rb-value (eval-register rb))
-		    (rc (cadr args))
-		    (rc-value (eval-register rc))
-		    (i (caddr args))
-		    (i-value (eval i)))
-	       (cond ((not (and i rb rc))
-		      (clc-error "Bad DS format instruction: ~S." inst))
-		     ((not (<= 0 i-value 15))
-		      (clc-error "I field out of range in ~S." inst))
-		     (t
-		      (dump-instruction
-		       inst (logior (ash opcode 4) i-value)
-		            (logior (ash rb-value 4) rc-value))))))
-	    (r
-	     (let* ((rb (car args))
-		    (rb-value (eval-register rb))
-		    (rc (cadr args))
-		    (rc-value (eval-register rc)))
-	       (cond ((not (and rb-value rc-value))
-		      (clc-error "Bad R format instruction: ~S" inst))
-		     (t
-		      (dump-instruction
-		       inst opcode (logior (ash rb-value 4) rc-value))))))
-	    (r1
-	     (let* ((rb (car args))
-		    (rb-value (eval rb))
-		    (rc (cadr args))
-		    (rc-value (eval-register rc)))
-	       (cond ((not (and rb-value rc-value))
-		      (clc-error "Bad R format instruction: ~S" inst))
-		     (t
-		      (dump-instruction
-		       inst opcode (logior (ash rb-value 4) rc-value))))))
-	    (r2
-	     (let* ((rb (car args))
-		    (rb-value (eval-register rb))
-		    (rc (cadr args))
-		    (rc-value (eval rc)))
-	       (cond ((not (and rb-value rc-value))
-		      (clc-error "Bad R format instruction: ~S" inst))
-		     (t
-		      (dump-instruction
-		       inst opcode (logior (ash rb-value 4) rc-value))))))
-	    (sr
-	     (let* ((rb (car args))
-		    (rb-value (eval-register rb)))
-	       (cond ((not rb-value)
-		      (clc-error "Bad S format instruction: ~S" inst))
-		     (t
-		      (dump-instruction
-		       inst (ash opcode -4)
-		            (logior (logand (ash opcode 4) 255) rb-value))))))
-	    (sn
-	     (let* ((rb (car args))
-		    (rb-value (eval rb)))
-	       (cond ((not rb-value)
-		      (clc-error "Bad S format instruction: ~S" inst))
-		     (t
-		      (dump-instruction
-		       inst (ash opcode -4)
-		            (logior (logand (ash opcode 4) 255) rb-value))))))
-	    (bi
-	     (let* ((rb (car args))
-		    (rb-value (eval-register rb))
-		    (bi (cadr args))
-		    (bi-value (reference-label bi 'bi location)))
-	       (cond ((not (and rb-value bi))
-		      (clc-error "Bad BI format instruction: ~S." inst))
-		     (t
-		      (let ((distance (- bi-value location)))
-			(unless (<= -524288 distance 524287)
-			  (clc-error "Out of range JI branch in ~S." inst))
-			(dump-instruction
-			 inst opcode
-			      (logior (ash rb-value 4)
-				      (logand (ash distance -16) 15))
-		              (logand (ash distance -8) 255)
-		              (logand distance 255)))))))
-	    (ba
-	     (let* ((ba (car args))
-		    (ba-value (cond ((fixnump ba) ba)
-				    ((and (listp ba)
-					  (eq (car ba) 'symbol-value))
-				     (symbol-value (cadr ba)))
-				    (T (reference-label ba 'ba location)))))
-	       (cond ((not ba)
-		      (clc-error "Bad BA format instruction: ~S." inst))
-		     (t
-		      (dump-instruction inst opcode
-					(logand (ash ba-value -16) 255)
-					(logand (ash ba-value -8) 255)
-					(logand ba-value 255))))))
-	    (d
-             (let* ((rb (car args))
-		    (rb-value (eval-register rb))
-		    (rc (cadr args))
-		    (rc-value (eval-register rc))
-		    (i (caddr args))
-		    (i-value (eval i)))
-	       (cond ((not (and i rb rc))
-		      (clc-error "Bad D format instruction: ~S." inst))
-		     ;; Sometimes I is sign extended, sometimes not.  Assume the
-		     ;;  guy knows what he's doing.
-		     ((not (<= -32768 i-value 65535))
-		      (clc-error "I field out of range in ~S." inst))
-		     (t
-		      (dump-instruction
-		       inst opcode
-		            (logior (ash rb-value 4) rc-value)
-		            (logand (ash i-value -8) 255)
-		            (logand i-value 255))))))))))
-  (when *clc-lap-stream*
-    (terpri *clc-lap-stream*)))
-
-
-;;; Dump-Instruction dumps out some bytes to the fasl file and a nice line to
-;;; the listing file.
-
-(defun dump-instruction (inst &rest bytes)
-  (declare (optimize (speed 3) (safety 0)))
-  (when *clc-lap-stream*
-    (if *produce-unixy-cruft*
-	(output-unixy-instruction inst)
-	(if (atom inst)
-	    (format *clc-lap-stream* "~%                    ~S" inst)
-	    (if (cddr bytes)
-		(format *clc-lap-stream*
-			"~%~2,'0X ~2,'0X ~2,'0X ~2,'0X         ~S"
-			(car bytes) (cadr bytes) (caddr bytes)
-			(cadddr bytes) inst)
-		(format *clc-lap-stream*
-			"~%~2,'0X ~2,'0X               ~S"
-			(car bytes) (cadr bytes) inst)))))
-  (dolist (byte bytes)
-    (dump-byte byte)))
-
-;;; Compatability for silly Unixy assembler.
-
-(defun output-unixy-instruction (inst)
-  (declare (optimize (speed 3) (safety 0)))
-  (if (atom inst)
-      (format *clc-lap-stream* "~%~(~A~):" (unixfy inst))
-      (let* ((name (car inst))
-	     (args (cdr inst))
-	     (info (get name '%instruction-info)))
-	(case (romp-info-format info)
-	  (ji
-	   (format *clc-lap-stream* "~%~(	~A	~A,~A~)"
-		   (case name (jb 'bb) (jnb 'bnb))
-		   (+ (eval (car args)) 8)
-		   (unixfy (cadr args))))
-	  (x
-	   (format *clc-lap-stream* "~%~(	~A	~A,~A,~A~)"
-		   name (unixfy (car args)) (unixfy (cadr args))
-		   (unixfy (caddr args))))
-	  (ds
-	   (format *clc-lap-stream* "~%~(	~A	~A,~A(~A)~)"
-		   (get-unixy-long-name name)
-		   (unixfy (car args)) (eval (caddr args))
-		   (unixfy (cadr args))))
-	  (r
-	   (if (eq name 'lhs)
-	       (format *clc-lap-stream* "~%~(	~A	~A,0(~A)~)"
-		       'lh (unixfy (car args)) (unixfy (cadr args)))
-	       (format *clc-lap-stream* "~%~(	~A	~A,~A~)"
-		       name (unixfy (car args)) (unixfy (cadr args)))))
-	  (r1
-	   (format *clc-lap-stream* "~%~(	~A	~A,~A~)"
-		   name (eval (car args)) (unixfy (cadr args))))
-	  (r2
-	   (if (eq name 'cis) (setq name 'ci))
-	   (cond ((memq name '(sari16 sri16 srpi16 sli16 slpi16))
-		  (format *clc-lap-stream* "~%~(	~A	~A,~A~)"
-			  (case name
-			    (sari16 'sari)
-			    (sri16 'sri)
-			    (srpi16 'srpi)
-			    (sli16 'sli)
-			    (slpi16 'slpi))
-			  (unixfy (car args)) (+ 16 (eval (cadr args)))))
-		 ((memq name '(mftbil mttbil))
-		  (format *clc-lap-stream* "~%~(	~A	~A,~A~)"
-			  (case name
-			    (mftbil 'mftbi)
-			    (mttbil 'mttbi))
-			  (unixfy (car args)) (- 32 (eval (cadr args)))))
-		 ((memq name '(mftbiu mttbiu))
-		  (format *clc-lap-stream* "~%~(	~A	~A,~A~)"
-			  (case name
-			    (mftbiu 'mftbi)
-			    (mttbiu 'mttbi))
-			  (unixfy (car args)) (- 16 (eval (cadr args)))))
-		 (T (format *clc-lap-stream* "~%~(	~A	~A,~A~)"
-			    name (unixfy (car args)) (eval (cadr args))))))
-	  (bi
-	   (format *clc-lap-stream* "~%~(	~A	~A,~A~)"
-		   name (unixfy (car args)) (unixfy (cadr args))))
-	  (ba
-	   (format *clc-lap-stream* "~%~(	~A	~A~)"
-		   name (unixfy (car args))))
-	  (d
-	   (if (memq name '(lc lha lh l lm tsh stc sth st stm cal cal16 cau))
-	       (format *clc-lap-stream* "~%~(	~A	~A,~A(~A)~)"
-		       name (unixfy (car args)) (eval (caddr args))
-		       (unixfy (cadr args)))
-	       (if (memq name '(ci cli))
-		   (format *clc-lap-stream* "~%~(	~A	~A,~A~)"
-			   name (unixfy (cadr args)) (eval (caddr args)))
-		   (format *clc-lap-stream* "~%~(	~A	~A,~A,~A~)"
-			   name (unixfy (car args)) (unixfy (cadr args))
-			   (eval (caddr args))))))
-	  (sr
-	   (cond ((memq name '(mtmq mfmq))
-		  (format *clc-lap-stream* "~%~(	~A	~A,~A~)"
-			  (if (eq name 'mtmq) 'mts 'mfs)
-			  10 (unixfy (car args))))
-		 (T (format *clc-lap-stream* "~%~(	~A	~A~)"
-			    name (unixfy (car args))))))
-	  (sn
-	   (format *clc-lap-stream* "~%~(	~A	~A~)"
-		   name (eval (car args))))))))
-
-(defun unixfy (thing)
-  (if (symbolp thing)
-      (substitute #\_ #\-
-		  (the string (copy-seq (the string (symbol-name thing)))))
-      thing))
-
-(defun get-unixy-long-name (name)
-  (case name
-    (ls 'l)
-    (sts 'st)
-    (lhas 'lha)
-    (sths 'sth)
-    (lcs 'lc)
-    (stcs 'stc)))
-
-;;; Nice branching instructions.
-
-(defconstant condition-code-alist
-  '((pz . 8) (lt . 9) (eq . 10) (gt . 11) (c0 . 12) (ov . 14) (tb . 15)
-	     (<0 . 9) (=0 . 10) (>0 . 11)))
-
-(defconstant not-condition-code-alist
-  '((po . 8) (ge . 9)  (ne . 10)  (le . 11) (nc0 . 12) (nov . 14) (ntb . 15)
-	     (>=0 . 9) (<>0 . 10) (<=0 . 11)))
-
-(defmacro defbranch (name on on-not)
-  `(defmacro ,name (destination &optional (condition 'po))
-     (let ((cc (cdr (assq condition condition-code-alist))))
-       (if cc
-	   `((,',on ,cc ,destination))
-	   (if (setq cc (cdr (assq condition not-condition-code-alist)))
-	       `((,',on-not ,cc ,destination))
-	       (error "Unknown condition code: ~S."))))))
-
-(defbranch branch   bb   bnb)		; branch
-(defbranch branchx  bbx  bnbx)		; branch with execute
-(defbranch rbranch  bbr  bnbr)		; register branch
-(defbranch rbranchx bbrx bnbrx)  	; register branch with execute
-
-(defmacro b (destination) `((branch ,destination)))
-(defmacro beq (destination) `((branch ,destination =0)))
-(defmacro bne (destination) `((branch ,destination <>0)))
-(defmacro blt (destination) `((branch ,destination <0)))
-(defmacro bgt (destination) `((branch ,destination >0)))
-(defmacro bge (destination) `((branch ,destination >=0)))
-(defmacro ble (destination) `((branch ,destination <=0)))
-(defmacro bx (destination) `((branchx ,destination)))
-(defmacro beqx (destination) `((branchx ,destination =0)))
-(defmacro bnex (destination) `((branchx ,destination <>0)))
-(defmacro bltx (destination) `((branchx ,destination <0)))
-(defmacro bgtx (destination) `((branchx ,destination >0)))
-(defmacro bgex (destination) `((branchx ,destination >=0)))
-(defmacro blex (destination) `((branchx ,destination <=0)))
-(defmacro br (destination) `((rbranch ,destination)))
-(defmacro breq (destination) `((rbranch ,destination =0)))
-(defmacro brne (destination) `((rbranch ,destination <>0)))
-(defmacro brlt (destination) `((rbranch ,destination <0)))
-(defmacro brgt (destination) `((rbranch ,destination >0)))
-(defmacro brge (destination) `((rbranch ,destination >=0)))
-(defmacro brle (destination) `((rbranch ,destination <=0)))
-(defmacro brx (destination) `((rbranchx ,destination)))
-(defmacro breqx (destination) `((rbranchx ,destination =0)))
-(defmacro brnex (destination) `((rbranchx ,destination <>0)))
-(defmacro brltx (destination) `((rbranchx ,destination <0)))
-(defmacro brgtx (destination) `((rbranchx ,destination >0)))
-(defmacro brgex (destination) `((rbranchx ,destination >=0)))
-(defmacro brlex (destination) `((rbranchx ,destination <=0)))
-
-(defmacro bov (destination) `((branch ,destination ov)))
-(defmacro bnov (destination) `((branch ,destination nov)))
-(defmacro brov (destination) `((rbranch ,destination ov)))
-(defmacro brnov (destination) `((rbranch ,destination nov)))
-(defmacro bovx (destination) `((branchx ,destination ov)))
-(defmacro bnovx (destination) `((branchx ,destination nov)))
-(defmacro brovx (destination) `((rbranchx ,destination ov)))
-(defmacro brnovx (destination) `((rbranchx ,destination nov)))
-
-(defmacro btb (destination) `((branch ,destination tb)))
-(defmacro bntb (destination) `((branch ,destination ntb)))
-(defmacro brtb (destination) `((rbranch ,destination tb)))
-(defmacro brntb (destination) `((rbranch ,destination ntb)))
-(defmacro btbx (destination) `((branchx ,destination tb)))
-(defmacro bntbx (destination) `((branchx ,destination ntb)))
-(defmacro brtbx (destination) `((rbranchx ,destination tb)))
-(defmacro brntbx (destination) `((rbranchx ,destination ntb)))
-
-(defmacro bc0 (destination) `((branch ,destination c0)))
-(defmacro bnc0 (destination) `((branch ,destination nc0)))
-(defmacro brc0 (destination) `((rbranch ,destination c0)))
-(defmacro brnc0 (destination) `((rbranch ,destination nc0)))
-(defmacro bc0x (destination) `((branchx ,destination c0)))
-(defmacro bnc0x (destination) `((branchx ,destination nc0)))
-(defmacro brc0x (destination) `((rbranchx ,destination c0)))
-(defmacro brnc0x (destination) `((rbranchx ,destination nc0)))
-
-;;; Lr loads register1 with the contents of register2.  Nicer looking than
-;;; cas r1,r2,0.
-
-(defmacro lr (register1 register2)
-  `((cas ,register1 ,register2 0)))
-
-;;; Loadi loads the specified Constant into the given Register.
-
-(defmacro loadi (register constant)
-  (let ((value (eval constant)))
-    (cond ((<= 0 value 15)
-	   `((lis ,register ,value)))
-	  ((<= -32768 value 32767)
-	   `((cal ,register 0 ,value)))
-	  ((= (logand value 65535) 0)
-	   `((cau ,register 0 (logand (ash ,value -16) #xFFFF))))
-	  (t
-	   `((cau ,register 0 (logand (ash ,value -16) #xFFFF))
-	     (oil ,register ,register (logand ,value 65535)))))))
-
-(defmacro cmpi (register constant)
-  (let ((value (eval constant)))
-    (cond ((<= 0 value 15)
-	   `((cis ,register ,value)))
-	  ((<= -32768 value 32767)
-	   `((ci 0 ,register ,value)))
-	  (T (clc-error "~A is to big for a compare immediate instruction."
-			value)))))
-
-(defmacro defmemref (name ds d shift)
-  `(defmacro ,name (register index-register &optional (offset 0))
-     (let ((value (eval offset)))
-       (cond ((and (eql (logand value (1- (ash 1 (abs ,shift)))) 0)
-		   (<= 0 (ash value ,shift) ,(if (eq name 'loadh) 0 15)))
-	      `((,',ds ,register ,index-register ,(ash value ,shift))))
-	     (t
-	      `((,',d ,register ,index-register ,value)))))))
-
-(defmemref loadc lcs lc 0)		; loads a character or byte
-(defmemref loadha lhas lha -1)		; loads a halfword, sign-extending
-(defmemref loadh lhs lh -1)		; loads a halfword, no sign extend.
-(defmemref loadw ls l -2)		; loads a fullword
-
-(defmemref storec stcs stc 0)		; stores a character or byte
-(defmemref storeha sths sth -1)		; stores a halfword
-(defmemref storew sts st -2)		; stores a fullword
-
-;;; (Mulitply Reg1 Reg2) multiplies the contents of Reg1 by Reg2 leaving the high order
-;;; result in Reg1 and the low order result in Reg2.  This macro could try and play
-;;; games, but to reduce the number of multiply steps, but it turns out that the extra
-;;; logic becomes pretty hariy, and you end up gaining a small amount.
-
-(defmacro multiply (Reg1 Reg2)
-  `((mtmq ,Reg1)
-    (s	,Reg1 ,Reg2)
-    (m	,Reg1 ,Reg2)
-    (m	,Reg1 ,Reg2)
-    (m	,Reg1 ,Reg2)
-    (m	,Reg1 ,Reg2)
-    (m	,Reg1 ,Reg2)
-    (m	,Reg1 ,Reg2)
-    (m	,Reg1 ,Reg2)
-    (m	,Reg1 ,Reg2)
-    (m	,Reg1 ,Reg2)
-    (m	,Reg1 ,Reg2)
-    (m	,Reg1 ,Reg2)
-    (m	,Reg1 ,Reg2)
-    (m	,Reg1 ,Reg2)
-    (m	,Reg1 ,Reg2)
-    (m	,Reg1 ,Reg2)
-    (m	,Reg1 ,Reg2)
-    (mfmq ,Reg2)))
-
-;;; More useful macros.
-
-(defmacro noop ()
-  `((cas NL0 NL0 NL0)))
-
-(defmacro pushm (reg)
-  `((inc cs 4)
-    (sts ,reg cs 0)))
-
-(defmacro popm (reg)
-  `((ls ,reg cs 0)
-    (dec cs 4)))
-
-(defmacro verify-type (reg type error &optional ignore-nil)
-  (let ((label (gensym "Label")))
-    (if (or (eq type 'type-+-fixnum) (eq type 'type-negative-fixnum))
-	`(,@(if (memq reg '(A0 A1))
-		`((srpi16 ,reg ,type-shift-16)
-		  (cmpi ,(if (eq reg 'A0) 'NL0 'NL1) ,type)
-		  (,(if (eq type 'type-+-fixnum) 'bgt 'blt) ,error))
-		`((lr NL0 ,reg)
-		  (sri16 NL0 ,type-shift-16)
-		  (cmpi NL0 ,type)
-		  (,(if (eq type 'type-+-fixnum) 'bgt 'blt) ,error))))
-	`(,@(if (and (eq type 'type-symbol) (null ignore-nil))
-		`((xiu NL0 ,reg nil-16)
-		  (beq ,label)))
-	  ,@(if (memq reg '(A0 A1))
-		`((srpi16 ,reg ,type-shift-16)
-		  (cmpi ,(if (eq reg 'A0) 'NL0 'NL1) ,type)
-		  (bne ,error))
-		`((niuz NL0 ,reg type-mask-16)
-		  (xiu NL0 NL0 (get-type-mask-16 ,type))
-		  (bne ,error)))
-	  ,@(if (and (eq type 'type-symbol) (null ignore-nil))
-		(list label))))))
-
-(defmacro verify-not-type (reg type error)
-  (if (or (eq type 'type-+-fixnum) (eq type 'type-negative-fixnum))
-      `(,@(if (memq reg '(A0 A1))
-	      `((srpi16 ,reg ,type-shift-16)
-		(cmpi ,(if (eq reg 'A0) 'NL0 'NL1) ,type)
-		(,(if (eq type 'type-+-fixnum) 'bgt 'blt) ,error))
-	      `((lr NL0 ,reg)
-		(sri16 NL0 ,type-shift-16)
-		(cmpi NL0 ,type)
-		(,(if (eq type 'type-+-fixnum) 'bgt 'blt) ,error))))
-      `(,@(if (memq reg '(A0 A1))
-	      `((srpi16 ,reg ,type-shift-16)
-		(cmpi ,(if (eq reg 'A0) 'NL0 'NL1) ,type)
-		(beq ,error))
-	      `((niuz NL0 ,reg type-mask-16)
-		(xiu NL0 NL0 (get-type-mask-16 ,type))
-		(beq ,error))))))
-
-(defmacro test-nil (reg label)
-  `((xiu NL0 ,reg nil-16)
-    (beq ,label)))
-
-(defmacro test-not-nil (reg label)
-  `((xiu NL0 ,reg nil-16)
-    (bne ,label)))
-
-(defmacro test-t (reg label)
-  `((xiu NL0 ,reg t-16)
-    (beq ,label)))
-
-(defmacro test-not-t (reg label)
-  `((xiu ro ,reg t-16)
-    (bne ,label)))
-
-(defmacro test-trap (reg label)
-  `((xiu NL0 ,reg trap-16)
-    (beq ,label)))
-
-(defmacro test-not-trap (reg label)
-  `((xiu NL0 ,reg trap-16)
-    (bne ,label)))
-
-(defmacro get-type (reg type-reg)
-  (cond ((and (eq reg 'A0) (eq type-reg 'NL0))
-	 `((srpi16 A0 type-shift-16)))
-	((and (eq reg 'A1) (eq type-reg 'NL1))
-	 `((srpi16 A1 type-shift-16)))
-	((and (eq reg 'A2) (eq type-reg 'A3))
-	 `((srpi16 A2 type-shift-16)))
-	(T `(,@(unless (eq reg type-reg)
-		 `((cas ,type-reg ,reg 0)))
-	     (sri16 ,type-reg type-shift-16)))))
-
-(defmacro type-equal (reg type label)
-  `((cmpi ,reg ,type)
-    ,(cond ((eq type 'type-+-fixnum)
-	    `(ble ,label))
-	   ((eq type 'type-negative-fixnum)
-	    `(bge ,label))
-	   (T `(beq ,label)))))
-
-(defmacro type-not-equal (reg type label)
-  `((cmpi ,reg ,type)
-    ,(cond ((eq type 'type-+-fixnum)
-	    `(bgt ,label))
-	   ((eq type 'type-negative-fixnum)
-	    `(blt ,label))
-	   (T `(bne ,label)))))
-
-(defmacro error0 (error-code)
-  `((bx error0)
-    (loadi a0 ,error-code)))
-
-(defmacro error1 (error-code reg)
-  `(,@(unless (eq reg 'a1)
-	`((cas a1 ,reg 0)))
-    (bx error1)
-    (loadi a0 ,error-code)))
-
-(defmacro error2 (error-code reg1 reg2)
-  `(,@(unless (eq reg2 'a2)
-	`((cas a2 ,reg2 0)))
-    ,@(unless (eq reg1 'a1)
-	`((cas a1 ,reg1 0)))
-    (bx error2)
-    (loadi a0 ,error-code)))
-
-;;; Floating Point support on the IBM RT PC.  The floating point support
-;;; provided assumes that there is hardware support for floating point.
-;;; This means the machine must have an FPA card, have an APC (which
-;;; has an MC68881 chip on board), or an AFPA card.
-
-;;; The macros defined below assume that there are only 7 floating point
-;;; registers available to Lisp miscops.  On the FPA's all register numbers
-;;; are shifted left one before being used, since the Mc68881 only has
-;;; 8 registers.  On the FPA the register 14 and 15 are not useable which
-;;; leaves 7 registers for Lisp.
-
-(float-register FR0 0)
-(float-register FR1 1)
-(float-register FR2 2)
-(float-register FR3 3)
-(float-register FR4 4)
-(float-register FR5 5)
-(float-register FR6 6)
-(float-register FR7 7)
-
-;;; Floatop generates code that checks (at runtime) the type of
-;;; floating point hardware available.  Shift-code is inserted between
-;;; the load of the hardware-type and the comparison.  Floatop then
-;;; branches to either the mc68881-code or the fpa-code.  The code for
-;;; each type of hardware should normally return to Lisp code.  However,
-;;; if the code should fall through, then the optional argument fall-through
-;;; should be passed a non-NIL value.
-
-(defmacro floatop (mc68881-code fpa-code &optional shift-code fall-through)
-  (let ((tag (gensym "LABEL"))
-	(tag2 (when fall-through (gensym "LABEL"))))
-    `((cau A3 0 romp-data-base)
-      (loadw A3 A3 floating-point-hardware-available)
-      ,@shift-code
-      (cmpi A3 float-mc68881)
-      (bne ,tag)
-      ,@mc68881-code
-      ,@(when fall-through `((b ,tag2)))
-      ,tag
-      ,@fpa-code
-      ,@(when fall-through `(,tag2)))))
-
-;;; Macros to support Floating point operations on the IBM RT PC.
-;;; The following code supports the FPA and AFPA.
-
-(defconstant read-float-register #x0BC)
-(defconstant read-status-register #x037)
-(defconstant write-float-register #x094)
-(defconstant write-status-register #x10F)
-(defconstant convert-float-long-to-float-short #x016)
-(defconstant convert-float-short-to-float-long #x01B)
-(defconstant negate-float-short #x055)
-(defconstant negate-float-long #x054)
-(defconstant absolute-float-short #x075)
-(defconstant absolute-float-long #x074)
-(defconstant copy-float-short #x045)
-(defconstant copy-float-long #x044)
-(defconstant compare-float-short #x049)
-(defconstant compare-float-long #x048)
-(defconstant divide-float-short #x061)
-(defconstant divide-float-long #x060)
-(defconstant multiply-float-short #x071)
-(defconstant multiply-float-long #x070)
-(defconstant subtract-float-short #x051)
-(defconstant subtract-float-long #x050)
-(defconstant add-float-short #x041)
-(defconstant add-float-long #x040)
-(defconstant round-float-long-to-word #x023)
-(defconstant truncate-float-long-to-word #x02B)
-(defconstant floor-float-long-to-word #x03B)
-(defconstant round-float-short-to-integer #x027)
-(defconstant truncate-float-short-to-integer #x02F)
-(defconstant floor-float-short-to-integer #x03F)
-(defconstant convert-float-short-immediate-to-float-long #x21B)
-(Defconstant convert-word-immediate-to-float-long #x203)
-(defconstant convert-word-immediate-to-float-short #x207)
-(defconstant compare-float-immediate-short #x249)
-(defconstant divide-float-immediate-short #x261)
-(defconstant divide-float-short-immediate #x161)
-(defconstant multiply-float-immediate-short #x271)
-(defconstant multiply-float-short-immediate #x171)
-(defconstant subtract-float-immediate-short #x251)
-(defconstant subtract-float-short-immediate #x151)
-(defconstant add-float-immediate-short #x241)
-(defconstant add-float-short-immediate #x141)
-(defconstant convert-float-long-immediate-to-float-short #x216)
-(defconstant compare-float-immediate-long #x248)
-(defconstant divide-float-immediate-long #x260)
-(defconstant divide-float-long-immediate #x160)
-(defconstant multiply-float-immediate-long #x270)
-(defconstant multiply-float-long-immediate #x170)
-(defconstant subtract-float-immediate-long #x250)
-(defconstant subtract-float-long-immediate #x150)
-(defconstant add-float-immediate-long #x240)
-(defconstant add-float-long-immediate #x140)
-(defconstant afpa-atanl #x0D4)
-(defconstant afpa-cosl #x0C2)
-(defconstant afpa-expl #x0D8)
-(defconstant afpa-log10l #x0DE)
-(defconstant afpa-logl #x0DC)
-(defconstant afpa-sinl #x0C0)
-(defconstant afpa-sqrs #x065)
-(defconstant afpa-sqrl #x064)
-(defconstant afpa-tanl #x0C4)
-
-(register float-status-register 14)
-
-;;; Check-For-Float-Errors checks to make sure a floating point operation
-;;; did not overflow or cause some other form of error.  The  argument
-;;; Error-Routine is the label to branch to if an error occurred.  There
-;;; is one routine for short, single, and long floating pointer errors
-;;; respectively.  The argument Reg is a general register to use in
-;;; the calculations.
-
-(defmacro fpa-check-for-float-error (underflow overflow reg &optional divide)
-  `((rdstr ,reg ,reg)			; get float status into register.
-    (nilz ,reg ,reg #x7)		; Clear useless bits.
-    (cmpi ,reg 1)			; Underflow ?
-    (beq ,underflow)			; Yes, go generate error.
-    (cmpi ,reg 2)			; Overflow ?
-    (beq ,overflow)			; Yes, go generate error.
-    ,@(if divide `((cmpi ,reg 3)	; Check for divide by 0.
-		   (beq ,divide)))))
-
-(defmacro invoke-fpa-float (opcode op1 op2 base
-			       &optional (data-reg 'NL0) (data-op 'storew))
-  (let* ((opcode (cond ((integerp opcode) opcode)
-		       ((symbolp opcode) (symbol-value opcode))
-		       (T (error "Illegal value: ~A." opcode))))
-	 (high-op (logior #xFF00 (logand (ash opcode -6) #xF)))
-	 (low-op (logior (ash (logand opcode #x3F) 10)
-			 (ash (eval-register op1) 6)
-			 (ash (eval-register op2) 2))))
-    (declare (fixnum high-op low-op))
-    (if (/= (logand low-op #x8000) 0)
-	(setq high-op (1+ high-op)))
-    `((cau ,base 0 ,high-op)
-      (,data-op ,data-reg ,base ,low-op))))
-
-(defmacro rdfr (gpr fpr &optional (base 'NL1))
-  `((invoke-fpa-float ,read-float-register ,fpr 0 ,base ,gpr loadw)))
-
-(defmacro rdstr (gpr &optional (base 'NL1))
-  `((invoke-fpa-float ,read-status-register float-status-register
-		  float-status-register ,base ,gpr loadw)))
-
-(defmacro wtfr (gpr fpr &optional (base 'NL1))
-  `((invoke-fpa-float ,write-float-register 0 ,fpr ,base ,gpr)))
-
-(defmacro wtstr (gpr &optional (base 'NL1))
-  `((invoke-fpa-float ,write-status-register float-status-register
-		  float-status-register ,base ,gpr)))
-
-(defmacro cisl (gr sfr lfr &optional (base 'NL1))
-  `((invoke-fpa-float ,convert-float-short-immediate-to-float-long
-		  ,sfr ,lfr ,base ,gr)))
-
-(defmacro csl (sfr lfr &optional (base 'NL1))
-  `((invoke-fpa-float ,convert-float-short-to-float-long ,sfr ,lfr ,base)))
-
-(defmacro cls  (lfr sfr &optional (base 'NL1))
-  `((invoke-fpa-float ,convert-float-long-to-float-short ,lfr ,sfr ,base)))
-
-(defmacro cils (gr lfr sfr &optional (base 'NL1))
-  `((invoke-fpa-float ,convert-float-long-immediate-to-float-short
-		  ,lfr ,sfr ,base ,gr)))
-
-(defmacro fixnum-to-short (ir sr &optional (base 'NL1))
-  `((invoke-fpa-float ,convert-word-immediate-to-float-short R0 ,sr ,base ,ir)))
-
-(defmacro fixnum-to-long (ir lr &optional (base 'NL1))
-  `((invoke-fpa-float ,convert-word-immediate-to-float-long R0 ,lr ,base ,ir)))
-
-(defmacro coms (fr1 fr2 &optional (base 'NL1))
-  `((invoke-fpa-float ,compare-float-short ,fr1 ,fr2 ,base)))
-
-(defmacro comis (gr fpr1 fpr2 &optional (base 'NL1))
-  `((invoke-fpa-float ,compare-float-immediate-short ,fpr1 ,fpr2 ,base ,gr)))
-
-(defmacro coml (fr1 fr2 &optional (base 'NL1))
-  `((invoke-fpa-float ,compare-float-long ,fr1 ,fr2 ,base)))
-
-(defmacro comil (gr fpr1 fpr2 &optional (base 'NL1))
-  `((invoke-fpa-float ,compare-float-immediate-long ,fpr1 ,fpr2 ,base ,gr)))
-
-(defmacro cops (fr1 fr2 &optional (base 'NL1))
-  `((invoke-fpa-float ,copy-float-short ,fr1 ,fr2 ,base)))
-
-(defmacro copl (fr1 fr2 &optional (base 'NL1))
-  `((invoke-fpa-float ,copy-float-long ,fr1 ,fr2 ,base)))
-
-(defmacro abss (fpr1 fpr2 &optional (base 'NL1))
-  `((invoke-fpa-float ,absolute-float-short ,fpr1 ,fpr2 ,base)))
-
-(defmacro absl (fpr1 fpr2 &optional (base 'NL1))
-  `((invoke-fpa-float ,absolute-float-long ,fpr1 ,fpr2 ,base)))
-
-(defmacro negs (fpr1 fpr2 &optional (base 'NL1))
-  `((invoke-fpa-float ,negate-float-short ,fpr1 ,fpr2 ,base)))
-
-(defmacro negl (fpr1 fpr2 &optional (base 'NL1))
-  `((invoke-fpa-float ,negate-float-long ,fpr1 ,fpr2 ,base)))
-
-(defmacro adds (fr1 fr2 &optional (base 'NL1))
-  `((invoke-fpa-float ,add-float-short ,fr1 ,fr2 ,base)))
-
-(defmacro addis (gr fr1 fr2 &optional (base 'NL1))
-  `((invoke-fpa-float ,add-float-immediate-short ,fr1 ,fr2 ,base ,gr)))
-
-(defmacro addsi (gr fr1 fr2 &optional (base 'NL1))
-  `((invoke-fpa-float ,add-float-short-immediate ,fr1 ,fr2 ,base ,gr)))
-
-(defmacro addl (fr1 fr2 &optional (base 'NL1))
-  `((invoke-fpa-float ,add-float-long ,fr1 ,fr2 ,base)))
-
-(defmacro addil (gr fr1 fr2 &optional (base 'NL1))
-  `((invoke-fpa-float ,add-float-immediate-long ,fr1 ,fr2 ,base ,gr)))
-
-(defmacro addli (gr fr1 fr2 &optional (base 'NL1))
-  `((invoke-fpa-float ,add-float-long-immediate ,fr1 ,fr2 ,base ,gr)))
-
-(defmacro subs (fr1 fr2 &optional (base 'NL1))
-  `((invoke-fpa-float ,subtract-float-short ,fr1 ,fr2 ,base)))
-
-(defmacro subis (gr fr1 fr2 &optional (base 'NL1))
-  `((invoke-fpa-float ,subtract-float-immediate-short ,fr1 ,fr2 ,base ,gr)))
-
-(defmacro subsi (gr fr1 fr2 &optional (base 'NL1))
-  `((invoke-fpa-float ,subtract-float-short-immediate ,fr1 ,fr2 ,base ,gr)))
-
-(defmacro subl (fr1 fr2 &optional (base 'NL1))
-  `((invoke-fpa-float ,subtract-float-long ,fr1 ,fr2 ,base)))
-
-(defmacro subil (gr fr1 fr2 &optional (base 'NL1))
-  `((invoke-fpa-float ,subtract-float-immediate-long ,fr1 ,fr2 ,base ,gr)))
-
-(defmacro subli (gr fr1 fr2 &optional (base 'NL1))
-  `((invoke-fpa-float ,subtract-float-long-immediate ,fr1 ,fr2 ,base ,gr)))
-
-(defmacro muls (fr1 fr2 &optional (base 'NL1))
-  `((invoke-fpa-float ,multiply-float-short ,fr1 ,fr2 ,base)))
-
-(defmacro mulis (gr fr1 fr2 &optional (base 'NL1))
-  `((invoke-fpa-float ,multiply-float-immediate-short ,fr1 ,fr2 ,base ,gr)))
-
-(defmacro mulsi (gr fr1 fr2 &optional (base 'NL1))
-  `((invoke-fpa-float ,multiply-float-short-immediate ,fr1 ,fr2 ,base ,gr)))
-
-(defmacro mull (fr1 fr2 &optional (base 'NL1))
-  `((invoke-fpa-float ,multiply-float-long ,fr1 ,fr2 ,base)))
-
-(defmacro mulil (gr fr1 fr2 &optional (base 'NL1))
-  `((invoke-fpa-float ,multiply-float-immediate-long ,fr1 ,fr2 ,base ,gr)))
-
-(defmacro mulli (gr fr1 fr2 &optional (base 'NL1))
-  `((invoke-fpa-float ,multiply-float-long-immediate ,fr1 ,fr2 ,base ,gr)))
-
-(defmacro divs (fr1 fr2 &optional (base 'NL1))
-  `((invoke-fpa-float ,divide-float-short ,fr1 ,fr2 ,base)))
-
-(defmacro divis (gr fr1 fr2 &optional (base 'NL1))
-  `((invoke-fpa-float ,divide-float-immediate-short ,fr1 ,fr2 ,base ,gr)))
-
-(defmacro divsi (gr fr1 fr2 &optional (base 'NL1))
-  `((invoke-fpa-float ,divide-float-short-immediate ,fr1 ,fr2 ,base ,gr)))
-
-(defmacro divl (fr1 fr2 &optional (base 'NL1))
-  `((invoke-fpa-float ,divide-float-long ,fr1 ,fr2 ,base)))
-
-(defmacro divil (gr fr1 fr2 &optional (base 'NL1))
-  `((invoke-fpa-float ,divide-float-immediate-long ,fr1 ,fr2 ,base ,gr)))
-
-(defmacro divli (gr fr1 fr2 &optional (base 'NL1))
-  `((invoke-fpa-float ,divide-float-long-immediate ,fr1 ,fr2 ,base ,gr)))
-
-(defmacro atanl (fr1 fr2 &optional (base 'NL1))
-  `((invoke-fpa-float ,afpa-atanl ,fr1 ,fr2 ,base)))
-
-(defmacro cosl (fr1 fr2 &optional (base 'NL1))
-  `((invoke-fpa-float ,afpa-cosl ,fr1 ,fr2 ,base)))
-
-(defmacro cosl (fr1 fr2 &optional (base 'NL1))
-  `((invoke-fpa-float ,afpa-cosl ,fr1 ,fr2 ,base)))
-
-(defmacro expl (fr1 fr2 &optional (base 'NL1))
-  `((invoke-fpa-float ,afpa-expl ,fr1 ,fr2 ,base)))
-
-(defmacro logl (fr1 fr2 &optional (base 'NL1))
-  `((invoke-fpa-float ,afpa-logl ,fr1 ,fr2 ,base)))
-
-(defmacro sinl (fr1 fr2 &optional (base 'NL1))
-  `((invoke-fpa-float ,afpa-sinl ,fr1 ,fr2 ,base)))
-
-(defmacro sqrs (fr1 fr2 &optional (base 'NL1))
-  `((invoke-fpa-float ,afpa-sqrs ,fr1 ,fr2 ,base)))
-
-(defmacro sqrl (fr1 fr2 &optional (base 'NL1))
-  `((invoke-fpa-float ,afpa-sqrl ,fr1 ,fr2 ,base)))
-
-(defmacro tanl (fr1 fr2 &optional (base 'NL1))
-  `((invoke-fpa-float ,afpa-tanl ,fr1 ,fr2 ,base)))
-
-;;; The following code is to support the MC6881 floating point chip on
-;;; the APC card.
-
-;;; MC68881 opcodes.
-
-(defconstant fop881-move #x00)
-(defconstant fop881-int #x01)
-(defconstant fop881-sinh #x02)
-(defconstant fop881-intrz #x03)
-(defconstant fop881-sqrt #x04)
-(defconstant fop881-lognp1 #x06)
-(defconstant fop881-etoxm1 #x08)
-(defconstant fop881-tanh #x09)
-(defconstant fop881-atan #x0A)
-(defconstant fop881-asin #x0C)
-(defconstant fop881-atanh #x0D)
-(defconstant fop881-sin #x0E)
-(defconstant fop881-tan #x0F)
-(defconstant fop881-etox #x10)
-(defconstant fop881-twotox #x11)
-(defconstant fop881-tentox #x12)
-(defconstant fop881-logn #x14)
-(defconstant fop881-log10 #x15)
-(defconstant fop881-log2 #x16)
-(defconstant fop881-abs #x18)
-(defconstant fop881-cosh #x19)
-(defconstant fop881-neg #x1A)
-(defconstant fop881-acos #x1C)
-(defconstant fop881-cos #x1D)
-(defconstant fop881-getexp #x1E)
-(defconstant fop881-getman #x1F)
-(defconstant fop881-div #x20)
-(defconstant fop881-mod #x21)
-(defconstant fop881-add #x22)
-(defconstant fop881-mul #x23)
-(defconstant fop881-sgldiv #x24)
-(defconstant fop881-rem #x25)
-(defconstant fop881-scale #x26)
-(defconstant fop881-sglmul #x27)
-(defconstant fop881-sub #x28)
-(defconstant fop881-sincos #x30)
-(defconstant fop881-cmp #x38)
-(defconstant fop881-tst #x3A)
-
-;;; Instruction classes.
-(defconstant f881-freg-to-freg 0)
-(defconstant f881-mem-to-freg 2)
-(defconstant f881-freg-to-mem 3)
-(defconstant f881-mem-to-scr 4)
-(defconstant f881-scr-to-mem 5)
-
-;;; When going to or from memory, have to specify type of the operand.
-(defconstant f881-mem-integer 0)	;; 32 bit integer.
-(defconstant f881-mem-single 1)		;; 32 bit float.
-(defconstant f881-mem-double 5)		;; 64 bit float.
-(defconstant f881-transfer-control-field-table
-  '#(0 #x3c0000 0 #x3c0000 0 #x3c0000 0 #x3c0000))
-
-;;; Control registers on the MC688881
-
-(defconstant f881-fpsr 2)
-(defconstant f881-fpcr 4)
-(defconstant f881-fpiar 1)
-
-
-(defmacro mc68881-check-for-error (under over opr baser &optional divide)
-  `((f881op ,f881-scr-to-mem ,f881-fpsr 0 ,fop881-move 1 ,opr ,baser)
-    (setcb 8)
-    (loadw NL0 ,baser 0)
-    (nilz ,opr NL0 #x800)
-    (bne ,under)
-    (nilz ,opr NL0 #x1000)
-    (bne ,over)
-    ,@(when divide
-	`((nilz ,opr NL0 #x400)
-	  (bne ,divide)))))
-
-(defmacro f881op (class src dst operation length &optional (opr 'A2) (dtr 'NL1))
-  (let* ((ecl (eval class))
-	 (opcode (logior #xFC000000
-			 (svref f881-transfer-control-field-table ecl)
-			 (ash ecl 15)
-			 (let ((r (eval-register src)))
-			   (unless r
-			     (setq r (eval src)))
-			   (ash r 12))
-			 (let ((r (eval-register dst)))
-			   (unless r
-			     (setq r (eval dst)))
-			   (ash r 9))
-			 (ash (eval operation) 2)
-			 length))
-	 (low (logand opcode #xFFFF))
-	 (high (+ (logand (ash opcode -16) #xFFFF)
-		  (if (eql (logand low #x8000) 0) 0 1))))
-    `((cau ,opr 0 ,high)
-      (storew ,dtr ,opr ,low))))
-
-;;; Assumes NL0 contains the (now) single floating point number.
-;;; Returns result in A0 as well as returning to caller.
-
-(defmacro short-monadic-f881op (op &optional (opr 'A2) (base 'NL1))
-  `((loadi ,base mc68881-float-temporary)
-    (storew NL0 ,base 0)
-    (f881op ,f881-mem-to-freg ,f881-mem-single FR0 ,(symbol-value op)
-	    1 ,opr ,base)
-    (f881op ,f881-freg-to-mem ,f881-mem-single FR0 ,fop881-move 1 ,opr ,base)
-    (setcb 8)
-    (loadw NL0 ,base 0)
-    (sri NL0 short-float-shift-16)
-    (brx PC)
-    (oiu A0 NL0 short-float-4bit-mask-16)))
-
-;;; Assumes A0 contains a pointer to a long floating point number.
-;;; Allocates storage to hold the result of the computation.
-
-(defmacro long-monadic-f881op (op &optional (opr 'A2) (base 'NL1))
-  `((cal ,base A0 long-float-high-data)
-    (f881op ,f881-mem-to-freg ,f881-mem-double FR0 ,(symbol-value op)
-	    2 ,opr ,base)
-    (allocate A0 type-long-float long-float-size ,base NL0)
-    (cal ,base A0 long-float-high-data)
-    (f881op ,f881-freg-to-mem ,f881-mem-double FR0 ,fop881-move 2 ,opr ,base)
-    (setcb 8)
-    (br PC)))
-
-;;; Assumes NL0 and NL1 contain the first and second number respectively.
-
-(defmacro short-dyadic-f881op (op type1 type2
-				  &optional (opr 'A2) (base 'A3) divide)
-  (let ((t1 (case type1
-	      (integer f881-mem-integer)
-	      (short-float f881-mem-single)
-	      (T type1)))
-	(t2 (case type2
-	      (integer f881-mem-integer)
-	      (short-float f881-mem-single)
-	      (T type2)))
-	(fr (if (float-register-p type1) type1 'FR6)))
-    `((loadi ,base ,mc68881-float-temporary)
-      (loadi ,opr 0)
-      (storew ,opr ,base 0)
-      (f881op ,f881-mem-to-scr ,f881-fpsr 0 ,fop881-move 1 ,opr ,base)
-      ,@(when (null (float-register-p type1))
-	  `((storew NL0 ,base 0)
-	    (f881op ,f881-mem-to-freg ,t1 ,fr ,fop881-move 1 ,opr ,base)))
-      ,@(if (null (float-register-p type2))
-	    `((storew NL1 ,base 4)
-	      (inc ,base 4)
-	      (f881op ,f881-mem-to-freg ,t2 ,fr ,(symbol-value op)
-		      1 ,opr ,base))
-	    `((f881op ,f881-freg-to-freg ,t2 ,fr ,(symbol-value op)
-			     0 ,opr ,base)))
-      (f881op ,f881-freg-to-mem ,f881-mem-single ,fr ,fop881-move 1 ,opr ,base)
-      (setcb 8)
-      (inc ,base 4)
-      (mc68881-check-for-error short-float-underflow short-float-overflow
-			       ,opr ,base ,divide)
-      (loadw NL0 ,base -4)
-      (sri NL0 short-float-shift-16)
-      (brx PC)
-      (oiu A0 NL0 short-float-4bit-mask-16))))
-
-;;; Assumes A0 contains the first number, and A1 the second.  Type1 and
-;;; type2 specify the type of the first and second number respectively.
-;;; Allocates storage to hold the result of the computation.
-
-(defmacro long-dyadic-f881op (op type1 type2
-				 &optional (opr 'A2) (base 'NL1) divide)
-  (let ((l1 (if (eq type1 'long-float) 2 1))
-	(l2 (if (eq type2 'long-float) 2 1))
-	(t1 (case type1
-	      (integer f881-mem-integer)
-	      (short-float f881-mem-single)
-	      (long-float f881-mem-double)
-	      (T type1)))
-	(t2 (case type2
-	      (integer f881-mem-integer)
-	      (short-float f881-mem-single)
-	      (long-float f881-mem-double)
-	      (T type2)))
-	(fr (if (float-register-p type1) type1 'FR6)))
-    `(,@(when (null (float-register-p type1))
-	  `(,@(case type1
-		(integer `((loadi ,base ,mc68881-float-temporary)
-			   (storew A0 ,base 0)))
-		(short-float `((loadi ,base ,mc68881-float-temporary)
-			       (slpi A0 short-float-shift-16)
-			       (storew NL0 ,base 0)))
-		(long-float `((cal ,base A0 long-float-high-data))))
-	      (f881op ,f881-mem-to-freg ,t1 ,fr ,fop881-move ,l1 ,opr ,base)))
-	,@(case type2
-	    (integer `((loadi ,base mc68881-float-temporary)
-		       (storew A1 ,base 4)
-		       (inc ,base 4)))
-	    (short-float `((loadi ,base mc68881-float-temporary)
-			   (lr NL0 A1)
-			   (sli NL0 short-float-shift-16)
-			   (storew NL0 ,base 4)
-			   (inc ,base 4)))
-	    (long-float `((cal ,base A1 long-float-high-data))))
-	,@(if (null (float-register-p type2))
-	      `((f881op ,f881-mem-to-freg ,t2 ,fr ,(symbol-value op)
-			,l2 ,opr ,base))
-	      `((f881op ,f881-freg-to-freg ,t2 ,fr ,(symbol-value op)
-			       0 ,opr ,base)))
-	(loadi ,base mc68881-float-temporary)
-	(mc68881-check-for-error long-float-underflow long-float-overflow
-				 ,opr ,base ,divide)
-	(allocate A0 type-long-float long-float-size ,base NL0)
-	(cal ,base A0 long-float-high-data)
-	(f881op ,f881-freg-to-mem ,f881-mem-double ,fr ,fop881-move
-		2 ,opr ,base)
-	(setcb 8)
-	(br PC))))
diff --git a/assembler/disassemble.lisp b/assembler/disassemble.lisp
deleted file mode 100644
index 720c5a4db0743b9c099c9ccfe4b7ad3935d96807..0000000000000000000000000000000000000000
--- a/assembler/disassemble.lisp
+++ /dev/null
@@ -1,368 +0,0 @@
-;;; -*- Mode: Lisp; Package: Compiler -*-
-
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; Spice Lisp is currently incomplete and under active development.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; The  DISASSEMBLE function as described in the Common Lisp manual.
-;;; 
-;;; Written by Don Mathis
-;;;
-;;;
-;;; Modified 11/83 by Robert Rose to put an asterisk before lines
-;;;  that are branched to.
-;;;
-;;; Heavily Modified 1/84 to use new instruction set.
-;;;
-;;; Modified by David B. McDonald to disassemble the Romp instruction
-;;; set.
-;;;
-;;; Hacked by Rob MacLachlan for the interim RT function format.  Hopefully
-;;; this file will die after the port.
-;;;
-;;; **********************************************************************
-;;;
-(in-package 'compiler :use '("LISP" "SYSTEM"))
-(export 'lisp::disassemble (find-package 'lisp))
-
-(proclaim '(special romp-4bit-opcode-symbol romp-8bit-opcode-symbol))
-
-;;;;   The Main function, DISASSEMBLE
-
-(defun disassemble (function &optional (*standard-output* *standard-output*))
-  "The argument should be either a function object, a lambda expression, or
-   a symbol with a function definition. If the relevant function is not a
-   compiled function, it is first compiled. In any case, the compiled code
-   is then 'reverse assembled' and printed out in a symbolic format."
-  (etypecase function
-    (function
-     (ecase (%primitive get-vector-subtype function)
-       ((#.%function-entry-subtype #.%function-closure-entry-subtype)
-	(prin-prelim-info function)
-	(Output-macro-instructions function (branch-list function)))
-       (#.%function-closure-subtype
-	(disassemble (%primitive header-ref function %function-name-slot)))))
-    (symbol
-     (disassemble (symbol-function function)))))
-
-
-
-;;;   PRIN-PRELIM-INFO takes a function object and extracts from it and
-;;; prints out the following information:
-;;;   - The argument list of the function.
-;;;   - The number of Locals allocated by the function.
-;;;   - Whether the function does or does not evaluate its arguments.
-
-(defun prin-prelim-info (function)
-  (format t "~%Disassembly of ~S.~%"
-	  (%primitive header-ref function %function-name-slot))
-  (format t "~%Its arg list is: ~A.~%"
-	  (%primitive header-ref function %function-entry-arglist-slot)))
-
-
-;;;   OUTPUT-MACRO-INSTRUCTIONS takes a function object and prints out the
-;;; corresponding macro. (Not executable macro, just macro that looks good!)
- 
-(defun Output-Macro-Instructions (function branches)
-  (declare (optimize (speed 3) (safety 0)))
-  (let* ((byte-vector
-	  (%primitive header-ref function %function-code-slot))
-	 (offset
-	  (- (%primitive header-ref function %function-offset-slot)
-	     i-vector-header-size))
-	 (vector-length (length byte-vector)))
-    (declare (fixnum vector-length))
-    (do ((i 0))
-	((= i vector-length))
-      (declare (fixnum i))
-      (when (= i offset)
-	(format t "~&*** Enter here:~%"))
-      (let* ((opcode (aref byte-vector i))
-	     (symbol (find-symbol-name opcode))
-	     (inst-type (get symbol 'romp-instruction-type)))
-	(case inst-type
-	  (ji (print-ji-instruction opcode byte-vector i branches)
-	      (setq i (the fixnum (+ i 2))))
-	  (x (print-x-instruction opcode byte-vector i branches)
-	     (setq i (the fixnum (+ i 2))))
-	  (ds (print-ds-instruction opcode byte-vector i branches function)
-	      (setq i (the fixnum (+ i 2))))
-	  (r (print-r-instruction opcode byte-vector i branches)
-	     (setq i (the fixnum (+ i 2))))
-	  (bi (print-bi-instruction opcode byte-vector i branches)
-	      (setq i (the fixnum (+ i 4))))
-	  (ba (print-ba-instruction opcode byte-vector i branches)
-	      (setq i (the fixnum  (+ i 4))))
-	  (d (setq i (the fixnum
-			  (+ i (the fixnum
-				    (print-d-instruction opcode byte-vector i
-							 branches function ))))))
-	  (T (error "Illegal instruction type: ~A for instruction ~A.~%"
-		    inst-type symbol)))))))
-
-
-(defun find-symbol-name (opcode)
-  (declare (fixnum opcode))
-  (let ((symbol (svref romp-4bit-opcode-symbol (logand (the fixnum (ash opcode -4)) #xFF))))
-    (if symbol
-	symbol
-	(svref romp-8bit-opcode-symbol opcode))))
-		  
-
-;;;   BRANCH-LIST is very much like output-macro-instructions,
-;;;   but instead of actually creating all the instructions it just
-;;;   creates the branch instruction labels.  A list of these labels
-;;;   is returned.
-
-
-(defun branch-list (function)
-  (let* ((byte-vector
-	  (%primitive header-ref function %function-code-slot))
-	 (vector-length (length byte-vector))
-	 (branches nil))
-    (declare (fixnum vector-length))
-    (do ((i 0))
-	((>= i vector-length))
-      (declare (fixnum i))
-      (let* ((opcode (aref byte-vector i))
-	     (symbol (find-symbol-name opcode))
-             (inst-type (get symbol 'romp-instruction-type)))
-	(case inst-type
-	  (ji (push (the fixnum (+ i (the fixnum (sign-extend-ji byte-vector i)))) branches)
-	      (setq i (the fixnum (+ i 2))))
-	  ((x ds r) (setq i (the fixnum (+ i 2))))
-	  (bi (push (the fixnum (+ i (the fixnum (sign-extend-bi byte-vector i)))) branches)
-	      (setq i (the fixnum (+ i 4))))
-	  ((ba d) (setq i (the fixnum (+ i 4))))
-	  (T (error "Unknown instruction type: ~A, for instruction ~A.~%"
-		    inst-type symbol)))))
-    branches))
-
-(defun print-ji-instruction (opcode byte-vector index branches)
-  (declare (fixnum opcode index))
-  (format t "~6D~A  (~A ~A ~A)~%"
-	  index (if (memq index branches) "*" " ")
-	  (if (= (logand opcode #x8) 0) "JNB" "JB")
-	  (romp-condition-code (+ 8 (logand opcode #x7)))
-	  `(**address** ,(the fixnum (+ index (the fixnum (sign-extend-ji byte-vector index)))))))
-
-(defun print-x-instruction (opcode byte-vector index branches)
-  (declare (fixnum opcode index))
-  (let* ((rega (get-register-name (logand opcode #xF)))
-	 (operand (aref byte-vector (the fixnum (1+ index))))
-	 (regb (get-register-name (logand (the fixnum (ash operand -4)) #xF)))
-	 (regc (get-register-name (logand operand #xF)))
-	 (star (if (memq index branches) "*" " ")))
-    (declare (fixnum operand))
-    (if (eq regc 'NL0)
-	(cond ((and (eq rega 'NL0) (eq regb 'NL0))
-	       (format t "~6D~A  (LR NL0 NL0)		; Padding for previous execute instruction.~%"
-		       index star))
-	      (T (format t "~6D~A  (LR ~A ~A)~%"
-			 index (if (memq index branches) "*" " ")
-			 rega regb)))
-	(format t "~6D~A  (CAS ~A ~A ~A)~%"
-		index (if (memq index branches) "*" " ")
-		rega regb regc))))
-
-(defun print-ds-instruction (opcode byte-vector index branches function)
-  (declare (fixnum opcode index))
-  (let* ((symbol (find-symbol-name opcode))
-	 (operand (aref byte-vector (the fixnum (1+ index))))
-	 (rega (get-register-name (logand (the fixnum (ash operand -4)) #xF)))
-	 (regb (get-register-name (logand operand #xF)))
-	 (offset (ash (logand opcode #xF) 2)))
-    (declare (fixnum offset operand))
-    (cond ((and (memq symbol '(ls sts))
-		(memq regb '(ENV CONT)))
-	   (print-special-access symbol rega regb offset function
-				 index branches))
-	  (T (format t "~6D~A  (~A ~A ~A ~A)~%"
-		     index (if (memq index branches) "*" " ")
-		     (symbol-name symbol)
-		     (get-register-name (logand (the fixnum (ash operand -4)) #xF))
-		     (get-register-name (logand operand #xF))
-		     (case symbol
-		       ((ls sts) (ash (logand opcode #xF) 2))
-		       ((lhs lhas sths) (ash (logand opcode #xF) 1))
-		       (T (logand opcode #xF))))))))
-
-(defun print-r-instruction (opcode byte-vector index branches)
-  (declare (fixnum index opcode))
-  (let* ((symbol (find-symbol-name opcode))
-	 (operand (aref byte-vector (the fixnum (1+ index))))
-	 (rega (logand (the fixnum (ash operand -4)) #xF))
-	 (regb (logand operand #xF)))
-    (declare (fixnum operand))
-    (cond ((memq symbol '(inc dec lis mftbil mftbiu mttbil mttbiu
-			      ais cis sis clrbl clrbu setbl setbu
-			      sari sari16 sri sri16 srpi srpi16
-			      sli sli16 slpi slpi16))
-	   (format t "~6D~A  (~A ~A ~A)~%"
-		   index (if (memq index branches) "*" " ")
-		   (symbol-name symbol)
-		   (get-register-name rega)
-		   regb))
-	  ((memq symbol '(bbr bbrx bnbr bnbrx))
-	   (format t "~6D~A  (~A ~A ~A)~%"
-		   index (if (memq index branches) "*" " ")
-		   (symbol-name symbol)
-		   (romp-condition-code rega)
-		   (get-register-name regb)))
-	  ((memq symbol '(mts mfs))
-	   (format t "~6D~A  (~A ~A ~A)~%"
-		   index (if (memq index branches) "*" " ")
-		   (symbol-name symbol)
-		   rega regb))
-	  ((memq symbol '(clrsb setsb))
-	   (format t "~6D~A  (~A ~A ~A)~%"
-		   index (if (memq index branches) "*" " ")
-		   (symbol-name symbol)
-		   rega regb))
-	  (T (format t "~6D~A  (~A ~A ~A)~%"
-		     index (if (memq index branches) "*" " ")
-		     (symbol-name symbol)
-		     (get-register-name rega)
-		     (get-register-name regb))))))
-
-(defun print-bi-instruction (opcode byte-vector index branches)
-  (declare (fixnum index opcode))
-  (let* ((symbol (find-symbol-name opcode))
-	 (cc (romp-condition-code
-	      (logand (ash (the fixnum (aref byte-vector (the fixnum (1+ index)))) -4) #xF)))
-	 (label (the fixnum (+ index (the fixnum (sign-extend-bi byte-vector index))))))
-    (format t "~6D~A  (~A ~A ~A)~%"
-	    index (if (memq index branches) "*" " ")
-	    (symbol-name symbol) cc `(**address** ,label))))
-
-(defun print-ba-instruction (opcode byte-vector index branches)
-  (declare (fixnum index opcode))
-  (let* ((symbol (find-symbol-name opcode))
-	 (operand (the fixnum (logior (ash (the fixnum (aref byte-vector (the fixnum (1+ index)))) 16)
-				      (ash (the fixnum (aref byte-vector (the fixnum (+ index 2)))) 8)
-				      (the fixnum (aref byte-vector (the fixnum (+ index 3)))))))
-	 (miscop (find-miscop-name operand)))
-    (format t "~6D~A  (~A ~A)		; Call miscop ~A.~%"
-	    index (if (memq index branches) "*" " ")
-	    (symbol-name symbol)
-	    miscop
-	    miscop))
-  4)
-
-(defun print-d-instruction (opcode byte-vector index branches function)
-  (declare (fixnum index opcode))
-  (let* ((symbol (find-symbol-name opcode))
-	 (operand (aref byte-vector (the fixnum (1+ index))))
-	 (rega (get-register-name (logand (the fixnum (ash operand -4)) #xF)))
-	 (regb (get-register-name (logand operand #xF)))
-	 (offset (sign-extend-d byte-vector index)))
-    (declare (fixnum offset operand))
-    (cond ((eq symbol 'ci)
-	   (format t"~6D~A  (~A ~A ~A)~%"
-		   index (if (memq index branches) "*" " ")
-		   (symbol-name symbol)
-		   rega offset)
-	   4)
-	  ((and (memq symbol '(l st))
-		(memq regb '(ENV CONT)))
-	   (print-special-access symbol rega regb offset function
-				 index branches)
-	   4)
-	  (T (format t "~6D~A  (~A ~A ~A ~A)~A~%"
-		     index (if (memq index branches) "*" " ")
-		     (symbol-name symbol)
-		     rega regb offset
-		     (if (eq (setq offset (logand offset #xFFFF)) nil-16)
-			 "		; NIL."
-			 (if (eq offset t-16)
-			     "		; T."
-			     "")))
-	     4))))
-
-
-(defun print-special-access (symbol rega regb offset function index branches)
-  (declare (fixnum index offset))
-  (let ((star (if (memq index branches) "*" " "))
-	(*print-level* 3)
-	(*print-length* 10))
-    (cond
-     ((not (eq regb 'ENV))
-      (format t "~6D~A  (~A ~A ~A ~A)		; Stack slot ~D.~%"
-	      index star (symbol-name symbol)
-	      rega regb offset
-	      (ash offset -2)))
-     ((= offset (ash %function-code-slot 2))
-      (format t "~6D~A  (~A ~A ~A ~A)		; Function code.~%"
-	      index star (symbol-name symbol)
-	      rega regb offset))
-     ((= offset (ash %function-offset-slot 2))
-      (format t "~6D~A  (~A ~A ~A ~A)		; Function offset.~%"
-	      index star (symbol-name symbol)
-	      rega regb offset))
-     (t
-      (format t "~6D~A  (~A ~A ~A ~A)		; Constant: ~S.~%"
-	      index star (symbol-name symbol)
-	      rega regb offset
-	      (%primitive header-ref
-			  (%primitive header-ref function
-				      %function-entry-constants-slot)
-			  (ash (the fixnum
-				    (- offset g-vector-header-size)) -2)))))))
-
-
-(defun sign-extend-ji (byte-vector index)
-  (declare (fixnum index))
-  (let ((byte (aref byte-vector (the fixnum (1+ index)))))
-    (declare (fixnum byte))
-    (ash (if (= (logand byte #x80) 0)
-	     byte
-	     (the fixnum (- (the fixnum (1+ (logand (lognot byte) #x7F))))))
-	 1)))
-
-(defun sign-extend-bi (byte-vector index)
-  (declare (fixnum index))
-  (let ((int (logior (the fixnum (ash (logand (the fixnum (aref byte-vector (the fixnum (1+ index)))) #xF) 16))
-		     (the fixnum (ash (aref byte-vector (the fixnum (+ index 2))) 8))
-		     (the fixnum (aref byte-vector (the fixnum (+ index 3)))))))
-    (declare (fixnum int))
-    (ash (if (= (logand int #x80000) 0)
-	     int
-	     (the fixnum (- (the fixnum (1+ (logand (lognot int) #x7FFFF))))))
-	 1)))
-
-(defun sign-extend-d (byte-vector index)
-  (declare (fixnum index))
-  (let ((hword (logior (the fixnum (ash (aref byte-vector (the fixnum (+ index 2))) 8))
-		       (the fixnum (aref byte-vector (the fixnum (+ index 3)))))))
-    (declare (fixnum hword))
-    (if (= (logand hword #x8000) 0)
-	hword
-	(the fixnum (- (the fixnum (1+ (logand (lognot hword) #xFFFF))))))))
-
-(defun romp-condition-code (cc)
-  (if (<= 8 cc 16)
-      (svref '#(pz lt eq gt cz reserved ov tb) (- cc 8))
-      '??))
-
-(defun get-register-name (reg)
-  (svref '#(NL0 A0 NL1 A1 A3 A2 SP L0 L1 L2 L3 L4 BS CONT ENV PC) reg))
-
-(defvar miscop-cache NIL)
-
-(defun find-miscop-name (index)
-  (if (null miscop-cache) (initialize-miscop-cache))
-  (gethash index miscop-cache))
-
-(defun initialize-miscop-cache ()
-  (setq miscop-cache (make-hash-table :size 500))
-  (do-symbols (x (find-package "CLC"))
-    (let ((v (get x 'lisp::%loaded-address)))
-      (when v
-	(setf (gethash v miscop-cache) x))))
-
-  (dolist (x lisp::*user-defined-miscops*)
-    (setf (gethash (get x 'lisp::%loaded-address) miscop-cache) x)))
diff --git a/assembler/miscasm.lisp b/assembler/miscasm.lisp
deleted file mode 100644
index 9ee8386afcd4ebe30140157bea7e32a0ad4ca13a..0000000000000000000000000000000000000000
--- a/assembler/miscasm.lisp
+++ /dev/null
@@ -1,44 +0,0 @@
-;;; -*- Mode: Lisp; Package: Compiler -*-
-
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; Spice Lisp is currently incomplete and under active development.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-
-(in-package 'compiler)
-
-(export '(asm asm-files) (find-package 'compiler))
-
-(defun asm (f)
-  (assemble-file (concatenate 'simple-string "nmiscops:" f ".romp")))
-
-(defun asm-files ()
-  (asm "abs")
-  (asm "allocation")
-  (asm "arith")
-  (asm "array")
-  (asm "byte")
-  (asm "call")
-  (asm "nlx")
-  (asm "compare")
-  (asm "divide")
-  (asm "gc")
-  (asm "gcd")
-  (asm "irrat")
-  (asm "list")
-  (asm "logic")
-  (asm "minus")
-  (asm "misc")
-  (asm "multiply")
-  (asm "negate")
-  (asm "plus")
-  (asm "print")
-  (asm "predicate")
-  (asm "save")
-  (asm "stack")
-  (asm "symbol")
-  (asm "system")
-  (asm "truncate"))
diff --git a/assembler/rompconst.lisp b/assembler/rompconst.lisp
deleted file mode 100644
index 6a1f782ec80eb4b6713e12c1518e94d58c186a44..0000000000000000000000000000000000000000
--- a/assembler/rompconst.lisp
+++ /dev/null
@@ -1,1087 +0,0 @@
-;;; -*- Mode: Lisp; Package: Compiler; Log: clc.log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; Spice Lisp is currently incomplete and under active development.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; Constants for the Romp.
-;;; Written by: David B. McDonald and Skef Wholey.
-;;;
-
-(in-package "COMPILER")
-
-
-;;; Utilities for hacking header objects.
-
-(defmacro load-slot (value object index)
-  `(loadw ,value ,object (ash (+ ,index g-vector-header-size-in-words) 2)))
-
-(defmacro store-slot (value object index)
-  `(storew ,value ,object (ash (+ ,index g-vector-header-size-in-words) 2)))
-
-
-;;; Pointer manipulation macros.
-
-(defmacro get-type-mask-16 (type)
-  `(ash ,type type-shift-16))
-
-(defmacro get-address-16 (type space)
-  `(logior (ash ,type type-shift-16)
-	   (ash ,space space-shift-16)))
-
-
-(defmacro romp-immed-fixnum-p (object)
-  `(let ((thing ,object))
-     (and (fixnump thing)
-	  (>= (the fixnum thing) (the fixnum romp-min-immed-number))
-	  (<= (the fixnum thing) (the fixnum romp-max-immed-number)))))
-
-(defmacro romp-short-fixnum-p (object)
-  `(let ((thing ,object))
-     (and (fixnump thing)
-	(>= (the fixnum thing) (the fixnum romp-min-short-immed-number))
-	(<= (the fixnum thing) (the fixnum romp-max-short-immed-number)))))
-
-(defmacro romp-fixnum-p (object)
-  `(let ((thing ,object))
-     (and (fixnump thing)
-	(>= (the fixnum thing) (the fixnum romp-min-fixnum))
-	(<= (the fixnum thing) (the fixnum romp-max-fixnum)))))
-
-
-;;; Registers are given a separate namespace from the constants.  Registers are
-;;; defined using the Register macro.  Constants can be defined using the Lisp
-;;; Defconstant.  Numbers may be used in place of registers.
-
-(defmacro register (name value)
-  `(setf (get ',name '%assembler-register) ,value))
-
-(defun registerp (name)
-  (and (symbolp name) (get name '%assembler-register)))
-
-(defmacro float-register (name value)
-  `(setf (get ',name '%assembler-float-register) ,value))
-
-(defun float-register-p (name)
-  (and (symbolp name) (get name '%assembler-float-register)))
-
-(defun eval-register (form)
-  (cond ((numberp form) form)
-	((symbolp form) (or (get form '%assembler-register)
-			    (get form '%assembler-float-register)))
-	(t (clc-error "~S can't be used as a register." form))))
-
-(defun translate-romp-type (register type label not-flag)
-  (case type
-    (+fixnum `((cmpi ,register type-+-fixnum)
-	       (,(get-branch-to-use label not-flag '+fixnum) ,label)))
-    (-fixnum `((cmpi ,register type-negative-fixnum)
-	       (,(get-branch-to-use label not-flag '-fixnum) ,label)))
-    (fixnum `((cmpi ,register type-+-fixnum)
-	      (,(get-branch-to-use label not-flag '+fixnum) ,label)
-	      (cmpi ,register type-negative-fixnum)
-	      (,(get-branch-to-use label not-flag '-fixnum) ,label)))
-    (bignum `((cmpi ,register type-bignum)
-	      (,(get-branch-to-use label not-flag) ,label)))
-    (ratio `((cmpi ,register type-ratio)
-	     (,(get-branch-to-use label not-flag) ,label)))
-    (+short-float `((cmpi ,register type-short-float-low)
-		    (,(get-branch-to-use label not-flag) ,label)))
-    (-short-float `((cmpi ,register type-short-float-high)
-		    (,(get-branch-to-use label not-flag) ,label)))
-    (short-float
-     (let ((tag (gensym "L")))
-       `((cmpi ,register type-short-float-low)
-	 (blt ,(if not-flag label tag))
-	 (cmpi ,register type-short-float-high)
-	 (,(if not-flag 'bgt 'ble) ,label)
-	 ,tag)))
-#|
-    (single-float `((cmpi ,register type-single-float)
-		    (,(get-branch-to-use label not-flag) ,label)))
-|#
-    (long-float `((cmpi ,register type-long-float)
-		  (,(get-branch-to-use label not-flag) ,label)))
-    (complex `((cmpi ,register type-complex)
-	       (,(get-branch-to-use label not-flag) ,label)))
-    (string `((cmpi ,register type-string)
-	      (,(get-branch-to-use label not-flag) ,label)))
-    (bit-vector `((cmpi ,register type-bit-vector)
-		  (,(get-branch-to-use label not-flag) ,label)))
-    (i-vector `((cmpi ,register type-i-vector)
-		      (,(get-branch-to-use label not-flag) ,label)))
-    (g-vector `((cmpi ,register type-g-vector)
-		      (,(get-branch-to-use label not-flag) ,label)))
-    (array `((cmpi ,register type-array)
-	     (,(get-branch-to-use label not-flag) ,label)))
-    (function `((cmpi ,register type-function)
-		(,(get-branch-to-use label not-flag) ,label)))
-    (symbol `((cmpi ,register type-symbol)
-	      (,(get-branch-to-use label not-flag) ,label)))
-    (list `((cmpi ,register type-list)
-	    (,(get-branch-to-use label not-flag) ,label)))
-    (control-stack-pointer `((cmpi ,register type-control-stack-pointer)
-			     (,(get-branch-to-use label not-flag) ,label)))
-    (binding-stack-pointer `((cmpi ,register type-binding-stack-pointer)
-			     (,(get-branch-to-use label not-flag) ,label)))
-    (gc-forward `((cmpi ,register type-gc-forward)
-		  (,(get-branch-to-use label not-flag) ,label)))
-    (string-char `((cmpi ,register type-string-char)
-		   (,(get-branch-to-use label not-flag) ,label)))
-    (trap `((cmpi ,register type-trap)
-	    (,(get-branch-to-use label not-flag) ,label)))
-    ((T))
-    (T (clc-error "Unknow type ~A to type-dispatch macro." type))))
-
-(defun get-branch-to-use (label not-flag &optional fixnum)
-  (cond ((eq label 'PC)
-	 (if (eq fixnum '+fixnum)
-	     (if not-flag 'brgt 'brle)
-	     (if (eq fixnum '-fixnum)
-		 (if not-flag 'brlt 'brge)
-		 (if not-flag 'brne 'breq))))
-	(T (if (eq fixnum '+fixnum)
-	       (if not-flag 'bgt 'ble)
-	       (if (eq fixnum '-fixnum)
-		   (if not-flag 'blt 'bge)
-		   (if not-flag 'bne 'beq))))))
-
-(defmacro type-dispatch (register &rest forms)
-    (do* ((form-list forms (cdr form-list))
-	  (form (car form-list) (car form-list))
-	  (label (gensym "L") (gensym))
-	  (type-code NIL)
-	  (clause-code NIL))
-	 ((null form-list)
-	  (append type-code clause-code))
-      (let ((types (cond ((listp (car form)) (car form))
-			 (t (list (car form)))))
-	    (label (if (and (cadr form) (atom (cadr form)))
-		       (cadr form) label))
-	    (not-flag (let ((next-form (cadr form-list)))
-			(cond ((and next-form
-				    (eq (car next-form) 'T)
-				    (cadr next-form)
-				    (atom (cadr next-form))
-				    (not (and (cadr form) (atom (cadr form)))))
-			       (setq form-list nil)
-			       (cadr next-form))))))
-	(if not-flag (setq label not-flag))
-	(dolist (x types)
-	  (setq type-code
-		(append type-code
-			(translate-romp-type register x label not-flag))))
-	(cond ((and (memq T types) (not (null (cdr form))) (atom (cadr form)))
-	       (setq type-code (append type-code `((b ,(cadr form))))))
-	      ((memq T types)
-	       (setq type-code
-		     (append type-code (cdr form)))
-	       (setq form-list nil))
-	      ((and (cdr form) (atom (cadr form))))
-	      ((null not-flag)
-	       (setq clause-code
-		     (append clause-code (list label) (cdr form))))
-	      (T (setq type-code (append type-code (cdr form))))))))
-
-(defmacro access-i-vector (vector index access-code)
-  (case access-code
-    ((0 1 2)
-     `((lr	NL1 ,index)
-       (sri	NL1 ,(case access-code (0 3) (1 2) (2 1)))
-       (cas	NL1 NL1 ,vector)
-       (loadc	NL0 NL1 i-vector-header-size)
-       (nilz	NL1 ,index ,(case access-code (0 #x7) (1 #x3) (2 #x1)))
-       (xil	NL1 NL1 ,(case access-code (0 #x7) (1 #x3) (2 #x1)))
-       ,@(case access-code (0 nil) (1 `((sli NL1 1))) (2 `((sli NL1 2))))
-       (sr	NL0 NL1)
-       (brx	PC)
-       (nilz	A0 NL0 ,(case access-code (0 #x1) (1 #x3) (2 #xF)))))
-    (3
-     `((cas	NL1 ,vector ,index)
-       (brx	PC)
-       (loadc	A0 NL1 i-vector-header-size)))
-    (4
-     `((sli	,index 1)
-       (cas	NL1 ,vector ,index)
-       (brx	PC)
-       (loadh	A0 NL1 i-vector-header-size)))
-    (5 (let* ((tag1 (gensym))
-	      (tag2 (gensym)))
-	 `((sli ,index 2)		; Get index to word.
-	   (cas NL1 ,vector ,index)
-	   (loadw NL0 NL1 i-vector-header-size) ; Pickup 32 bit quantity
-	   (srpi16 NL0 fixnum?-shift-16) ; Shift bits to a more useful place.
-	   (bne ,tag1)			; Not a fixnum, go create a bignum
-	   (brx PC)		 	; Return it as a fixnum.
-	   (cas A0 NL0 0)		; Put into return register.
-,tag1
-	   (xiu NL1 NL0 #x8000)		; 1 or 2 word bignum?
-
-	   (bnex ,tag2)
-	   (loadi A1 (+ bignum-header-size 8)) ; Assume two word.
-	   (noop)			; For execute.
-
-	   (loadi A1 (+ bignum-header-size 4)) ; A one word bignum.
-,tag2
-	   (allocate A0 type-bignum A1 A2 A3) ; Allocate a bignum.
-	   (storew NL0 A0 bignum-header-size) ; Store result in bignum.
-	   (sri A1 2)
-	   (brx PC)			; Return to caller.
-	   (storew A1 A0 0))))		; Store word count in bignum header.
-    (T (clc-error "Illegal access code (~A) in access-i-vector."
-		  access-code))))
-
-(defmacro store-i-vector (vector index access-code value)
-  (case access-code
-    ((0 1 2)
-     `((cas	NL1 ,index 0)
-       (sri	NL1 ,(case access-code (0 3) (1 2) (2 1)))
-       (cas	NL1 NL1 ,vector)
-       (loadc	NL0 NL1 i-vector-header-size)
-       (nilz	,index ,index ,(case access-code (0 #x7) (1 #x3) (2 #x1)))
-       (xil	,index ,index ,(case access-code (0 #x7) (1 #x3) (2 #x1)))
-       ,@(case access-code (0 nil) (1 `((sli ,index 1))) (2 `((sli ,index 2))))
-       (nilz	,value ,value ,(case access-code (0 #x1) (1 #x3) (2 #xF)))
-       (lr	A0 ,value)
-       (sl	,value ,index)
-       (lis	A3 ,(case access-code (0 #x1) (1 #x3) (2 #xF)))
-       (sl	A3 ,index)
-       (onec	A3 A3)
-       (n	NL0 A3)
-       (o	NL0 ,value)
-       (brx	PC)
-       (storec	NL0 NL1 i-vector-header-size)))
-    (3
-     `((cas	NL1 ,vector ,index)
-       (lr	A0 ,value)
-       (brx	PC)
-       (storec	,value NL1 i-vector-header-size)))
-    (4
-     `((sli	,index 1)
-       (cas	NL1 ,vector ,index)
-       (lr	A0 ,value)
-       (brx	PC)
-       (storeha ,value NL1 i-vector-header-size)))
-    (5 (let ((tag1 (gensym)))
-	 `((sli ,index 2)		; Get index to word.
-	   (cas NL1 ,index ,vector)
-	   (get-type ,value NL0)		; Get type of object.
-	   (cmpi NL0 type-bignum)	; Bignum?
-	   (beq ,tag1)	; Yes, go process it.
-	   (storew ,value NL1 i-vector-header-size) ; Assume fixnum and store it.
-	   (brx PC)			; Return to caller.
-	   (lr A0 ,value)		; Put into return register.
-,tag1
-	   (loadw NL0 ,value bignum-header-size) ; Pull out low order 32 bits.
-	   (storew NL0 NL1 i-vector-header-size) ; Store it into vector.
-	   (brx PC)
-	   (lr A0 ,value))))
-    (T (clc-error "Illegal access code (~A) in access-i-vector."
-		  access-code))))
-
-;;; The bit-bash-loop macro is used to generate code for the various operations
-;;; in the bit-bash misc-op.  It accepts a list of instructions, that should
-;;; only modify NL0 and NL1 leaving the result in NL0.
-
-(defmacro bit-bash-loop (operation-code)
-  (let ((loop-label (gensym "LABEL-"))
-	(done-label (gensym "LABEL-")))
-    `((lr	A3 NL0)
-      ,loop-label
-      (dec	A3 4)
-      (cmpi	A3 i-vector-header-size)
-      (blt	,done-label)
-      (cas	NL1 A0 A3)
-      (loadw	NL0 NL1 0)
-      (cas	NL1 A1 A3)
-      (loadw	NL1 NL1 0)
-      ,@operation-code
-      (cas	NL1 A2 A3)
-      (bx	,loop-label)
-      (storew	NL0 NL1 0)
-      ,done-label
-      (brx	PC)
-      (lr	A0 A2))))
-
-;;; Macro to call a conversion routine inside an arithmetic miscop.
-
-(defmacro call-conversion-routine (conversion-routine register)
-  `((inc CS 12)			; Make room on for A0, A1, PC.
-    (storew PC CS 0)		; Store PC
-    (storew A0 CS -4)		; Store A0.
-    ,@(unless (eq register 'A0) `((cas A0 ,register 0)))
-    
-    (mo-callx ,conversion-routine) ; Convert A0 to whatever.
-    (storew A1 CS -8)		; while saving A1.
-
-    (cas A2 A0 0)		; Get returned 
-    (loadw PC CS 0)		; Restore PC
-    (loadw A1 CS -8)		; Get A1 back.
-    (loadw A0 CS -4)		; Restore A0.
-    (dec CS 12)))		; Restore Stack pointer.
-
-(defmacro save-registers (&rest registers)
-  (let ((amount (ash (length registers) 2)))
-    (do* ((i 0 (1+ i))
-	  (reg-list registers (cdr reg-list))
-	  (register (car reg-list) (car reg-list))
-	  (inst-list NIL))
-	 ((null reg-list)
-	  `(,(if (< amount 16) `(inc CS ,amount) `(cal CS CS ,amount))
-	    ,@(nreverse inst-list)))
-      (push `(storew ,register CS ,(- (ash (1+ i) 2) amount)) inst-list))))
-
-(defmacro restore-registers (&rest registers)
-  (let ((amount (ash (length registers) 2)))
-    (do* ((i 0 (1+ i))
-	  (reg-list registers (cdr reg-list))
-	  (register (car reg-list) (car reg-list))
-	  (inst-list NIL))
-	 ((null reg-list)
-	  `(,@(nreverse inst-list)
-	    ,(if (< amount 16) `(dec CS ,amount) `(cal CS CS ,(- amount)))))
-      (push `(loadw ,register CS ,(- (ash (1+ i) 2) amount)) inst-list))))
-
-(defmacro save-registers-PC (&rest registers)
-  (let ((amount (+ (ash (length registers) 2) 8)))
-    (do* ((i 0 (1+ i))
-	  (reg-list registers (cdr reg-list))
-	  (register (car reg-list) (car reg-list))
-	  (inst-list NIL))
-	 ((null reg-list)
-	  `(,(if (< amount 16) `(inc CS ,amount) `(cal CS CS ,amount))
-	    ,@(nreverse inst-list)
-	    (stm AF CS -4)))
-      (push `(storew ,register CS ,(- (ash (1+ i) 2) amount)) inst-list))))
-
-(defmacro restore-registers-PC (&rest registers)
-  (let ((amount (+ (ash (length registers) 2) 8)))
-    (do* ((i 0 (1+ i))
-	  (reg-list registers (cdr reg-list))
-	  (register (car reg-list) (car reg-list))
-	  (inst-list NIL))
-	 ((null reg-list)
-	  `(,@(nreverse inst-list)
-	    (lm AF CS -4)
-	    (storew BS CS 0)			; Clobber return PC.
-	    ,(if (< amount 16) `(dec CS ,amount) `(cal CS CS ,(- amount)))))
-      (if register
-	  (push `(loadw ,register CS ,(- (ash (1+ i) 2) amount)) inst-list)))))
-
-(defmacro save-registers-internal-PC (&rest registers)
-  (let ((amount (+ (ash (length registers) 2) 4)))
-    (do* ((i 0 (1+ i))
-	  (reg-list registers (cdr reg-list))
-	  (register (car reg-list) (car reg-list))
-	  (inst-list NIL))
-	 ((null reg-list)
-	  `(,(if (< amount 16) `(inc CS ,amount) `(cal CS CS ,amount))
-	    ,@(nreverse inst-list)
-	    (storew PC CS 0)))
-      (push `(storew ,register CS ,(- (ash (1+ i) 2) amount)) inst-list))))
-
-(defmacro restore-registers-internal-PC (&rest registers)
-  (let ((amount (+ (ash (length registers) 2) 4)))
-    (do* ((i 0 (1+ i))
-	  (reg-list registers (cdr reg-list))
-	  (register (car reg-list) (car reg-list))
-	  (inst-list NIL))
-	 ((null reg-list)
-	  `(,@(nreverse inst-list)
-	    (loadw PC CS 0)
-	    ,(if (< amount 16) `(dec CS ,amount) `(cal CS CS ,(- amount)))))
-      (if register
-	  (push `(loadw ,register CS ,(- (ash (1+ i) 2) amount)) inst-list)))))
-
-;;; Macros to call misc-ops and internal assembler routines
-
-(defmacro mo-call (routine)
-  `((bali PC ,routine)))
-
-(defmacro mo-callx (routine)
-  `((balix PC ,routine)))
-
-(defmacro load-global-addr (register offset)
-  `((cau ,register 0 romp-data-base)
-    (oil ,register ,register ,offset)))
-
-(defmacro load-global (register offset &optional (base NIL base-defined))
-  (if (not base-defined) (setq base register))
-  `((cau ,base 0 romp-data-base)
-    (loadw ,register ,base ,offset)))
-
-(defmacro load-multiple-global (register offset
-					 &optional (base NIL base-defined))
-  (if (not base-defined) (setq base register))
-  `((cau ,base 0 romp-data-base)
-    (lm ,register ,base ,offset)))
-
-(defmacro store-global (register offset &optional (base 'NL1))
-  `((cau ,base 0 romp-data-base)
-    (storew ,register ,base ,offset)))
-
-(defmacro store-multiple-global (register offset &optional (base 'NL1))
-  `((cau ,base 0 romp-data-base)
-    (stm ,register ,base ,offset)))
-
-(defmacro load-symbol-addr (register offset)
-  `((cau ,register 0 (get-address-16 type-symbol static-space))
-    (oil ,register ,register ,offset)))
-
-(defmacro load-symbol-offset (register symbol-offset offset)
-  `((cau ,register 0 (get-address-16 type-symbol static-space))
-    (loadw ,register ,register (+ ,symbol-offset ,offset))))
-
-(defmacro store-symbol-offset (register symbol-offset offset &optional (base 'NL1))
-  `((cau ,base 0 (get-address-16 type-symbol static-space))
-    (storew ,register ,base (+ ,symbol-offset ,offset))))
-
-;;; Escape-Routine  --  Interface
-;;;
-;;;    Call the function that is the definition of the symbol at the specifed
-;;; offset, passing Nargs arguments.  The arguments should already be set up in
-;;; A0..A2.  The function must take no more than 3 arguments and return no more
-;;; than 3 values.  We make an "escape frame" and save the entire register set
-;;; in it.  If the called function returns, we restore the saved registers
-;;; *except* for A<N> and NL<N>.  This is so that we return the values returned
-;;; by the escape routine, rather than restoring whatever garbage was in the
-;;; argument registers before the call.  We only saved the arg registers for
-;;; the benefit of the debugger.
-;;;
-(defmacro escape-routine (symbol-offset nargs)
-  `((cal SP SP (* 4 %escape-frame-size)) ; Allocate frame
-    ;; Clear type bits in unboxed registers so that GC doesn't gag.  If these
-    ;; hold user fixnum or string-char variables, then this won't destroy the
-    ;; info.
-    (niuo NL0 NL0 clc::type-not-mask-16)
-    (niuo NL1 NL1 clc::type-not-mask-16)
-    ;; Save all registers...
-    (stm NL0 CS (* 4 (- (- %escape-frame-size
-			   %escape-frame-general-register-start-slot))))
-    ;; Save current CONT as OLD-CONT.
-    (storew CONT SP (* 4 (+ (- %escape-frame-size) c::old-cont-save-offset)))
-    ;; Compute escape frame start from SP.
-    (cal CONT SP (* 4 (- %escape-frame-size)))
-    ;; Store escape frame start in to register save area as old SP, since we
-    ;; trashed SP before saving registers.
-    (storew CONT CONT (* 4 (+ %escape-frame-general-register-start-slot
-			      c::sp-offset)))
-    ;; Zero ENV save area to indicate an escape frame.
-    (loadi NL1 0)
-    (storew NL1 CONT (* 4 c::env-save-offset))
-    ;; Save miscop return PC as PC escape frame is returning to.
-    (storew PC CONT (* 4 c::return-pc-save-offset))
-
-    ;; Get definition
-    (load-symbol-offset ENV ,symbol-offset symbol-definition)
-    ;; Get entry offset (in bytes, including header size).
-    (loadw PC ENV (+ g-vector-header-size (* 4 %function-offset-slot)))
-    ;; Get code vector.
-    (loadw NL1 ENV (+ g-vector-header-size (* 4 %function-code-slot)))
-    ;; Compute entry PC.
-    (cas PC PC NL1)
-    (lr OLD-CONT CONT) ; OLD-CONT gets escape frame.
-    (lr CONT SP) ; So escape frame doesn't get overwritten.
-    ;; Call, giving this miscop as return PC for escape frame.
-    (balrx PC PC)
-    (lis NARGS ,nargs) ; Load argument count
-    (noop)
-    (cal 0 0 0) ; 32bit noop for single-value return.
-    ;; Now restore all registers except for A<N> and NL<N>.
-    ;; CONT should be restored to the escape frame by returning function.
-    (lm SP CONT (* 4 (+ %escape-frame-general-register-start-slot
-			c::sp-offset)))
-    ;; Return to caller.
-    (br PC)))
-
-
-;;; The Allocate macro allocates a chunk of storage, frobing the free pointers
-;;; of the correct space and possibly invoking the garbage collector.  A newly
-;;; allocated object of the given Type and Length is left in the specified
-;;; Register.  The Length may be a constant or a register.
-
-;;; We take advantage of the fact that a GC will never happen during execution
-;;; of a miscop.  Things get significantly hairier if that is not true.
-
-(defmacro allocate (reg type length temp1 temp2)
-  `((load-symbol-offset ,temp1 current-allocation-space-offset symbol-value)
-    (oil ,temp1 ,temp1 (ash ,type 5))		; or in type
-    (cau ,temp1 ,temp1 alloc-table-address-16)	; add alloc-type address
-    (loadw ,reg ,temp1)				; fetch free pointer
-    ,@(if (registerp length)			; update free pointer
-	  `((cas ,temp2 ,length ,reg))
-	  `((cal ,temp2 ,reg ,length)))
-    (storew ,temp2 ,temp1)))			; write free pointer back to memory
-
-(defmacro static-allocate (reg type length temp1 temp2)
-  `((cau ,temp1 0 alloc-table-address-16)
-    (oil ,temp1 ,temp1 (+ (ash ,type 5) 16))
-    (loadw ,reg ,temp1)
-    ,@(if (registerp length)
-	  `((cas ,temp2 ,reg ,length))
-	  `((cal ,temp2 ,reg ,length)))
-    (storew ,temp2 ,temp1)))
-
-;;; Check-pc-for-interrupt checks to see if a miscops got interrupted
-;;; before it entered an interruptable state.
-
-(defmacro check-pc-for-interrupt ()
-  (let ((l (gensym)))
-    `((srpi16 PC type-shift-16)
-      (bne ,l)
-      (load-global PC interrupt-pc)
-      (cau L0 0 interrupted-16)
-      ,l)))
-
-(defmacro service-interrupt ()
-  `((xiu L0 L0 interrupted-16)
-    (brnex PC)
-    (cau L0 0 nil-16)
-    (store-global PC interrupt-pc NL1)
-    (load-global PC interrupt-routine)))
-
-;;; Various ranges for fixnums on the Romp.
-
-(eval-when (compile load eval)
-  (defconstant romp-code-base #x0020)
-  (defconstant romp-data-base #x0010)
-)
-
-(defconstant romp-min-immed-number (1- (- #x7fff)))
-(defconstant romp-max-immed-number #x7fff)
-
-(defconstant romp-min-short-immed-number 0)
-(defconstant romp-max-short-immed-number 15)
-
-(defconstant romp-max-fixnum #x7FFFFFF)
-(defconstant romp-min-fixnum (1- (- romp-max-fixnum)))
-
-(defconstant Page-Size 8192)
-(defconstant Page-Mask-16 #x1FFF)
-(defconstant Page-Not-Mask-16 #xE000)
-(defconstant Page-Shift-16 13)
-
-;;; Type codes:
-
-(eval-when (compile load eval)
-  (defconstant type-+-fixnum 0)
-  (defconstant type-gc-forward 1)
-  (defconstant type-trap 4)
-  (defconstant type-bignum 5)
-  (defconstant type-ratio 6)
-  (defconstant type-complex 7)
-  (defconstant type-+-short-float 8)
-  (defconstant type---short-float 9)
-  (defconstant type-double-float 10)
-  (defconstant type-long-float 10)
-  (defconstant type-string 11)
-  (defconstant type-bit-vector 12)
-  (defconstant type-i-vector 13)
-  (defconstant type-code-vector 14)
-  (defconstant type-g-vector 15)
-  (defconstant type-array 16)
-  (defconstant type-function 17)
-  (defconstant type-symbol 18)
-  (defconstant type-list 19)
-  (defconstant type-control-stack-pointer 20)
-  (defconstant type-binding-stack-pointer 21)
-  (defconstant type-assembler-code 0)
-
-
-  (defconstant type-short-float 8)
-  (defconstant type-short-float-low 8)
-  (defconstant type-short-float-high 9)
-
-  (defconstant type-string-char 26)
-  (defconstant type-bitsy-char 27)
-  (defconstant type-interruptable 28)
-
-  (defconstant type-negative-fixnum 31)
-
-  (defconstant first-pointer-type 4)
-  (defconstant last-pointer-type 19)
-  (defconstant first-lisp-pointer-type 4)
-  (defconstant last-lisp-pointer-type 21)
-)
-
-;;; Header sizes and offsets to access words in Lisp objects.
-
-(defconstant bignum-header-size 4)
-(defconstant bignum-header-size-in-words 1)
-(defconstant bignum-header-words 0)
-
-(defconstant ratio-numerator 0)
-(defconstant ratio-denominator 4)
-
-(defconstant float-header-size 4)
-(defconstant float-header-size-in-words 1)
-(defconstant long-float-size 12)
-#|
-(defconstant single-float-size 8)
-(defconstant single-float-data 4)
-|#
-(defconstant long-float-high-data 4)
-(defconstant long-float-low-data 8)
-(defconstant short-float-shift-16 4)
-(defconstant short-float-4bit-type #x4)
-(defconstant short-float-4bit-mask-16 #x4000)
-(defconstant float-compare-shift-16 9)
-(defconstant mc68881-compare-shift-16 10)
-(defconstant float-compare-mask-16 #x3)
-(defconstant mc68881-compare-mask-16 #x3)
-(defconstant float-compare-equal 1)
-
-(defconstant short-float-zero-16 #x4000)
-(defconstant single-float-one #x3F80)
-(defconstant long-float-one #x3FF0)
-(defconstant short-float-one
-  (logior (ash short-float-4bit-type (- 16 short-float-shift-16))
-	  (ash single-float-one (- short-float-shift-16))))
-(defconstant single-float-minus-one #xBF80)
-(defconstant long-float-minus-one #xBFF0)
-(defconstant short-float-minus-one
-  (logior (ash short-float-4bit-type (- 16 short-float-shift-16))
-	  (ash single-float-minus-one (- short-float-shift-16))))
-
-(defconstant complex-realpart 0)
-(defconstant complex-imagpart 4)
-(defconstant complex-size 8)
-
-(defconstant vector-subtype-byte 0)
-
-(defconstant string-header-size 8)
-(defconstant string-header-words 0)
-(defconstant string-header-entries 4)
-
-(defconstant bit-vector-header-size 8)
-(defconstant bit-vector-header-words 0)
-(defconstant bit-vector-header-entries 4)
-
-(defconstant i-vector-header-size 8)
-(defconstant i-vector-header-size-in-words 2)
-(defconstant i-vector-header-words 0)
-(defconstant i-vector-header-entries 4)
-(defconstant i-vector-access-byte 4)
-
-(defconstant iv-access-code-1 0)
-(defconstant iv-access-code-2 1)
-(defconstant iv-access-code-4 2)
-(defconstant iv-access-code-8 3)
-(defconstant iv-access-code-16 4)
-(defconstant iv-access-code-32 5)
-
-(defconstant g-vector-header-size 4)
-(defconstant g-vector-header-size-in-words 1)
-(defconstant g-vector-header-words 0)
-
-(defconstant array-header-size 20)
-(defconstant array-header-size-in-words 5)
-(defconstant array-header-words 0)
-(defconstant array-data-vector 4)
-(defconstant array-nelements 8)
-(defconstant array-fill-pointer 12)
-(defconstant array-displacement 16)
-
-(defconstant function-header-size 24)
-(defconstant function-header-size-in-words 6)
-(defconstant function-header-words 0)
-(defconstant function-nconstants 4)
-(defconstant function-code 8)
-(defconstant function-arginfo 12)
-(defconstant min-arg-count-mask-16 #xFF)
-(defconstant max-arg-count-mask-16 #xFF00)
-(defconstant max-arg-shift-16 8)
-(defconstant function-symbol 16)
-(defconstant function-arguments 20)
-
-(defconstant symbol-size 20)
-(defconstant symbol-value 0)
-(defconstant symbol-definition 4)
-(defconstant symbol-property-list 8)
-(defconstant symbol-print-name 12)
-(defconstant symbol-package 16)
-
-(defconstant cons-size 8)
-(defconstant list-size 8)
-(defconstant list-car 0)
-(defconstant list-cdr 4)
-
-(defconstant frame-size 36)
-(defconstant frame-size-in-words 9)
-(defconstant frame-saved-l0 0)
-(defconstant frame-saved-l1 4)
-(defconstant frame-saved-l2 8)
-(defconstant frame-saved-l3 12)
-(defconstant frame-saved-l4 16)
-(defconstant frame-binding-stack 20)
-(defconstant frame-active-frame 24)
-(defconstant frame-active-function 28)
-(defconstant frame-pc 32)
-
-(defconstant catch-frame-size 24)
-(defconstant catch-frame-size-in-words 6)
-(defconstant catch-binding-stack 0)
-(defconstant catch-active-frame 4)
-(defconstant catch-active-function 8)
-(defconstant catch-pc 12)
-(defconstant catch-tag-caught 16)
-(defconstant catch-prev-catch 20)
-
-(defconstant binding-symbol 4)
-(defconstant binding-value 0)
-
-;;; Structure for the link table.
-
-(defconstant lt-vector-size 5)
-(defconstant lt-access-code 5)
-(defconstant lt-nargs-ac 4)
-
-(defconstant lt-link-table-size 8192)
-(defconstant lt-log-table-size 13)
-(defconstant link-table-end-in-bytes
-  (+ i-vector-header-size (ash lt-link-table-size 3)))
-(defconstant lt-table-count 4)
-(defconstant lt-symbol-table 8)
-(defconstant lt-nargs-table 12)
-(defconstant lt-link-table 16)
-(defconstant lt-next-table 20)
-
-;;; Masks and shifts for various operations on the ROMP.
-
-(eval-when (compile load eval)
-  (defconstant type-mask-16 #xF800)
-  (defconstant type-not-mask-16 #x7FF)
-  (defconstant type-shift-16 11)
-
-  (defconstant space-mask-16 #x0600)
-  (defconstant space-shift-16 9)
-  (defconstant dynamic-space-mask-16 #x0200)
-)
-
-(defconstant space-mask-result-16 #x3)
-
-(defconstant dynamic-0-space 0)
-(defconstant dynamic-1-space 1)
-(defconstant static-space 2)
-(defconstant read-only-space 3)
-
-(defconstant nil-16 (get-address-16 type-list static-space))
-(defconstant t-16 (get-address-16 type-symbol static-space))
-(defconstant trap-16 (ash type-trap type-shift-16))
-
-(defconstant interruptable-16 (get-type-mask-16 type-interruptable))
-(defconstant interrupted-16 (+ (get-type-mask-16 type-interruptable) 1))
-
-(defconstant g-vector-words-mask-16 #x00FF)
-(defconstant right-shifted-subtype-mask-16 #x0007)
-(defconstant subtype-shift-16 8)
-(defconstant subtype-mask-16 #x0700)
-(defconstant g-vector-must-rehash #x0400)
-(defconstant i-vector-entries-mask-16 #x0FFF)
-(defconstant i-vector-words-mask-16 #x00FF)
-(defconstant access-code-shift-byte-16 4)
-(defconstant access-code-shift-word-16 12)
-
-(defconstant access-code-1-mask-16 #x0000)
-(defconstant access-code-2-mask-16 #x1000)
-(defconstant access-code-4-mask-16 #x2000)
-(defconstant access-code-8-mask-16 #x3000)
-(defconstant access-code-16-mask-16 #x4000)
-(defconstant access-code-32-mask-16 #x5000)
-
-(defconstant fixnum-mask-16 #xF800)
-(defconstant fixnum-not-mask-16 #x07FF)
-(defconstant fixnum-bits 28)
-(defconstant fixnum-sign-bit-16 4)
-(defconstant fixnum-shift-16 4)
-(defconstant fixnum?-shift-16 11)
-(defconstant most-negative-fixnum-16 #xF800)
-(defconstant smallest-+-bignum-16 #x0800)
-(defconstant smallest-positive-bignum-address-16
-  (get-address-16 type-bignum static-space))
-(defconstant least-negative-bignum-offset 8)
-
-;;; Define values for the boole operations.
-
-(defconstant boole-clr 0)
-(defconstant boole-set 1)
-(defconstant boole-1 2)
-(defconstant boole-2 3)
-(defconstant boole-c1 4)
-(defconstant boole-c2 5)
-(defconstant boole-and 6)
-(defconstant boole-ior 7)
-(defconstant boole-xor 8)
-(defconstant boole-eqv 9)
-(defconstant boole-nand 10)
-(defconstant boole-nor 11)
-(defconstant boole-andc1 12)
-(defconstant boole-andc2 13)
-(defconstant boole-orc1 14)
-(defconstant boole-orc2 15)
-
-;;; Register definitions.
-
-(register r0 0)
-(register r1 1)
-(register r2 2)
-(register r3 3)
-(register r4 4)
-(register r5 5)
-(register r6 6)
-(register r7 7)
-(register r8 8)
-(register r9 9)
-(register r10 10)
-(register r11 11)
-(register r12 12)
-(register r13 13)
-(register r14 14)
-(register r15 15)
-
-(register NArgs 0)		; Number of arguments to a function.
-(register nl0 0)		; Unboxed scratch
-(register a0 1)			; First argument and return value
-(register nl1 2)		; Unboxed scratch
-(register a1 3)			; Second argument
-(register t0 4)			; Boxed scratch
-(register a3 4)			; Fourth arg to some misc-ops.
-(register a2 5)			; Third argument
-(register cs 6)			; Control Stack Pointer (old name)
-(register sp 6)			; Stack pointer
-(register l0 7)			; Boxed Temporary
-(register l1 8)			; Boxed Temporary
-(register l2 9)			; Boxed Temporary
-(register name 9)		; Name of function we are trying to call
-(register l3 10)		; Boxed Temporary
-(register old-cont 10)		; Cont to return to
-(register l4 11)		; Boxed Temporary
-(register args 11)		; Pointer to stack arguments
-(register bs 12)		; Binding Stack Pointer
-(register fp 13)		; Active Frame Pointer (old name)
-(register cont 13)		; Current Cont
-(register af 14)		; Active Function Pointer (old name)
-(register env 14)		; Current constant pool, called function.
-(register pc 15)		; PC, Return PC for misc-ops, and
-(register st 15)		; Super Temporary (old name)
-(register t1 15)		; Boxed scratch
-
-;;; Floating point hardware types.
-
-(defconstant float-none 0)
-(defconstant float-fpa 2)
-(defconstant float-afpa 4)
-(defconstant float-mc68881 1)
-
-;;; Error codes.
-
-(defconstant error-not-list 1)
-(defconstant error-not-symbol 2)
-(defconstant error-object-not-number 3)
-(defconstant error-object-not-integer 4)
-(defconstant error-object-not-ratio 5)
-(defconstant error-object-not-complex 6)
-(defconstant error-object-not-vector 7)
-(defconstant error-object-not-simple-vector 8)
-(defconstant error-illegal-function 9)
-(defconstant error-object-not-header 10)
-(defconstant error-object-not-i-vector 11)
-(defconstant error-object-not-simple-bit-vector 12)
-(defconstant error-object-not-simple-string 13)
-(defconstant error-object-not-character 14)
-(defconstant error-not-control-stack-pointer 15)
-(defconstant error-not-binding-stack-pointer 16)
-(defconstant error-object-not-array 17)
-(defconstant error-object-not-non-negative-fixnum 18)
-(defconstant error-object-not-sap-pointer 19)
-(defconstant error-object-not-system-pointer 20)
-(defconstant error-object-not-float 21)
-(defconstant error-object-not-rational 22)
-(defconstant error-object-not-non-complex-number 23)
-
-(defconstant error-symbol-unbound 25)
-(defconstant error-symbol-undefined 26)
-(defconstant error-modify-nil 27)
-(defconstant error-modify-t 28)
-
-(defconstant error-bad-access-code 30)
-(defconstant error-bad-vector-length 31)
-(defconstant error-index-out-of-range 32)
-(defconstant error-illegal-index 33)
-(defconstant error-illegal-shrink-value 34)
-(defconstant error-not-a-shrink 35)
-(defconstant error-illegal-data-vector 36)
-(defconstant error-too-few-indices 37)
-(defconstant error-too-many-indices 38)
-
-(defconstant error-illegal-byte-specifier 40)
-(defconstant error-illegal-position-in-byte-spec 41)
-(defconstant error-illegal-size-in-byte-spec 42)
-(defconstant error-illegal-shift-count 43)
-(defconstant error-illegal-boole-operation 44)
-
-(defconstant error-wrong-number-args 50)
-
-(defconstant error-not-<= 55)
-
-(defconstant error-divide-by-zero 60)
-(defconstant error-unseen-throw-tag 61)
-(defconstant error-short-float-underflow 62)
-(defconstant error-short-float-overflow 63)
-#|
-(defconstant error-single-float-underflow 64)
-(defconstant error-single-float-overflow 65)
-|#
-(defconstant error-long-float-underflow 66)
-(defconstant error-long-float-overflow 67)
-(defconstant error-monadic-short-underflow 68)
-(defconstant error-monadic-short-overflow 69)
-(defconstant error-monadic-long-underflow 70)
-(defconstant error-monadic-long-overflow 71)
-
-(defconstant error-log-of-zero 72)
-
-(defconstant error-object-not-string-char 73)
-(defconstant error-object-not-short-float 74)
-(defconstant error-object-not-long-float 75)
-(defconstant error-object-not-fixnum 76)
-(defconstant error-object-not-cons 77)
-
-(defconstant error-invalid-exit 78)
-
-(defconstant error-odd-keyword-arguments 79)
-(defconstant error-unknown-keyword-argument 80)
-(defconstant error-object-not-type 81)
-(defconstant error-object-not-function-or-symbol 82)
-(defconstant error-not-= 83)
-
-
-;;; Addresses of memory blocks used by the assembler routines.
-
-(defconstant alloc-table-address-16 romp-data-base)
-(defconstant alloc-table-address (ash alloc-table-address-16 16))
-(defconstant mc68881-float-temporary (+ (ash romp-data-base 16) #x10000))
-(defconstant get-real-time (+ (ash romp-data-base 16) #x20000))
-(defconstant get-run-time (+ (ash romp-data-base 16) #x20008))
-(defconstant alloc-table-size 2048)
-
-(defconstant prime-table-offset	(+ alloc-table-size 0))
-(defconstant mo-nargs-nil-routine-addr (+ alloc-table-size 64))
-(defconstant mo-nargs-t-routine-addr (+ alloc-table-size 68))
-(defconstant check-nargs-t-addr (+ alloc-table-size 72))
-(defconstant current-catch-block (+ alloc-table-size 76))
-(defconstant space-address (+ alloc-table-size 80))
-(defconstant newspace-address (+ alloc-table-size 84))
-(defconstant gc-save-NL0 (+ alloc-table-size 88))
-(defconstant gc-save-NL1 (+ alloc-table-size 92))
-(defconstant gc-save-CS (+ alloc-table-size 96))
-(defconstant gc-save-BS (+ alloc-table-size 100))
-(defconstant mo-no-entry-routine-addr (+ alloc-table-size 104))
-(defconstant save-c-stack-pointer (+ alloc-table-size 108))
-(defconstant current-unwind-protect-block (+ alloc-table-size 112))
-(defconstant interrupt-signal (+ alloc-table-size 116))
-(defconstant interrupt-code (+ alloc-table-size 120))
-(defconstant interrupt-scp (+ alloc-table-size 124))
-(defconstant interrupt-pc (+ alloc-table-size 128))
-(defconstant interrupt-routine (+ alloc-table-size 132))
-(defconstant interrupt-reset-pc (+ alloc-table-size 136))
-(defconstant interrupt-old-r5 (+ alloc-table-size 140))
-(defconstant in-call-foreign (+ alloc-table-size 144))
-(defconstant in-cf-save-regs-ptr (+ alloc-table-size 148))
-(defconstant software-interrupt-offset (+ alloc-table-size 152))
-(defconstant floating-point-hardware-available (+ alloc-table-size 156))
-(defconstant bignum-cache-timestamp (+ alloc-table-size 160))
-(defconstant bignum-cache-hits (+ alloc-table-size 164))
-(defconstant bignum-cache-table (+ alloc-table-size 168))
-(defconstant bignum-cache-bignums (+ alloc-table-size 172))
-(defconstant get-time-buffer (+ alloc-table-size 300))
-
-;;; Define offsets from the begining of static symbol space for all the symbols
-;;; that the assembler code needs to know about.
-
-(defconstant %sp-t-offset 0)
-(defconstant %sp-internal-apply-offset 20)
-(defconstant %sp-internal-error-offset 40)
-(defconstant %sp-software-interrupt-handler-offset 60)
-(defconstant %sp-internal-throw-tag-offset 80)
-(defconstant %sp-initial-function-offset 100)
-(defconstant %link-table-header-offset 120)
-(defconstant current-allocation-space-offset 140)
-(defconstant %sp-bignum/fixnum 160)
-(defconstant %sp-bignum/bignum 180)
-(defconstant %sp-fixnum/bignum 200)
-(defconstant %sp-abs-ratio 220)
-(defconstant %sp-abs-complex 240)
-(defconstant %sp-negate-ratio 260)
-(defconstant %sp-negate-complex 280)
-(defconstant %sp-integer+ratio 300)
-(defconstant %sp-ratio+ratio 320)
-(defconstant %sp-complex+number 340)
-(defconstant %sp-number+complex 360)
-(defconstant %sp-complex+complex 380)
-(defconstant %sp-1+ratio 400)
-(defconstant %sp-1+complex 420)
-(defconstant %sp-integer-ratio 440)
-(defconstant %sp-ratio-integer 460)
-(defconstant %sp-ratio-ratio 480)
-(defconstant %sp-complex-number 500)
-(defconstant %sp-number-complex 520)
-(defconstant %sp-complex-complex 540)
-(defconstant %sp-1-ratio 560)
-(defconstant %sp-1-complex 580)
-(defconstant %sp-integer*ratio 600)
-(defconstant %sp-ratio*ratio 620)
-(defconstant %sp-number*complex 640)
-(defconstant %sp-complex*number 660)
-(defconstant %sp-complex*complex 680)
-(defconstant %sp-integer/ratio 700)
-(defconstant %sp-ratio/integer 720)
-(defconstant %sp-ratio/ratio 740)
-(defconstant %sp-number/complex 760)
-(defconstant %sp-complex/number 780)
-(defconstant %sp-complex/complex 800)
-(defconstant %sp-integer-truncate-ratio 820)
-(defconstant %sp-ratio-truncate-integer 840)
-(defconstant %sp-ratio-truncate-ratio 860)
-(defconstant %sp-number-truncate-complex 880)
-(defconstant %sp-complex-truncate-number 900)
-(defconstant %sp-complex-truncate-complex 920)
-(defconstant maybe-gc 940)
-(defconstant lisp-environment-list 960)
-(defconstant call-lisp-from-c 980)
-(defconstant lisp-command-line-list 1000)
-(defconstant *nameserverport*-offset 1020)
-(defconstant *ignore-floating-point-underflow*-offset 1040)
-(defconstant lisp::%sp-sin-rational 1060)
-(defconstant lisp::%sp-sin-short 1080)
-(defconstant lisp::%sp-sin-long 1100)
-(defconstant lisp::%sp-sin-complex 1120)
-(defconstant lisp::%sp-cos-rational 1140)
-(defconstant lisp::%sp-cos-short 1160)
-(defconstant lisp::%sp-cos-long 1180)
-(defconstant lisp::%sp-cos-complex 1200)
-(defconstant lisp::%sp-tan-rational 1220)
-(defconstant lisp::%sp-tan-short 1240)
-(defconstant lisp::%sp-tan-long 1260)
-(defconstant lisp::%sp-tan-complex 1280)
-(defconstant lisp::%sp-atan-rational 1300)
-(defconstant lisp::%sp-atan-short 1320)
-(defconstant lisp::%sp-atan-long 1340)
-(defconstant lisp::%sp-atan-complex 1360)
-(defconstant lisp::%sp-exp-rational 1380)
-(defconstant lisp::%sp-exp-short 1400)
-(defconstant lisp::%sp-exp-long 1420)
-(defconstant lisp::%sp-exp-complex 1440)
-(defconstant lisp::%sp-log-rational 1460)
-(defconstant lisp::%sp-log-short 1480)
-(defconstant lisp::%sp-log-long 1500)
-(defconstant lisp::%sp-log-complex 1520)
-(defconstant lisp::%sp-sqrt-rational 1540)
-(defconstant lisp::%sp-sqrt-short 1560)
-(defconstant lisp::%sp-sqrt-long 1580)
-(defconstant lisp::%sp-sqrt-complex 1600)
-(defconstant *eval-stack-top*-offset 1620)
diff --git a/assembler/ropdefs.lisp b/assembler/ropdefs.lisp
deleted file mode 100644
index 37bf970f136e0e9e2d7ac2eab70daf6badf95b7a..0000000000000000000000000000000000000000
--- a/assembler/ropdefs.lisp
+++ /dev/null
@@ -1,221 +0,0 @@
-;;; -*- Mode: Lisp; Package: Compiler -*-
-
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-
-;;; This file defines the instruction set for the Common Lisp Romp Assembler
-;;; used by the compiler.
-
-;;; Written by David B. McDonald.
-
-(in-package 'Compiler)
-
-(defvar romp-4bit-opcode-symbol (make-array 16))
-(defvar romp-8bit-opcode-symbol (make-array 256))
-
-;;; Define-Romp-Instruction defines a Romp instruction to the assembler.
-;;; It accepts three arguments:
-;;;	romp-instruction is a symbol whose pname is the name of a Romp instruction
-;;;	romp-inst-type specifies the underlying type of the Romp instruction.
-;;;		it must have one of the following values: JI, X, DS, R, BI, BA,
-;;;		or D.
-;;;	romp-code specifies the numeric op code for the instruction.
-
-
-(defmacro Define-Romp-Instruction (romp-instruction romp-inst-type romp-code)
-  `(progn (setf (get ',romp-instruction 'romp-instruction-type)
-		',romp-inst-type)
-	  (setf (get ',romp-instruction 'romp-operation-code)
-		,romp-code)
-	  ,(case romp-inst-type
-	     (ji
-	      `(setf (svref romp-4bit-opcode-symbol 0) ',romp-instruction))
-	     ((x ds)
-	      `(setf (svref romp-4bit-opcode-symbol ,romp-code) ',romp-instruction))
-	     ((r bi ba d)
-	      `(setf (svref romp-8bit-opcode-symbol ,romp-code) ',romp-instruction))
-	     (T
-	      (error "Illegal instruction type: ~A, for instruction ~A (~A).~%"
-		     romp-inst-type romp-instruction romp-code)))))
-
-;;; Define-Romp-Branch defines a Romp branch instruction to the assembler.  It
-;;; accepts three arguments:
-;;;     romp-branch is a symbol whose pname is the name of a branch instruction.
-;;;     romp-instruction is the underlying romp-instruction that should be used
-;;;             used to implement the branch instruction.
-;;;     condition-code specifies the bit of the condition code that should be
-;;;             be tested to implement the branch.
-
-(defmacro Define-Romp-Branch (romp-branch romp-instruction condition-code)
-  `(progn (setf (get ',romp-branch 'romp-branch-instruction)
-		',romp-instruction)
-	  (setf (get ',romp-branch 'romp-condition-code)
-		,condition-code)))
-
-;;; Define-Condition-Code associates the integer code for a particular condition
-;;; code bit with a symbol.  It accepts a symbol and a value.
-
-(defmacro Define-Condition-Code (condition-code value)
-  `(setf (get ',condition-code 'condition-code) ,value))
-
-;;; Storage Access Instructions.
-
-(define-romp-instruction lcs ds #x4)
-(define-romp-instruction lc d #xCE)
-(define-romp-instruction lhas ds #x5)
-(define-romp-instruction lha d #xCA)
-(define-romp-instruction lhs r #xEB)
-(define-romp-instruction lh d #xDA)
-(define-romp-instruction ls ds #x7)
-(define-romp-instruction l d #xCD)
-(define-romp-instruction lm d #xC9)
-(define-romp-instruction tsh d #xCF)
-(define-romp-instruction stcs ds #x1)
-(define-romp-instruction stc d #xDE)
-(define-romp-instruction sths ds #x2)
-(define-romp-instruction sth d #xDC)
-(define-romp-instruction sts ds #x3)
-(define-romp-instruction st d #xDD)
-(define-romp-instruction stm d #xD9)
-
-;;; Address Computation Instructions.
-
-(define-romp-instruction cal d #xC8)
-(define-romp-instruction cal16 d #xC2)
-(define-romp-instruction cau d #xD8)
-(define-romp-instruction cas x #x6)
-(define-romp-instruction ca16 r #xF3)
-(define-romp-instruction inc r #x91)
-(define-romp-instruction dec r #x93)
-(define-romp-instruction lis r #xA4)
-
-;;; Basic Romp Branch Instructions.
-
-(define-romp-instruction bala ba #x8A)
-(define-romp-instruction balax ba #x8B)
-(define-romp-instruction bali bi #x8C)
-(define-romp-instruction balix bi #x8D)
-(define-romp-instruction balr r #xEC)
-(define-romp-instruction balrx r #xED)
-(define-romp-instruction jb ji #x1)
-(define-romp-instruction bb bi #x8E)
-(define-romp-instruction bbx bi #x8F)
-(define-romp-instruction bbr r #xEE)
-(define-romp-instruction bbrx r #xEF)
-(define-romp-instruction jnb ji #x0)
-(define-romp-instruction bnb bi #x88)
-(define-romp-instruction bnbx bi #x89)
-(define-romp-instruction bnbr r #xE8)
-(define-romp-instruction bnbrx r #xE9)
-
-;;; Romp Trap Instrunctions.
-
-(define-romp-instruction ti d #xCC)
-(define-romp-instruction tgte r #xBD)
-(define-romp-instruction tlt r #xBE)
-
-;;; Romp Move and Insert Instructions.
-
-(define-romp-instruction mc03 r #xF9)
-(define-romp-instruction mc13 r #xFA)
-(define-romp-instruction mc23 r #xFB)
-(define-romp-instruction mc33 r #xFC)
-(define-romp-instruction mc30 r #xFD)
-(define-romp-instruction mc31 r #xFE)
-(define-romp-instruction mc32 r #xFF)
-(define-romp-instruction mftb r #xBC)
-(define-romp-instruction mftbil r #x9D)
-(define-romp-instruction mftbiu r #x9C)
-(define-romp-instruction mttb r #xBF)
-(define-romp-instruction mttbil r #x9F)
-(define-romp-instruction mttbiu r #x9E)
-
-;;; Romp Arithmetic Instructions.
-
-(define-romp-instruction a r #xE1)
-(define-romp-instruction ae r #xF1)
-(define-romp-instruction aei d #xD1)
-(define-romp-instruction ai d #xC1)
-(define-romp-instruction ais r #x90)
-(define-romp-instruction abs r #xE0)
-(define-romp-instruction onec r #xF4)
-(define-romp-instruction twoc r #xE4)
-(define-romp-instruction c r #xB4)
-(define-romp-instruction cis r #x94)
-(define-romp-instruction ci d #xD4)
-(define-romp-instruction cl r #xB3)
-(define-romp-instruction cli d #xD3)
-(define-romp-instruction exts r #xB1)
-(define-romp-instruction s r #xE2)
-(define-romp-instruction sf r #xB2)
-(define-romp-instruction se r #xF2)
-(define-romp-instruction sfi d #xD2)
-(define-romp-instruction sis r #x92)
-(define-romp-instruction d r #xB6)
-(define-romp-instruction m r #xE6)
-
-;;; Romp Logical Operations
-
-(define-romp-instruction clrbl r #x99)
-(define-romp-instruction clrbu r #x98)
-(define-romp-instruction setbl r #x9B)
-(define-romp-instruction setbu r #x9A)
-(define-romp-instruction n r #xE5)
-(define-romp-instruction nilz d #xC5)
-(define-romp-instruction nilo d #xC6)
-(define-romp-instruction niuz d #xD5)
-(define-romp-instruction niuo d #xD6)
-(define-romp-instruction o r #xE3)
-(define-romp-instruction oil d #xC4)
-(define-romp-instruction oiu d #xC3)
-(define-romp-instruction x r #xE7)
-(define-romp-instruction xil d #xC7)
-(define-romp-instruction xiu d #xD7)
-(define-romp-instruction clz r #xF5)
-
-;;; Romp Shift Instructions
-
-(define-romp-instruction sar r #xB0)
-(define-romp-instruction sari r #xA0)
-(define-romp-instruction sari16 r #xA1)
-(define-romp-instruction sr r #xB8)
-(define-romp-instruction sri r #xA8)
-(define-romp-instruction sri16 r #xA9)
-(define-romp-instruction srp r #xB9)
-(define-romp-instruction srpi r #xAC)
-(define-romp-instruction srpi16 r #xAD)
-(define-romp-instruction sl r #xBA)
-(define-romp-instruction sli r #xAA)
-(define-romp-instruction sli16 r #xAB)
-(define-romp-instruction slp r #xBB)
-(define-romp-instruction slpi r #xAE)
-(define-romp-instruction slpi16 r #xAF)
-
-;;; Romp System Control Instructions.
-
-(define-romp-instruction mts r #xB5)
-(define-romp-instruction mfs r #x96)
-(define-romp-instruction clrsb r #x95)
-(define-romp-instruction setsb r #x97)
-(define-romp-instruction lps d #xD0)
-(define-romp-instruction wait r #xF0)
-(define-romp-instruction svc d #xC0)
-
-;;; Romp Input/Output Instructions.
-
-(define-romp-instruction ior d #xCB)
-(define-romp-instruction iow d #xDB)
-
-;;; Define bit setting for examining condition codes.
-
-(define-condition-code pz 8)
-(define-condition-code lt 9)
-(define-condition-code eq 10)
-(define-condition-code gt 11)
-(define-condition-code cz 12)
-(define-condition-code ov 14)
-(define-condition-code tb 15)
diff --git a/code/alieneval.lisp b/code/alieneval.lisp
deleted file mode 100644
index e4837681e78f41ccd6ab26a6e97a2c7999166481..0000000000000000000000000000000000000000
--- a/code/alieneval.lisp
+++ /dev/null
@@ -1,1278 +0,0 @@
-;;; -*- Log: code.log; Package: Lisp -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    This file contains any the part of the Alien implementation that
-;;; is not part of the compiler.
-;;;
-(in-package 'lisp)
-(in-package 'system)
-(export '(*alien-eval-when* make-alien alien-type alien-size alien-address
-			    copy-alien dispose-alien defalien alien-value
-			    alien-bind defoperator alien-index alien-indirect
-			    bits bytes words long-words port perq-string
-			    boolean defenumeration enumeration
-			    system-area-pointer pointer alien alien-access
-			    alien-assign alien-sap define-alien-stack
-			    with-stack-alien null-terminated-string c-procedure
-			    unstructured))
-(in-package 'lisp)
-
-(defun concat-pnames* (name1 name2)
-  (if name1
-      (make-symbol (concatenate 'simple-string (symbol-name name1)
-				(symbol-name name2)))
-      name2))
-
-#-new-compiler
-(eval-when (compile)
-  (setq lisp::*bootstrap-defmacro* :both))
-
-;;; The number of bits corresponding to a change of 1 in the value of a SAP.
-;;;
-(defconstant alien-address-unit 8)
-
-;;; The address pointed to by the SAP in an alien is always a multiple of this
-;;; number of bits.
-;;;
-(defconstant alien-alignment 16)
-
-(defvar *alien-eval-when* '(compile load eval)
-  "This is a list of the times to eval Alien compiler info.")
-
-(defun %print-alien-value (s stream d)
-  (declare (ignore d))
-  (let ((offset (alien-value-offset s)))
-    (format stream
-	    "#<Alien value, Address = #x~X~:[+~D/8~;~*~], Size = ~D, Type = ~S>"
-	    (%primitive sap-int (alien-value-sap s)) (zerop offset) offset
-	    (alien-value-size s) (alien-value-type s))))
-
-(defun %print-alien-info (s stream d)
-  (declare (ignore s d))
-  (write-string "#<Alien-Info>" stream))
-
-
-;;;; Interpreter stubs for SAP functions:
-
-#+new-compiler (progn
-(defun sap-int (sap)
-  "Converts a System Area Pointer into an integer."
-  (sap-int sap))
-
-(defun int-sap (int)
-  "Converts an integer into a System Area Pointer."
-  (int-sap int))
-
-(defun sap-ref-8 (sap offset)
-  "Returns the 8-bit byte at Offset bytes from SAP."
-  (sap-ref-8 sap offset))
-
-(defun sap-ref-16 (sap offset)
-  "Returns the 16-bit word at Offset words from SAP."
-  (sap-ref-16 sap offset))
-
-(defun sap-ref-32 (sap offset)
-  "Returns the 32-bit dualword at Offset words from SAP."
-  (sap-ref-32 sap offset))
-
-(defun (setf sap-ref-8) (sap offset new-value)
-  (setf (sap-ref-8 sap offset) new-value))
-
-(defun (setf sap-ref-16) (sap offset new-value)
-  (setf (sap-ref-16 sap offset) new-value))
-
-(defun (setf sap-ref-32) (sap offset new-value)
-  (setf (sap-ref-32 sap offset) new-value))
-
-); #+New-Compiler
-
-
-;;;; Miscellaneous primitives:
-
-;;; Alien-Assign  --  Public
-;;;
-;;;    Just blt the bytes from one to the other...
-;;;
-(defun alien-assign (to-alien from-alien)
-  "Copy the data in From-Alien into To-Alien.  The two alien values
-  must be of the same size and type."
-  (declare (type alien-value to-alien from-alien))
-  (unless (equal (alien-value-type to-alien) (alien-value-type from-alien))
-    (error "Arguments to Alien-Assign are of different types:~%~S~%~S"
-	   to-alien from-alien))
-  (let ((size (alien-value-size to-alien))
-	(src-off (alien-value-offset from-alien))
-	(dst-off (alien-value-offset to-alien)))
-    (unless (= size (alien-value-size from-alien))
-      (error "Arguments to Alien-Assign are of different sizes:~%~S~%~S"
-	     to-alien from-alien))
-    (unless (zerop (logand size 7))
-      (error "Size of assigned Alien is not a byte multiple:~%~S"
-	     from-alien))
-    (unless (zerop (logand src-off 7))
-      (error "Alien is not byte aligned:~%~S" from-alien))
-    (unless (zerop (logand dst-off 7))
-      (error "Alien is not byte aligned:~%~S" to-alien))
-    (let ((dst-start (ash dst-off -3)))
-      (%primitive byte-blt (alien-value-sap from-alien) (ash src-off -3)
-		  (alien-value-sap to-alien) dst-start
-		  (+ dst-start (ash size -3))))
-    to-alien))
-
-
-;;; Alien-Type, Alien-Size, Alien-Address, Alien-SAP  --  Public
-;;;
-;;;    Return the corresponding fields out of the Alien-Value structure.
-;;; Convert the address back into rational form.
-;;;
-(defun alien-type (alien)
-  "Return the type of the Alien Value."
-  (check-type alien alien-value)
-  (alien-value-type alien))
-
-(defun alien-size (alien)
-  "Return the size in bits of the Alien." 
-  (check-type alien alien-value)
-  (alien-value-size alien))
-
-(defun alien-address (alien)
-  "Return the address of the data for Alien."
-  (check-type alien alien-value)
-  (+ (%primitive sap-int (alien-value-sap alien))
-     (/ (alien-value-offset alien) alien-address-unit)))
-
-(defun alien-sap (alien)
-  "Return the system-area-pointer which corresponds to Alien.  Signal an
-  error if the alien's address is not word-aligned."
-  (check-type alien alien-value)
-  (unless (zerop (alien-value-offset alien))
-    (error "Argument to Alien-SAP is not word-aligned:~%~S" alien))
-  (alien-value-sap alien))
-
-
-;;;; Interface macros:
-
-;;; Defalien  --  Public
-;;;
-;;;    Dump the right compiler info and code to create the value at
-;;; load-time.
-;;;
-(defmacro defalien (name type size &optional (address :static))
-  "defalien Name Type Size [address]
-  Define a global Alien variable with the specified Name, Type, Size and
-  Address.  If Address is not supplied allocate storage to hold it."
-  `(progn
-    (eval-when (load eval)
-      (defparameter ,name (make-alien ',type ,size ,address)))
-    (eval-when ,*alien-eval-when*
-      (setf (info variable alien-value ',name)
-	    (make-ct-a-val
-	     :type ',type
-	     :size ,size
-	     :offset ,(if (numberp address)
-			  (rem (* address alien-address-unit) alien-alignment)
-			  0)
-	     :sap `(alien-value-sap ,',name)
-	     :alien ',name)))))
-
-
-;;; Define-Alien-Stack  --  Public
-;;;
-;;;    Define some variables and a function to grow the stack.  Put good
-;;; stuff on the property list.
-;;;
-(defmacro define-alien-stack (name type size)
-  "Define-Stack-Alien Name Type Size
-  Defines a new alien stack for use with the With-Stack-Alien macro.
-  The aliens have the specifed Type and Size, and are static."
-  (let ((n-head (concat-pnames name '-alien-stack-head))
-	(n-current (concat-pnames name '-alien-stack))
-	(grow-fun (concat-pnames name '-grow-stack)))
-  `(progn
-    (eval-when ,*alien-eval-when*
-      (setf (info alien-stack info ',name)
-	    (make-stack-info :head ',n-head  :current ',n-current
-			     :grow ',grow-fun  :type ',type
-			     :size ,size)))
-    (defvar ,n-head ())
-    (defvar ,n-current ())
-    (defun ,grow-fun ()
-      (let ((new (list (make-alien ',type ,size :static))))
-	(setq ,n-head (nconc ,n-head new)  ,n-current new)
-	(car new))))))
-
-
-;;; Defoperator  --  Public
-;;;
-;;;    Make the Alien-Info for the compiler and the function for the
-;;; interpreter.
-;;;
-(defmacro defoperator ((name result-type) args body)
-  (do ((arg args (cdr arg))
-       (argnames ())
-       (arg-types ())
-       (n 0 (1+ n)))
-      ((null arg)
-       `(eval-when ,*alien-eval-when*
-	  (setf (info function alien-operator ',name)
-		(make-alien-info #'(lambda ,(nreverse argnames) ,body)
-				 ,(length args) ',arg-types ',result-type))
-	  (setf (info function source-transform ',name)
-		#'c::alien=>lisp-transform)
-	  (defun ,name (&rest dummy-arglist)
-	    (displace-operator-definition ',name dummy-arglist))))
-    (cond
-     ((symbolp (car arg))
-      (push (car arg) argnames))
-     (t
-      (push (cons n (cadar arg)) arg-types) 
-      (push (caar arg) argnames)))))
-
-#-new-compiler
-(eval-when (compile)
-  (setq lisp::*bootstrap-defmacro* nil))
-
-
-;;;; Alien allocation:
-
-(eval-when (compile)
-  (dolist (x '(system-space-start alien-allocation-end))
-    (remprop x 'lisp::%constant)))
-
-;;;    In order to improve memory locality static alien values are allocated
-;;; contiguously in a pre-validated area at the beginning of system space.  We
-;;; keep a free pointer to the next word we can allocate.
-;;;
-(defparameter system-space-start
-  (%primitive make-immediate-type 0 %static-alien-area)
-  "The address of the first statically allocated alien.")
-
-(defparameter alien-allocation-end
-  (%primitive make-immediate-type #x40000 %static-alien-area)
-  "The end of statically allocated aliens.")
-
-(defvar *current-alien-free-pointer* system-space-start
-  "The next word in system space for static alien allocation.")
-
-;;; Allocate-Static-Alien  --  Internal
-;;;
-;;;    Allocate enough storage to hold the specified number of bits
-;;; and return the address.
-;;;
-(defun allocate-static-alien (bits)
-  (declare (fixnum bits))
-  (let* ((alien *current-alien-free-pointer*)
-	 (bytes (logand (ash (the fixnum (+ bits 31)) -3) (lognot 3)))
-	 (new (%primitive sap+ *current-alien-free-pointer* bytes)))
-    (when (%primitive pointer> new alien-allocation-end)
-      (error "Not enough room to allocate a ~D bit alien." bits))
-    (setq *current-alien-free-pointer* new)
-    alien))
-
-
-;;; DO-VALIDATE  --  Internal Interface.
-;;;
-;;; Do a ValidateMemory on our kernel port and flame out if error.
-;;;
-;;; Hemlock and other code files use this, even though it is not exported from
-;;; a more appropriate package.
-;;;
-(defun do-validate (addr bytes mask)
-  (gr-call* mach::vm_allocate *task-self* addr bytes (if (eq mask -1) t NIL)))
-
-
-;;; Make-Alien  --  Public
-;;;
-;;;    Create an Alien value structure, validating memory to hold the data
-;;; if necessary.  We convert the rational address into a word address +
-;;; bit offset.
-;;;
-(defun make-alien (type size &optional (address :dynamic))
-  "Return an Alien value of the specified Type, whose size is Size bits.
-  Address is the word address of the value to create, if this is not
-  supplied then memory is allocated to contain the data."
-  (case address
-    (:dynamic
-     (setq address (do-validate 0 (ash size -3) -1)))
-    (:static
-     (setq address (allocate-static-alien size)))
-    (t
-     (if (not (integerp address))
-	 (setq address (%primitive sap-int address)))
-     (check-type address (rational 0))))
-  (check-type size (integer 0))
-  (if (numberp address)
-      (multiple-value-bind (base frac) (truncate address)
-	(let ((offset (* frac alien-address-unit)))
-	  (unless (integerp frac)
-	    (error "Address ~S does not fall on a bit position." address))
-	  (make-alien-value (%primitive int-sap base) offset size type)))
-      (make-alien-value address 0 size type)))
-
-
-;;; Copy-Alien  --  Public
-;;;
-;;;   Validate some memory and byte-blt the contents to it.  Since we just move
-;;; words we preserve a nonzero bit-offset when it might be desirable to
-;;; eliminate it, but that is more trouble than it is worth, since non-aligned
-;;; fields are probably rarely copied.
-;;;
-(defun copy-alien (alien)
-  "Copy the storage pointed to by Alien and return a new alien value that
-  describes it."
-  (check-type alien alien-value)
-  (let* ((offset (alien-value-offset alien))
-	 (length (alien-value-size alien))
-	 (bytes (ash (+ length offset 15) -3))
-	 (new (%primitive int-sap (do-validate 0 bytes -1))))
-    (%primitive byte-blt (alien-value-sap alien) (ash offset -3)
-		new 0 bytes)
-    (make-alien-value new offset length (alien-value-type alien))))
-
-
-;;; Dispose-Alien  --  Public
-;;;
-;;;    Invalidate the memory pointed to by unless it is a statically
-;;; allocated alien.
-;;;
-(defun dispose-alien (alien)
-  "Release the storage allocated for Alien."
-  (check-type alien alien-value)
-  (let ((address (alien-value-sap alien)))
-    (unless (not (or (%primitive pointer< address system-space-start)
-		     (%primitive pointer> address alien-allocation-end)))
-      (gr-call mach:vm_deallocate *task-self* address
-	       (logand #x-200 (ash (+ (alien-value-size alien) #xFFF) -3))))))
-
-
-;;;; Operator definition primitives:
-
-;;; Alien-Index  --  Public
-;;;
-;;;    Check that the selected field fits within the Alien, and add it
-;;; in if it does.
-;;;
-(defun alien-index (alien offset size)
-  "Return a new Alien value that is Offset bits within Alien, and is
-  Size bits long."
-  (check-type alien alien-value)
-  (check-type offset (integer 0))
-  (check-type size (integer 0))
-  (when (> (+ offset size) (alien-value-size alien))
-    (error "~S is too small to extract a ~A bit field at ~A."
-	   alien size offset))
-  (multiple-value-bind (words bits)
-		       (truncate (+ offset (alien-value-offset alien)) 8)
-    (make-alien-value
-     (%primitive int-sap (+ words (%primitive sap-int (alien-value-sap alien))))
-     bits
-     size
-     nil)))
-
-;;; Alien-Indirect  --  Public
-;;;
-;;;    Check that Alien is word-aligned and 32 bits long.  If it is, grab
-;;; the value.  Check that the value falls within the system area.  If
-;;; it does then make a new Alien-Value out of it.
-;;;
-(defun alien-indirect (alien size)
-  "Return a new Alien value that points to what the value of Alien points to
-  which is Size bits long."
-  (check-type alien alien-value)
-  (check-type size (integer 0))
-  (unless (= (alien-value-size alien) 32)
-    (error "~S is not thirty-two bits long." alien))
-  (unless (zerop (alien-value-offset alien))
-    (error "~S is not word aligned."))
-  (let* ((sap (alien-value-sap alien))
-	 (value (logior (ash (%primitive 16bit-system-ref sap 0) 16)
-			(%primitive 16bit-system-ref sap 1))))
-#|
-    (unless (<= system-space-start value most-positive-fixnum)
-      (error "The value of ~S, #x~X, does not point into system space."
-	     alien value))
-|#
-    (make-alien-value (%primitive int-sap value) 0 size nil)))
-
-
-;;; Bits, Bytes, Words, Long-Words  --  Public
-;;;
-;;;
-(macrolet ((frob (name n)
-	     `(progn
-		(proclaim '(inline ,name))
-		(defun ,name (n)
-		  (declare (type (integer 0 ,(truncate most-positive-fixnum n))
-				 n))
-		  (* n ,n)))))
-  (frob bits 1)
-  (frob bytes 8)
-  (frob words 16)
-  (frob long-words 32))
-
-
-;;;; General case versions of compiler internal functions:
-
-;;; %Alien-Indirect  --  Internal
-;;;
-;;;    Alien-Indirect is transformed into this.  Calls can take place at
-;;; run-time when the operation can't be proven safe at compile time.
-;;;
-(defun %alien-indirect (size sap offset exp)
-  (unless (eql size 32)
-    (error "Argument to Alien-Indirect is ~D bits, 32:~% ~S." size exp))
-  (unless (zerop (logand offset #x1F))
-    (error "Offset ~D to Alien-Indirect is not long-word-aligned:~% ~S."
-	   offset exp))
-  (%primitive sap-system-ref sap (ash offset -4)))
-
-
-;;; %Aligned-SAP  --  Internal
-;;;
-;;;    Various things transform into this when the alien is declared to be
-;;; aligned.  In this case, we absorb the offset into the SAP, and make the
-;;; bound offset 0.
-;;;
-(defun %aligned-sap (sap offset form)
-  (unless (zerop (logand offset #xF))
-    (error "Offset ~S was declared to be word aligned, but isn't:~% ~S"
-	   offset form))
-  (%primitive sap+ sap (ash offset -3)))
-
-#+new-compiler
-;;; Naturalize-Integer  --  Internal
-;;;
-;;;    Read a possibly signed integer somewhere.  For the 16 and 32 bit
-;;; cases we let the transform do the work, for random fields we do it
-;;; by hand.
-;;;
-(defun naturalize-integer (signed sap offset size form)
-  (multiple-value-bind (q r) (truncate offset 16)
-    (cond
-     ((> size 15)
-      (unless (zerop r)
-	(error "Offset ~D for ~D bit access is not word-aligned:~% ~S"
-	       offset size form))
-      (case size
-	(32
-	 (if signed
-	     (%primitive signed-32bit-system-ref sap (ash q 4))
-	     (%primitive unsigned-32bit-system-ref sap (ash q 4))))
-	(16
-	 (if signed
-	     (naturalize-integer t sap (ash q 4) 16 nil)
-	     (naturalize-integer nil sap (ash q 4) 16 nil)))
-	(t
-	 (error "Access of ~D bit integers is not supported." size))))
-     (t
-      (when (> (+ size r) 16)
-	(error "~D bit field at ~D offset crosses a word boundry:~% ~S"
-	       size offset form))
-      (if signed
-	  (let ((val (ldb (byte size (- 16 size r))
-			  (%primitive 16bit-system-ref sap q))))
-	    (if (logbitp val (1- size))
-		(logior val (ash -1 size))
-		val))
-	  (ldb (byte size (- 16 size r))
-	       (%primitive 16bit-system-ref sap q)))))))
-
-#+new-compiler
-;;; Deport-Integer  --  Internal
-;;;
-;;;    Like Naturalize-Integer, but writes an integer.
-;;;
-(defun deport-integer (signed sap offset size value form)
-  (declare (ignore signed))
-  (multiple-value-bind (q r) (truncate offset 16)
-    (declare (fixnum r))
-    (cond
-     ((> size 15)
-      (unless (zerop r)
-	(error "Offset ~D for ~D bit store is not word-aligned:~% ~S"
-	       offset size form))
-      (case size
-	(32
-	 (%primitive signed-32bit-system-set sap q value))
-	(16
-	 (%primitive 16bit-system-set sap q value))
-	(t
-	 (error "Storing of ~D bit integers is not supported:~% ~S"
-		size form))))
-     ((= size 8)
-      (setq q (ash q 1))
-      (when (= r 8)
-	(setq q (1+ q))
-	(setq r 0))
-      (when (/= r 0)
-	(error "8 bit field at ~D offset crosses a byte boundary:~% ~S"
-	       offset form))
-      (%primitive 8bit-system-set sap q value))
-     ((> size 7)
-      (when (> (+ size r) 16)
-	(error "~D bit field at ~D offset crosses a word boundry:~% ~S"
-	       size offset form))
-      (%primitive 16bit-system-set sap q
-		  (dpb value (byte size (- 16 size r))
-		       (%primitive 16bit-system-ref sap q))))
-     (T
-      (multiple-value-bind (nq nr) (truncate offset 8)
-	(when (> (+ size nr) 8)
-	  (error "~D bit field at ~D offset crosses a byte boundry:~% ~S"
-		 size offset form))
-	(%primitive 8bit-system-set sap nq
-		    (dpb value (byte size (- 8 size nr))
-			 (%primitive 8bit-system-ref sap nq)))))))
-  nil)
-
-
-;;; Naturalize and Deport Boolean  --  Internal
-;;;
-;;;    Handle the general case of boolean access.  The transforms
-;;; should pick off the normal cases.
-;;;
-#+new-compiler
-(defun naturalize-boolean (sap offset size form)
-  (declare (notinline naturalize-integer))
-  (not (zerop (naturalize-integer nil sap offset size form))))
-;;;
-#+new-compiler
-(defun deport-boolean (sap offset size value form)
-  (declare (notinline deport-integer))
-  (deport-integer nil sap offset size (if value 1 0) form)
-  nil)
-
-;;; Check<=, Check=  --  Internal
-;;;
-;;;    Interpreter stubs for functions normally open-coded.  Note that the
-;;; compiler will constant-fold these, possibly producing an error at compile
-;;; time.
-;;;
-(defun check<=  (x y) (check<= x y))
-(defun check= (x y)
-  #|
-  (check= x y)
-  |#
-  ;### Bootstrap hack:
-  (unless (and (fixnump x) (>= x 0)
-	       (fixnump y) (>= y 0)
-	       (= x y))
-    (error "Not ~S not = to ~S at compile time." x y)))
-
-
-;;;; Utility functions used by macros and special forms:
-
-;;; Check-Alien-Type  --  Internal
-;;;
-;;;    Check that Alien is of the specified Alien type, and give an
-;;; error if it is not. 
-;;;
-(defun check-alien-type (alien type)
-  (unless (alien-value-p alien)
-    (error "~S is not an Alien value." alien))
-  (unless (equal (alien-value-type alien) type)
-    (error "Wrong Alien type ~S, should have been of type ~S."
-	   (alien-value-type alien) type))
-  alien)
-
-
-;;; Assert-Alien-Type  --  Internal
-;;;
-;;;    Make a new Alien value having the specified type.
-;;;
-(defun assert-alien-type (alien type)
-  (unless (alien-value-p alien)
-    (error "~S is not an Alien value." alien))
-  (make-alien-value (alien-value-sap alien)
-		    (alien-value-offset alien)
-		    (alien-value-size alien)
-		    type))
-
-
-;;; Displace-Operator-Definition  --  Internal
-;;;
-;;;    To save space and load & compile time for defoperators, we don't
-;;; actually generate the function for the operator until it is called.
-;;; This results in a significant space savings at the cost of
-;;; always running the operator definition interpreted when called
-;;; that way.
-;;;
-(defun displace-operator-definition (name actual-args)
-  (let ((info (info function alien-operator name)))
-    (unless info
-      (error "Operator ~S has no Alien-Operator-Info property."))
-    (let ((num-args (alien-info-num-args info))
-	  (arg-types (alien-info-arg-types info)))
-      (do ((i 0 (1+ i))
-	   (args ())
-	   (binds ()))
-	  ((= i num-args)
-	   (let* ((args (nreverse args))
-		  (res (coerce `(lambda ,args
-				  (alien-bind ,(nreverse binds)
-				    (assert-alien-type
-				     ,(apply (alien-info-function info) args)
-				     ',(alien-info-result-type info))))
-			       'function)))
-	     (setf (symbol-function name) res)
-	     (apply res actual-args)))
-	(let ((type (assoc i arg-types))
-	      (sym (gensym)))
-	  (push sym args)
-	  (if type
-	      (push `(,sym ,sym ,(cdr type)) binds)))))))
-
-
-;;;; Alien access method definition:
-;;;
-;;;    We describe how to access and store at an Alien's address in
-;;; a way that permits the same code to be use both for the compiler
-;;; and the interpreter.  What we do is have experts that ask things
-;;; about the alien value and return a piece of code to do the access.
-;;;
-;;;
-(defvar *alien-access-table* (make-hash-table :test #'eq)
-  "Hashtable from lisp types to Alien access functions.")
-(defvar *alien-only-access-table* (make-hash-table :test #'eq)
-  "Hashtable from alien types to Alien access functions.")
-(defvar *alien-to-lisp-types* (make-hash-table :test #'eq)
-  "Hashtable we use to tell whether there is a unique lisp-type
-   for a given alien-type.")
-
-(defmacro mostcar (x)
-  `(if (listp ,x) (car ,x) ,x))
-
-
-;;; %Define-Alien-Access  --  Internal
-;;;
-(defun %define-alien-access (lisp-type atypes fun)
-  (dolist (type atypes)
-    (let ((res (gethash type *alien-to-lisp-types*)))
-      (cond ((not res)
-	     (setf (gethash type *alien-to-lisp-types*) lisp-type))
-	    ((eq res lisp-type))
-	    (t
-	     (setf (gethash type *alien-to-lisp-types*) '%conflict%))))
-
-    (setf (gethash type *alien-only-access-table*) fun)
-    (setf (gethash lisp-type *alien-access-table*) fun)))
-
-
-;;; Get-Alien-Access-Method  --  Internal
-;;;
-;;;    Returns the alien-access method corresponding to Alien-Type and
-;;; Lisp-Type or dies trying.
-;;;
-(defun get-alien-access-method (alien-type lisp-type)
-  (let* ((alien-type (mostcar alien-type))
-	 (lisp-type (mostcar lisp-type))
-	 (unique? (gethash alien-type *alien-to-lisp-types*)))
-    (cond
-     ((not unique?)
-      (error "Alien type ~S does not correspond to any Lisp type." alien-type))
-     ((and (null lisp-type)
-	   (not (eq unique? '%conflict%))
-	   (gethash alien-type *alien-only-access-table*)))
-     ((not (eq unique? '%conflict%))
-      (gethash unique? *alien-access-table*))
-     ((not lisp-type)
-      (error "Lisp-Type must be specified with Alien type ~S." alien-type))
-     ((gethash lisp-type *alien-access-table*))
-     (t
-      (error "~S is not a Lisp-Type known to Alien-Access."
-	     lisp-type)))))
-
-
-;;; Define-Alien-Access  --  Internal
-;;;
-(defmacro define-alien-access ((lisp-type &optional (atype lisp-type)
-					  &rest more-types)
-			       (alien-var kind-var value-var
-					  &optional
-					  (source-var (gensym) source-p))
-			       &body body)
-  "Define-Alien-Access (Lisp-Type {Alien-Type}*) (Alien-Var Kind-Var Value-Var)
-		       {form}*
-
-  Define a new type for Alien-Access.  When Alien-Access is given the specified
-  Lisp-Type and the alien is one of the specified Alien-Types, then body will
-  be evaluated to get an expression that does the the appropriate access/store.
-  If no Alien-Type is supplied, then the accepted Alien type is Lisp-Type.  If
-  the type of the Alien is a list, then we use the car as the type.
-
-  Alien-Var
-      Bound to the Alien type of the Alien value to access.
-
-  Kind-Var
-      Bound to :read or :write, indicating whether to read or store a value.
-
-  Value-Var
-      When Kind-Var is :write, this is bound to an expression to evaluate to
-      obtain the value to be stored.
-
-  Source-Var
-      If specified, this is bound to the original Alien-Access form
-      (for use in error messages.)
-
-  In order to obtain the Alien value at which the access is to be done, the
-  local With-Alien macro should be used:
-
-  With-Alien (Sap-Var) (Offset-Var {Key Value}*) (Size-Var {Key Value}*)
-              {Form}*
-  This macro is for use within the body of a Define-Alien-Access.  It
-  analyzes and verifies assertions on the alien value to be accessed.
-  Sap-Var, Offset-Var and Size-Var are bound to expressions for the
-  system-area-pointer to the value, the offset from it in bits and
-  the size of the Alien in bits.
-
-  The keyword arguments for the offset and size may be used to place
-  constraints on the values they may assume.  If the value
-  is Nil, that is taken to be a null constraint.  The following
-  keys are defined:
-   :unit      -- A integer (default 16).
-		 Asserts that the value is a multiple of this number, and
-		 that the value is to be divided by this number before any
-		 other options are processed.
-   :constant  -- An integer (default Nil).
-		 Asserts that the value must be exactly the supplied value.
-   :minimum   -- An integer (default Nil).
-		 Asserts that the value may not be less than the supplied
-		 value.
-
-  The value of With-Alien is the value of the last form."
-
-  (let ((n-sap (gensym))
-	(n-offset (gensym))
-	(n-size (gensym)))
-    `(%define-alien-access
-      ',lisp-type '(,atype ,@more-types)
-      #'(lambda (,n-sap ,n-offset ,n-size ,alien-var ,kind-var ,value-var
-			,source-var)
-	  ,@(unless source-p
-	     `((declare (ignore ,source-var))))
-
-	  (unless (memq (mostcar ,alien-var) '(,atype ,@more-types))
-	    (error "Wrong Alien type ~S, should have been ~S~
-	            ~{~#[~; or~:;,~] ~S~}."
-		   ,alien-var ',atype ',more-types))
-	  
-	  (macrolet ((with-alien ((sap)
-				  (offset &key
-					  ((:unit ounit) 16))
-				  (size &key
-					((:constant sconst) nil)
-					((:minimum smin) nil)
-					((:unit sunit) 16))
-				  &body (body decls))
-		       (%with-alien sap offset ounit
-				    size sconst smin sunit
-				    ',n-sap ',n-offset ',n-size
-				    body decls)))
-	    ,@body)))))
-
-
-(eval-when (compile load eval)
-
-(defun %with-alien (sap offset ounit size sconst smin sunit
-			n-sap n-offset n-size body decls)
-  (let ((sunit (or sunit 1))
-	(ounit (or ounit 1))
-	(n-scaled-offset (gensym))
-	(n-scaled-size (gensym)))
-    `(let ((,sap ,n-sap)
-	   (,offset ',n-scaled-offset)
-	   (,size ',n-scaled-size))
-       ,@decls
-       `(let ((,',n-scaled-offset (/ ,,n-offset ,,ounit))
-	      (,',n-scaled-size (/ ,,n-size ,,sunit)))
-	  ,',n-scaled-size ; Ignorable...
-	  ,@',(when sconst
-		`((check= ,n-scaled-size ,sconst)))
-	  ,@',(when smin
-		`((check<= ,smin ,n-scaled-size)))
-	  ,,@body))))
-
-); Eval-When (Compile Load Eval)
-
-
-;;; Alien-Access  --  Public
-;;;
-;;;    This is only called when we can't open-code because the types aren't
-;;; constant (or are erroneous.)  In this case, we must look up the access
-;;; method at run-time, compute the access form, then eval it.
-;;;
-(defun alien-access (alien &optional lisp-type)
-  "Converts the bits described by Alien into an object of type Lisp-Type,
-  or dies trying."
-  (declare (type alien-value alien))
-  (let* ((alien-type (alien-value-type alien))
-	 (access (get-alien-access-method alien-type lisp-type))
-	 (n-sap (gensym))
-	 (n-offset (gensym))
-	 (n-size (gensym)))
-    (eval
-     `(let ((,n-sap ',(alien-value-sap alien))
-	    (,n-offset ',(alien-value-offset alien))
-	    (,n-size ',(alien-value-size alien)))
-	,(funcall access n-sap n-offset n-size alien-type :read nil
-		  'alien-access)))))
-
-(defsetf alien-access %set-alien-access
-  "Stores the representation of the value into the alien.")
-
-;;; %Set-Alien-Access  --  Public
-;;;
-;;;    Like Alien-Access, only we call the expert with :write and return
-;;; the new value.
-;;;
-(defun %set-alien-access (alien lisp-type &optional (new-value nil nvp))
-  (declare (type alien-value alien))
-  (let* ((lisp-type (if nvp lisp-type nil))
-	 (new-value (if nvp new-value lisp-type))
-	 (alien-type (alien-value-type alien))
-	 (access (get-alien-access-method alien-type lisp-type))
-	 (n-sap (gensym))
-	 (n-offset (gensym))
-	 (n-size (gensym))
-	 (n-nval (gensym)))
-    (eval
-     `(let ((,n-sap ',(alien-value-sap alien))
-	    (,n-offset ',(alien-value-offset alien))
-	    (,n-size ',(alien-value-size alien))
-	    (,n-nval ,new-value))
-	,(funcall access n-sap n-offset n-size alien-type :write n-nval
-		  '(setf alien-access))))
-    new-value))
-
-
-;;;; Miscellaneous alien access methods:
-
-;;; Alien-Access expert for Port  --  Internal
-;;;
-;;;    Just find the place and grab or store a 32-bit port, depending
-;;; on the access kind, treating ports as 32-bit signed integers. --JRG
-;;;
-(define-alien-access (port) (type kind value form)
-  ;;
-  ;; We want to know if the offset is constant, and the size must be two
-  ;; words.
-  (with-alien (sap)
-	      (offset :unit nil)
-	      (size :constant 32
-		    :unit nil)
-    (declare (ignore size))
-    (if (eq kind :read)
-	`(naturalize-integer t ,sap ,offset 32 ',form)
-	`(deport-integer t ,sap ,offset 32 ,value ',form))))
-
-;;; Alien-Access expert for String-Char  --  Internal
-;;;
-;;;    Kind of easy, but we need to deal with random bit positions.  What we do
-;;; is call Naturalize-Integer or Deport-Integer to do the access, and just do
-;;; the type conversion.
-;;;
-(define-alien-access (string-char) (type kind value form)
-  (with-alien (sap)
-	      (offset :unit nil)
-	      (size :unit nil :minimum 8)
-    (if (eq kind :read)
-	`(code-char (naturalize-integer nil ,sap ,offset ,size ',form))
-	`(deport-integer nil ,sap ,offset ,size (char-code ,value) ',form))))
-
-;;; Alien-Access experts for Unsigned-Byte, Signed-Byte  --  Internal
-;;;
-;;;    Like, just call Naturalize or Deport Integer.
-;;;
-(define-alien-access (unsigned-byte) (type kind value form)
-  (with-alien (sap)
-	      (offset :unit nil)
-	      (size :minimum (cadr type)
-		    :unit nil)
-    (if (eq kind :read)
-	`(naturalize-integer nil ,sap ,offset ,size ',form)
-	`(deport-integer nil ,sap ,offset ,size ,value ',form))))
-;;;
-(define-alien-access (signed-byte) (type kind value form)
-  (with-alien (sap)
-	      (offset :unit nil)
-	      (size :minimum (cadr type)
-		    :unit nil)
-    (if (eq kind :read)
-	`(naturalize-integer t ,sap ,offset ,size ',form)
-	`(deport-integer t ,sap ,offset ,size ,value ',form))))
-
-#| 
-I didn't write this, and it is wrong, since it assumes the size is constant.
-In fact, it will never be constant at this point in the new compiler.  I also
-don't know that it is supposed to be used for.  I suspect it is a PERQ crock.
-
-(define-alien-access (unstructured) (type kind value)
-  (with-alien (sap)
-	      (offset :unit nil)
-	      (size :unit nil
-		    :minimum (cadr type))
-    (if (eq kind :read)
-	(if (<= size 32)
-	    `(naturalize-integer nil ,sap ,offset ,size)
-	    (if (and (= (mod offset 32) 0) (= (mod size 32) 0))
-		(do ((i 32 (+ i 32))
-		     (form `(naturalize-integer nil ,sap ,offset 32)))
-		    ((>= i size) form)
-		  (setq form
-			`(logior (ash ,form 32)
-				 (naturalize-integer nil ,sap
-						     ,(+ offset i) 32))))
-		(error
-		 "Unstructured aliens of size ~D and offset ~D not supported."
-		 size offset)))
-	(if (<= size 32)
-	    `(deport-integer nil ,sap ,offset ,size ,value)
-	    (if (and (= (mod offset 32) 0) (= (mod size 32) 0))
-		(do ((i (- size 32) (- i 32))
-		     (shift 0 (- shift 32))
-		     (form ()))
-		    ((< i 0) (nreverse form))
-		  (push `(deport-integer nil ,sap ,(+ offset i) 32
-					 (logand (ash ,value ,shift)
-						 #xFFFFFFFF))
-			form))
-		(error
-		 "Unstructured aliens of size ~D and offset ~D not supported."
-		 size offset)))))))
-
-|#
-
-;;; Alien-Access expert for Boolean  --  Internal 
-;;;
-;;;    A boolean is a single bit, represented in Lisp as T or NIL.
-;;;
-(define-alien-access (boolean) (type kind value form)
-  (with-alien (sap)
-	      (offset :unit 1)
-	      (size :unit 1  :minimum 1)
-    (if (eq kind :read)
-	`(naturalize-boolean ,sap ,offset ,size ',form)
-	`(deport-boolean ,sap ,offset ,size ,value ',form))))
-
-
-;;; Alien-Access expert for short-floats
-;;;
-(define-alien-access (short-float) (type kind value)
-  (with-alien (sap)
-	      (offset)
-	      (size :constant 2)
-    (declare (ignore size))
-    (if (eq kind :read)
-	`(%primitive int-sap
-	  (logior (ash (%primitive unsigned-32bit-system-ref ,sap ,offset)
-		       (- clc::short-float-shift-16))
-		  (ash clc::short-float-4bit-type
-		       (- 32 clc::short-float-shift-16))))
-	(let ((var (gensym)))
-	  `(let ((,var (float ,value 1.0s0)))
-	     (setq ,var (ash (%primitive sap-int ,var) clc::short-float-shift-16))
-	     (%primitive signed-32bit-system-set ,sap ,offset ,var))))))
-
-
-;;; Alien-Access expert for long-floats
-;;;
-(define-alien-access (long-float) (type kind value)
-  (with-alien (sap)
-	      (offset)
-	      (size :constant 4)
-    (declare (ignore size))
-    (if (eq kind :read)
-	(let ((var (gensym)))
-	  `(let ((,var (%primitive float-long 0)))
-	     (%primitive 16bit-system-set ,var 2
-			 (%primitive 16bit-system-ref ,sap ,offset))
-	     (%primitive 16bit-system-set ,var 3
-			 (%primitive 16bit-system-ref ,sap (1+ ,offset)))
-	     (%primitive 16bit-system-set ,var 4
-			 (%primitive 16bit-system-ref ,sap (+ ,offset 2)))
-	     (%primitive 16bit-system-set ,var 5
-			 (%primitive 16bit-system-ref ,sap (+ ,offset 3)))
-	     ,var))
-	(let ((var (gensym)))
-	  `(let ((,var (float ,value 1.0L0)))
-	     (%primitive 16bit-system-set ,sap ,offset
-			 (%primitive 16bit-system-ref ,var 2))
-	     (%primitive 16bit-system-set ,sap (1+ ,offset)
-			 (%primitive 16bit-system-ref ,var 3))
-	     (%primitive 16bit-system-set ,sap (+ ,offset 2)
-			 (%primitive 16bit-system-ref ,var 4))
-	     (%primitive 16bit-system-set ,sap (+ ,offset 3)
-			 (%primitive 16bit-system-ref ,var 5)))))))
-
-;;; Alien-access expert for procedure objects.  These should be used
-;;; with caution.
-;;;
-(define-alien-access (c-procedure) (type kind value)
-  (with-alien (sap)
-	      (offset)
-	      (size :constant 2)
-    (declare (ignore size))
-    (if (eq kind :read)
-	`(error "It is illegal to reference a c-procedure object.")
-	`(%primitive set-c-procedure-pointer ,sap ,offset ,value))))
-
-
-;;;; Strings accesses:
-
-;;; Alien-Access expert for String  --  Internal
-;;;
-;;;    Read a Perq-String into a string or write a string out into
-;;; a Perq-String.
-;;;
-(define-alien-access (simple-string perq-string) (type kind n-value)
-  (with-alien (n-sap)
-	      (n-offset :unit 8)
-	      (size :unit 8
-		    :minimum (1+ (cadr type)))
-    (declare (ignore size))
-    (if (eq kind :read)
-	(let ((size (gensym))
-	      (str (gensym)))
-	  `(let* ((,size (%primitive 8bit-system-ref ,n-sap ,n-offset))
-		  (,str (make-string ,size)))
-	     (%primitive byte-blt ,n-sap (1+ ,n-offset) ,str 0 ,size)
-	     ,str))
-	(let ((len (gensym))
-	      (1+off (gensym)))
-	  `(let ((,len (length (the simple-string
-				    ,n-value)))
-		 (,1+off (1+ ,n-offset)))
-	     (check<= ,len ,(cadr type))
-	     (%primitive 8bit-system-set ,n-sap ,n-offset ,len)
-	     (%primitive byte-blt ,n-value 0 ,n-sap ,1+off
-			 (+ ,1+off ,len)))))))
-
-
-;;; Alien-Access expert for null terminated string  --  Internal
-;;;
-;;;    Read a null terminated string into a string or write a string out into
-;;; a null terminated string.
-;;;
-(define-alien-access (simple-string null-terminated-string) (type kind n-value)
-  (with-alien (n-sap)
-	      (n-offset :unit 8)
-	      (size :unit 8
-		    :minimum (cadr type))
-    (declare (ignore size))
-    (if (eq kind :read)
-	(let ((size (gensym))
-	      (str (gensym)))
-	  `(let* ((,size (the fixnum
-			      (- (the fixnum
-				      (%primitive find-character
-						  ,n-sap ,n-offset
-						  most-positive-fixnum 0))
-				 (the fixnum ,n-offset))))
-		  (,str (make-string ,size)))
-	     (%primitive byte-blt ,n-sap ,n-offset ,str 0 ,size)
-	     ,str))
-	(let ((len (gensym))
-	      (end (gensym)))
-	  `(let* ((,len (the fixnum (1+ (length (the simple-string
-						     ,n-value)))))
-		  (,end (the fixnum (+ (the fixnum ,len) ,n-offset))))
-	     (declare (fixnum ,len ,end))
-	     (check<= ,len ,(cadr type))
-	     (%primitive byte-blt ,n-value 0 ,n-sap ,n-offset ,end)
-	     (%primitive 8bit-system-set ,n-sap
-			 (the fixnum (1+ ,end)) 0))))))
-
-
-;;;; Pointer alien access:
-
-;;; Alien-Access expert for System-Area-Pointer  --  Internal
-;;;
-;;;    Get or store a pointer.  In the store case this is the same
-;;; as Pointer.
-;;;
-(define-alien-access (system-area-pointer system-area-pointer alien)
-  (type kind value)
-  (with-alien (sap)
-	      (offset)
-	      (size :constant 2)
-    (declare (ignore size))
-    (if (eq kind :read)
-	`(%primitive sap-system-ref ,sap ,offset)
-	`(%primitive pointer-system-set ,sap ,offset ,value))))
-
-;;; Alien-Access expert for (Alien <type> [<bits>])  --  Internal
-;;;
-;;;    Get or store an alien value.  On read, we cons up a value, getting
-;;; the size of out the type.  On write, we just store the SAP.
-;;;
-(define-alien-access (alien) (type kind value)
-  (with-alien (sap)
-	      (offset)
-	      (size :constant 2)
-    (declare (ignore size))
-    (unless (and (consp type) (consp (cdr type)))
-      (error "Bad type for accessing as an Alien: ~S" type))
-    (let ((atype (second type))
-	  (size (third type)))
-      (cond
-       ((eq kind :read)
-	(unless size
-	  (error "Size not specified when reading alien type: ~S" type))
-	(unless (and (integerp size) (>= size 0))
-	  (error "Size is not a positive integer: ~S" type))
-	`(make-alien-value
-	  (%primitive sap-system-ref ,sap ,offset)
-	  0
-	  ,size
-	  ',atype))
-       (t
-	`(%primitive pointer-system-set ,sap ,offset
-		     (alien-value-sap ,value)))))))
-
-;;; Alien-Access expert for (Pointer xxx)  --  Internal
-;;;
-;;;    We can't read pointers, and can only store pointers to unboxed
-;;; things.
-;;;
-(define-alien-access (pointer pointer alien) (type kind value)
-  (with-alien (sap)
-	      (offset)
-	      (size :constant 2)
-    (declare (ignore size))
-    (when (eq kind :read)
-      (error "Cannot read with Pointer Alien type:~%~S" type))
-    `(%primitive pointer-system-set ,sap ,offset ,value)))
-
-
-;;;; Enumeration Alien access:
-
-(compiler-let ((lisp::*bootstrap-defmacro* t))
-
-;;; Defenumeration  --  Public
-;;;
-;;;    Cons up the from alist, keeping track of the minimum and maximum
-;;; values, then decide whether to use a vector or alist to mapping.
-;;;
-(defmacro defenumeration (name &rest elements)
-  "Defenumeration Name {{Element}+ | {(Element Value)}+}
-  Define an enumeration for use with Alien-Access and the Enumeration
-  Alien type."
-  (let ((min nil)
-	(max nil)
-	(from-alist ()))
-    (declare (list from-alist))
-    (when (null elements)
-      (error "An anumeration must contain at least one element."))
-    (if (listp (car elements))
-	(dolist (el elements)
-	  (unless (listp el)
-	    (error "Element value is not specified: ~S." el))
-	  (push (cons (first el) (second el)) from-alist))
-	(let ((num -1))
-	  (dolist (el elements)
-	    (push (cons el (incf num)) from-alist))))
-    (do ((el from-alist (cdr el)))
-	((null el))
-      (let ((sym (caar el))
-	    (val (cdar el)))
-	(unless (keywordp sym)
-	  (error "Enumeration element ~S is not a keyword." sym))
-	(unless (integerp val)
-	  (error "Element value ~S is not an integer." val))
-	(unless (and max (> max val)) (setq max val))
-	(unless (and min (< min val)) (setq min val))
-	(when (rassoc val (cdr el))
-	  (error "Element value ~S used more than once." val))
-	(when (assq sym (cdr el))
-	  (error "Enumeration element ~S used more than once." sym))))
-    (let* ((signed (minusp min))
-	   (to (intern (concatenate 'simple-string (string name)
-				    "-TO-ENUMERATION-" (string (gensym)))))
-	   (from (intern (concatenate 'simple-string (string name)
-				      "-FROM-ENUMERATION-" (string (gensym)))))
-	   (info (make-enumeration-info :signed signed
-					:size (if signed
-						  (1+ (max (integer-length min)
-							   (integer-length max)))
-						  (integer-length max))
-					:from from  :to to))
-	   to-thing)
-      (cond
-       ;;
-       ;; If range is at least 20% dense, use vector mapping.  Crossover
-       ;; point solely on basis of space would be 25%.  Vector mapping
-       ;; is always faster, so give the benefit of the doubt.
-       ((< 0.2 (/ (float (length from-alist)) (float (- max min))))
-	;;
-	;; If offset is small and ignorable, ignore it to save time.
-	(when (< 0 min 10) (setq min 0))
-	(setq to-thing (make-array (1+ (- max min))))
-	(dolist (el from-alist)
-	  (setf (svref to-thing (- (cdr el) min)) (car el)))
-	(setf (enumeration-info-kind info) :vector)
-	(setf (enumeration-info-offset info) (- min)))
-       (t
-	(setf (enumeration-info-kind info) :alist)
-	(setq to-thing (mapcar #'(lambda (x) (cons (cdr x) (car x))) from-alist))))
-      `(progn
-	(eval-when (compile load eval)
-	  (proclaim '(special ,to ,from))
-	  (set ',to ',to-thing)
-	  (set ',from ',from-alist))
-	(eval-when ,*alien-eval-when*
-	  (setf (info enumeration info ',name) ',info))
-	',name))))
-
-); compiler-let
-
-;;; Enumeration-Error  --  Internal
-;;;
-;;;    Tell the luser what permissable values the enumeration has when she
-;;; gives us something bogus.  We even give them a chance to specify
-;;; something else.
-;;;
-(defun enumeration-error (alist)
-  (loop
-   (cerror "Prompt for a new value."
-	   "Enumeration value is not one of the following: ~{~<~%  ~:;~S ~>~}"
-	  (mapcar #'car alist))
-   (write-string "New value: " *query-io*)
-   (let* ((response (read *query-io*))
-	  (res (cdr (assq response alist))))
-     (when res (return res)))))
-
-
-(define-alien-access (enumeration) (type kind value form)
-  (let* ((enum (cadr type))
-	 (info (or (info enumeration info enum)
-		   (error "~S is not a defined enumeration." enum)))
-	 (signed (enumeration-info-signed info))
-	 (to (enumeration-info-to info))
-	 (from (enumeration-info-from info)))
-    (with-alien (sap)
-		(offset :unit nil)
-		(size :unit nil
-		      :minimum (enumeration-info-size info))
-      (if (eq kind :read)
-	  (ecase (enumeration-info-kind info)
-	    (:vector
-	     `(svref ,to
-		     (+ ,(enumeration-info-offset info)
-			(naturalize-integer ,signed ,sap ,offset ,size
-					    ',form))))
-	    (:alist
-	     `(cdr (assoc (naturalize-integer ,signed ,sap ,offset ,size
-					      ',form)
-			  ,to))))
-	  `(deport-integer
-	    ,signed ,sap ,offset ,size
-	    (or (cdr (assq ,value ,from))
-		(enumeration-error ,from))
-	    ',form)))))
-
diff --git a/code/array.lisp b/code/array.lisp
deleted file mode 100644
index 77cbf80e12a6b71eec885d58de3df5da5e145ddf..0000000000000000000000000000000000000000
--- a/code/array.lisp
+++ /dev/null
@@ -1,873 +0,0 @@
-;;; -*- Log: code.log; Package: Lisp -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; Functions to implement arrays for Spice Lisp 
-;;; Written by Skef Wholey.
-;;;
-(in-package "LISP")
-
-(export '(array-rank-limit array-dimension-limit array-total-size-limit
-	  make-array vector aref array-element-type array-rank
-	  array-dimension array-dimensions array-in-bounds-p
-	  array-row-major-index array-total-size svref bit sbit
-	  bit-and bit-ior bit-xor bit-eqv bit-nand bit-nor bit-andc1 bit-andc2
-	  bit-orc1 bit-orc2 bit-not array-has-fill-pointer-p
-	  fill-pointer vector-push vector-push-extend vector-pop adjust-array
-          adjustable-array-p row-major-aref))
-
-(defconstant array-rank-limit 65529
-  "The exclusive upper bound on the rank of an array.")
-
-(defconstant array-dimension-limit most-positive-fixnum
-  "The exclusive upper bound any given dimension of an array.")
-
-(defconstant array-total-size-limit most-positive-fixnum
-  "The exclusive upper bound on the total number of elements in an array.")
-
-
-;;; Random function used by WITH-ARRAY-DATA, which has to be defined in
-;;; init.lisp.
-;;;
-(defun find-data-vector (array)
-  (do ((data array (%primitive header-ref data %array-data-slot))
-       (cumulative-offset 0
-			  (the fixnum
-			       (+ cumulative-offset
-				  (the fixnum
-				       (or (%primitive header-ref data
-						       %array-displacement-slot)
-					   0))))))
-      ((not (array-header-p data))
-       (values data cumulative-offset))
-    (declare (fixnum cumulative-offset))))
-
-
-
-(defun make-array (dimensions &key
-			      (element-type t)
-			      (initial-element nil initial-element-p)
-			      initial-contents adjustable fill-pointer
-			      displaced-to displaced-index-offset)
-  "Creates an array of the specified Dimensions.  See manual for details."
-  (unless (listp dimensions) (setq dimensions (list dimensions)))
-  (let ((array-rank (length (the list dimensions))))
-    (declare (fixnum array-rank))
-    (if (eq fill-pointer t) (setq fill-pointer (car dimensions)))
-    (if (and fill-pointer (> array-rank 1))
-	(error "Multidimensional arrays can't have fill pointers."))
-    (cond (displaced-to
-	   ;; If the array is displaced, make a header and fill it up.
-	   (unless (subtypep element-type (array-element-type displaced-to))
-	     (error "One can't displace an array of type ~S into another of ~
-		    type ~S." element-type (array-element-type displaced-to)))
-	   (if (or initial-element initial-contents)
-	       (error "The :initial-element or initial-contents option may not ~
-		       be specified with :displaced-to."))
-	   (let ((displacement (or displaced-index-offset 0))
-		 (array-size (array-linear-length dimensions)))
-	     (declare (fixnum displacement array-size))
-	     (if (< (the fixnum (array-total-size displaced-to))
-		    (the fixnum (+ displacement array-size)))
-		 (error "The :displaced-to array is too small."))
-	     (set-array-header (%primitive alloc-array array-rank)
-			       displaced-to array-size
-			       (or fill-pointer array-size)
-			       displacement dimensions t)))
-	  ((and (not adjustable) (= array-rank 1) (not fill-pointer))
-	   ;; If the array can be represented as a simple thing, do that.
-	   (if (and initial-element-p initial-contents)
-	       (error "The :initial-contents option may not be specified with ~
-		       :initial-element."))
-	   (data-vector-from-inits dimensions (car dimensions) array-rank
-				   element-type initial-contents
-				   initial-element initial-element-p))
-	  (t
-	   ;; Otherwise, build a complex array.
-	   (if (and initial-element-p initial-contents)
-	       (error "The :initial-contents option may not be specified with ~
-		       :initial-element."))
-	   (let* ((array-size (array-linear-length dimensions))
-		  (array (%primitive alloc-array array-rank))
-		  (array-data (data-vector-from-inits
-			       dimensions array-size array-rank element-type
-			       initial-contents initial-element
-			       initial-element-p)))
-	     (set-array-header array array-data array-size
-			       (or fill-pointer array-size)
-			       0 ;displacement
-			       dimensions nil))))))
-
-;;; Some people out there are still calling MAKE-VECTOR:
-;;;
-(setf (symbol-function 'make-vector) #'make-array)
-
-(defun vector (&rest objects)
-  "Constructs a simple-vector from the given objects."
-  (coerce (the list objects) 'simple-vector))
-
-;;; DATA-VECTOR-FROM-INITS returns a simple vector that has the specified array
-;;; characteristics.  Dimensions is only used to pass to COPY-CONTENTS-AUX
-;;; for error checking on the structure of initial-contents.
-;;;
-(defun data-vector-from-inits (dimensions total-size rank element-type
-			       initial-contents initial-element
-			       initial-element-p)
-  (let ((data (cond ((subtypep element-type 'string-char)
-		     (%primitive alloc-string total-size))
-		    ((subtypep element-type '(unsigned-byte 32))
-		     (%primitive alloc-i-vector total-size
-				 (element-type-to-access-code element-type)))
-		    (t
-		     (%primitive alloc-g-vector total-size initial-element)))))
-    (cond (initial-element-p
-	   (unless (simple-vector-p data)
-	     (unless (typep initial-element element-type)
-	       (error "~S cannot be used to initialize an array of type ~S."
-		      initial-element element-type))
-	     (fill (the vector data) initial-element)))
-	  (initial-contents
-	   (copy-contents-aux dimensions initial-contents element-type
-			      rank 0 data)))
-    data))
-
-;;; COPY-CONTENTS-AUX spins down into the Data vector and the Initial-Contents
-;;; filling the former from the latter.
-;;;
-(defun copy-contents-aux (dimensions initial-contents element-type
-			  depth index data)
-  (declare (fixnum depth index))
-  (cond ((= depth 0)
-	 (unless (typep initial-contents element-type)
-	   (error "~S cannot be used to initialize an array of element-type ~S."
-		  initial-contents element-type))
-	 (setf (aref data index) initial-contents)
-	 (the fixnum (1+ index)))
-	((listp initial-contents)
-	 (unless (= (length (the list initial-contents)) (car dimensions))
-	   (error "This part of initial-contents, ~S, is an unappropriate ~
-		   length for the dimension, ~S."
-		  initial-contents (car dimensions)))
-	 (do ((initial-contents initial-contents (cdr initial-contents))
-	      (next-dimensions (cdr dimensions))
-	      (next-depth (the fixnum (1- depth))))
-	     ((null initial-contents) index)
-	   (declare (list initial-contents))
-	   (setq index (copy-contents-aux
-			next-dimensions (car initial-contents) element-type
-			next-depth index data))))
-	((vectorp initial-contents)
-	 (unless (= (length (the vector initial-contents)) (car dimensions))
-	   (error "This part of initial-contents, ~S, is an unappropriate ~
-		   length for the dimension, ~S."
-		  initial-contents (car dimensions)))
-	 (do ((i-index 0 (1+ i-index))
-	      (i-end (length (the vector initial-contents)))
-	      (next-dimensions (cdr dimensions))
-	      (next-depth (the fixnum (1- depth))))
-	     ((= i-index i-end) index)
-	   (declare (fixnum i-index i-end))
-	   (setq index (copy-contents-aux
-			next-dimensions (aref initial-contents index)
-			element-type next-depth index data))))
-	(t
-	 (error "~S is not a sequence, and cannot be used to initialize~%~
-		the contents of an array." initial-contents))))
-
-;;; ELEMENT-TYPE-TO-ACCESS-CODE returns the Spice Lisp I-Vector access code to
-;;; be used for the data vector of an array with the given access code.
-;;;
-(defun element-type-to-access-code (type)
-  (cond ((subtypep type 'bit) 0)
-	((subtypep type '(unsigned-byte 2)) 1)
-	((subtypep type '(unsigned-byte 4)) 2)
-	((subtypep type '(unsigned-byte 8)) 3)
-	((subtypep type '(unsigned-byte 16)) 4)
-	((subtypep type '(unsigned-byte 32)) 5)
-	(t (error "Unexpected array element type -- ~S." type))))
-
-
-;;; ARRAY-LINEAR-LENGTH returns the number of elements an array with the
-;;; specified dimensions would have.
-;;;
-(defun array-linear-length (dimensions)
-  (do ((dimensions dimensions (cdr dimensions))
-       (length 1))
-      ((null dimensions) length)
-    (declare (fixnum length))
-    (setq length (* length (the fixnum (car dimensions))))))
-
-(defun aref (array &rest subscripts)
-  "Returns the element of the Array specified by the Subscripts."
-  (if (and subscripts (null (cdr subscripts)))
-      (aref array (car subscripts))
-      (do ((subscripts (nreverse (the list subscripts)) (cdr subscripts))
-	   (dim-index (1- (the fixnum (%primitive header-length array)))
-		      (1- dim-index))
-	   (chunk-size 1)
-	   (result 0))
-	  ((= (the fixnum dim-index) %array-dim-base)
-	   (if (atom subscripts)
-	       (with-array-data ((data array) (start) (end))
-		 (declare (ignore end))
-		 (aref data (the fixnum (+ start result))))
-	       (error "Too many subscripts for array reference.")))
-	(declare (fixnum dim-index chunk-size result))
-	(let ((axis (%primitive header-ref array dim-index)))
-	  (declare (fixnum axis))
-	  (cond ((atom subscripts)
-		 (error "Too few subscripts for array reference."))
-		((not (< -1 (the fixnum (car subscripts)) axis))
-		 (error "Subscript ~S is out of bounds." (car subscripts)))
-		(t
-		 (setq result (the fixnum
-				   (+ result
-				      (the fixnum
-					   (* (the fixnum (car subscripts))
-					      chunk-size)))))
-		 (setq chunk-size (* chunk-size axis))))))))
-
-(defun %aset (array &rest stuff)
-  (if (and (cdr stuff) (null (cddr stuff)))
-      (setf (aref array (car stuff)) (cadr stuff))
-      (let ((rstuff (nreverse (the list stuff))))
-	(do ((subscripts (cdr rstuff) (cdr subscripts))
-	     (dim-index (1- (the fixnum (%primitive header-length array)))
-			(1- dim-index))
-	     (chunk-size 1)
-	     (result 0))
-	    ((= dim-index %array-dim-base)
-	     (if (atom subscripts)
-		 (with-array-data ((data array) (start) (end))
-		   (declare (ignore end))
-		   (setf (aref data (+ start result)) (car rstuff)))
-		 (error "Too many subscripts for array reference.")))
-	  (declare (fixnum dim-index chunk-size result))
-	  (let ((axis (%primitive header-ref array dim-index)))
-	    (declare (fixnum axis))
-	    (cond ((atom subscripts)
-		   (error "Too few subscripts for array reference."))
-		  ((not (< -1 (the fixnum (car subscripts)) axis))
-		   (error "Subscript ~S is out of bounds."
-			  (car subscripts)))
-		  (t
-		   (setq result (+ result
-				   (the fixnum (* (the fixnum (car subscripts))
-						  chunk-size))))
-		   (setq chunk-size (* chunk-size axis)))))))))
-
-
-;;; %Apply-aset is called when (setf (apply #'aref ...) new-value) is
-;;; called.
-
-(defun %apply-aset (new-value array &rest stuff)
-  (if (null (cdr stuff))
-      (setf (aref array (car stuff)) new-value)
-      (let ((rstuff (nreverse (the list stuff))))
-	(do ((subscripts rstuff (cdr subscripts))
-	     (dim-index (1- (the fixnum (%primitive header-length array)))
-			(1- dim-index))
-	     (chunk-size 1)
-	     (result 0))
-	    ((= dim-index %array-dim-base)
-	     (if (atom subscripts)
-		 (with-array-data ((data array) (start) (end))
-				  (declare (ignore end))
-				  (setf (aref data (+ start result)) new-value))
-		 (error "Too many subscripts for array reference.")))
-	  (declare (fixnum dim-index chunk-size result))
-	  (let ((axis (%primitive header-ref array dim-index)))
-	    (declare (fixnum axis))
-	    (cond ((atom subscripts)
-		   (error "Too few subscripts for array reference."))
-		  ((not (< -1 (the fixnum (car subscripts)) axis))
-		   (error "Subscript ~S is out of bounds."
-			  (car subscripts)))
-		  (t
-		   (setq result (+ result
-				   (the fixnum (* (the fixnum (car subscripts))
-						  chunk-size))))
-		   (setq chunk-size (* chunk-size axis)))))))))
-
-(defun array-element-type (array)
-  "Returns the type of the elements of the array"
-  (cond ((bit-vector-p array)
-	 '(mod 2))
-	((stringp array)
-	 'string-char)
-	((simple-vector-p array)
-	 t)
-	((array-header-p array)
-	 (with-array-data ((data array) (start) (end))
-	   (declare (ignore start end))
-	   (array-element-type data)))
-	((vectorp array)
-	 (case (%primitive get-vector-access-code array)
-	   (0 'bit)
-	   (1 '(unsigned-byte 2))
-	   (2 '(unsigned-byte 4))
-	   (3 '(unsigned-byte 8))
-	   (4 '(unsigned-byte 16))
-	   (5 '(unsigned-byte 32))))
-	(t (error "~S is not an array." array))))
-
-(defun array-rank (array)
-  "Returns the number of dimensions of the Array."
-  (if (array-header-p array)
-      (the fixnum (- (the fixnum (%primitive header-length array))
-		     %array-first-dim-slot))
-      1))
-
-(defun array-dimension (array axis-number)
-  "Returns length of dimension Axis-Number of the Array."
-  (declare (fixnum axis-number))
-  (if (array-header-p array)
-      (if (and (>= axis-number 0)
-	       (< axis-number (the fixnum (array-rank array))))
-	  (%primitive header-ref array (the fixnum (+ %array-first-dim-slot axis-number)))
-	  (error "~S is an illegal axis number." axis-number))
-      (if (= axis-number 0)
-	  (%primitive vector-length array)
-	  (error "~S is an illegal axis number." axis-number))))
-
-(defun array-dimensions (array)
-  "Returns a list whose elements are the dimensions of the array"
-  (if (array-header-p array)
-      (do ((index %array-first-dim-slot (1+ index))
-	   (end (%primitive header-length array))
-	   (result ()))
-	  ((= index end) (nreverse result))
-	(declare (fixnum index end))
-	(push (%primitive header-ref array index) result))
-      (list (%primitive vector-length array))))
-
-(defun array-total-size (array)
-  "Returns the total number of elements in the Array."
-  (if (array-header-p array)
-      (%primitive header-ref array %array-length-slot)
-      (%primitive vector-length array)))
-
-(defun array-in-bounds-p (array &rest subscripts)
-  "Returns T if the Subscipts are in bounds for the Array, Nil otherwise."
-  (if (array-header-p array)
-      (do ((dim-index %array-first-dim-slot (1+ dim-index))
-	   (dim-index-limit (+ %array-first-dim-slot
-			       (the fixnum (array-rank array))))
-	   (subs subscripts (cdr subs)))
-	  ((= dim-index dim-index-limit)
-	   (atom subs))
-	(declare (fixnum dim-index dim-index-limit))
-	(if (atom subs)
-	    (return nil)
-	    (if (not (< -1
-			(the fixnum (car subs))
-			(the fixnum (%primitive header-ref array dim-index))))
-		(return nil))))
-      (and (null (cdr subscripts))
-	   (< -1
-	      (the fixnum (car subscripts))
-	      (the fixnum (%primitive vector-length array))))))
-
-(defun array-row-major-index (array &rest subscripts)
-  "Returns the index into the Array's data vector for the given subscripts."
-  (if (array-header-p array)
-      (do ((subscripts (nreverse (the list subscripts)) (cdr subscripts))
-	   (dim-index (1- (the fixnum (%primitive header-length array)))
-		      (1- dim-index))
-	   (chunk-size 1)
-	   (result 0))
-	  ((= dim-index %array-dim-base)
-	   (if (atom subscripts)
-	       result
-	       (error "Too many subscripts for array reference.")))
-	(declare (fixnum dim-index chunk-size result))
-	(let ((axis (%primitive header-ref array dim-index)))
-	  (declare (fixnum axis))
-	  (cond ((null subscripts)
-		 (error "Too few subscripts for array reference."))
-		((not (< -1 (the fixnum (car subscripts)) axis))
-		 (error "Subscript ~S is out of bounds." (car subscripts)))
-		(t
-		 (setq result (+ result
-				 (the fixnum (* (the fixnum (car subscripts))
-						chunk-size))))
-		 (setq chunk-size (* chunk-size axis))))))
-      (cond ((null subscripts)
-	     (error "Too few subscripts for array reference."))
-	    ((not (< -1
-		     (the fixnum (car subscripts))
-		     (length (the simple-array array))))
-	     (error "Subscript ~S is out of bounds." (car subscripts)))
-	    (t
-	     (car subscripts)))))
-
-(defun adjustable-array-p (array)
-  "Returns T if the given Array is adjustable, or Nil otherwise."
-  (array-header-p array))
-
-
-(defun row-major-aref (array index)
-  "Returns the element of array corressponding to the row-major index.  This is
-   SETF'able."
-  (with-array-data ((data array) (start) (end))
-    (declare (ignore end))
-    (aref data (+ start index))))
-
-(defsetf row-major-aref %set-row-major-aref)
-
-(defun %set-row-major-aref (array index new-value)
-  (with-array-data ((data array) (start) (end))
-    (declare (ignore end))
-    (setf (aref data (+ start index)) new-value)))
-
-(defun svref (simple-vector index)
-  "Returns the Index'th element of the given Simple-Vector."
-  (svref simple-vector index))
-
-(defun %svset (simple-vector index new)
-  (setf (svref simple-vector index) new))
-
-;;; The following function is used when (setf (apply #'svref ...) new
-;;; is compiled.
-
-(defun %apply-svset (new simple-vector index)
-  (setf (svref simple-vector index) new))
-
-(defun array-has-fill-pointer-p (array)
-  "Returns T if the given Array has a fill pointer, or Nil otherwise."
-  (and (vectorp array) (array-header-p array)))
-
-(defun fill-pointer (vector)
-  "Returns the Fill-Pointer of the given Vector."
-  (if (and (vectorp vector) (array-header-p vector))
-      (%primitive header-ref vector %array-fill-pointer-slot)
-      (error "~S is not an array with a fill-pointer." vector)))
-
-(defun %set-fill-pointer (vector new)
-  (declare (fixnum new))
-  (if (and (vectorp vector) (array-header-p vector))
-      (if (> new (the fixnum (%primitive header-ref vector %array-length-slot)))
-	  (error "New fill pointer, ~S, is larger than the length of the vector."
-		 new)
-	  (%primitive header-set vector %array-fill-pointer-slot new))
-      (error "~S is not an array with a fill-pointer." vector)))
-
-(defun vector-push (new-el array)
-  "Attempts to set the element of Array designated by the fill pointer
-   to New-El and increment fill pointer by one.  If the fill pointer is
-   too large, Nil is returned, otherwise the new fill pointer value is 
-   returned."
-  (if (array-header-p array)
-      (let ((fill-pointer (%primitive header-ref array %array-fill-pointer-slot)))
-	(declare (fixnum fill-pointer))
-	(cond ((= fill-pointer
-		  (the fixnum (%primitive header-ref array %array-length-slot)))
-	       nil)
-	      (t (%primitive header-set array %array-fill-pointer-slot
-			     (1+ fill-pointer))
-		 (with-array-data ((data array) (start) (end))
-		   (declare (ignore end))
-		   (setf (aref data (+ fill-pointer start)) new-el))
-		 fill-pointer)))
-      (error "~S: Object has no fill pointer." array)))
-
-(defun vector-push-extend (new-el array &optional (extension (length array)))
-  "Like Vector-Push except that if the fill pointer gets too large, the
-   Array is extended rather than Nil being returned."
-  (declare (fixnum extension))
-  (if (array-header-p array)
-      (let ((length (%primitive header-ref array %array-length-slot))
-	    (fill-pointer (%primitive header-ref array %array-fill-pointer-slot)))
-	(declare (fixnum length fill-pointer))
-	(with-array-data ((data array) (start) (end))
-	  (declare (ignore end))
-	  (if (= fill-pointer length)
-	      (do* ((new-index 0 (1+ new-index))
-		    (new-length (let ((l (+ length extension)))
-				  (declare (fixnum l))
-				  (if (zerop l) 1 l)))
-		    (old-index start (1+ old-index))
-		    (new-data (make-array (if (zerop new-length) 1 new-length)
-					  :element-type (array-element-type
-							 array))))
-		   ((= new-index length)
-		    (setq data new-data)
-		    (setq start 0)
-		    (set-array-header array data new-length
-				      (1+ fill-pointer) start new-length nil))
-		(declare (fixnum new-index new-length old-index))
-		(setf (aref new-data new-index) (aref data old-index)))
-	      (%primitive header-set array
-			  %array-fill-pointer-slot (1+ fill-pointer)))
-	  (setf (aref data (+ fill-pointer start)) new-el)
-	  fill-pointer))
-      (error "~S has no fill pointer." array)))
-
-(defun vector-pop (array)
-  "Attempts to decrease the fill-pointer by 1 and return the element
-   pointer to by the new fill pointer.  If the new value of the fill
-   pointer is 0, an error occurs."
-  (if (array-header-p array)
-      (let ((fill-pointer (%primitive header-ref array %array-fill-pointer-slot)))
-	(declare (fixnum fill-pointer))
-	(cond ((< fill-pointer 1)
-	       (error "Fill-pointer reached 0."))
-	      (t
-	       (let ((fill-pointer (1- fill-pointer)))
-		 (declare (fixnum fill-pointer))
-		 (with-array-data ((data array) (start) (end))
-		   (declare (ignore end))
-		   (%primitive header-set array %array-fill-pointer-slot
-			       fill-pointer)
-		   (aref data (+ fill-pointer start)))))))
-      (error "~S: Object has no fill pointer." array)))
-
-
-(defun adjust-array (array dimensions &key
-			   (element-type (array-element-type array))
-			   (initial-element nil initial-element-p)
-			   initial-contents fill-pointer
-			   displaced-to displaced-index-offset)
-  "Adjusts the Array's dimensions to the given Dimensions and stuff."
-  (unless (listp dimensions) (setq dimensions (list dimensions)))
-  (cond ((not (array-header-p array))
-	 (error "~S is not an adjustable array." array))
-	((/= (the fixnum (length (the list dimensions)))
-	     (the fixnum (array-rank array)))
-	 (error "Number of dimensions not equal to rank of array."))
-	((not (subtypep element-type (array-element-type array)))
-	 (error "New element type, ~S, is incompatible with old."
-		element-type)))
-  (let ((array-rank (length (the list dimensions))))
-    (declare (fixnum array-rank))
-    (when (and fill-pointer (> array-rank 1))
-      (error "Multidimensional arrays can't have fill pointers."))
-    (cond (initial-contents
-	   (if (or initial-element-p displaced-to)
-	       (error "Initial contents may not be specified with ~
-		       the :initial-element or :displaced-to option."))
-	   (let* ((array-size (array-linear-length dimensions))
-		  (array-data (data-vector-from-inits
-			       dimensions array-size array-rank element-type
-			       initial-contents initial-element
-			       initial-element-p)))
-	     (set-array-header array array-data array-size
-			       (get-new-fill-pointer array array-size
-						     fill-pointer)
-			       0 dimensions nil)))
-	  (displaced-to
-	   (when initial-element ;no initial-contents supplied is already known
-	       (error "The :initial-element option may not be specified ~
-		       with :displaced-to."))
-	   (unless (subtypep element-type (array-element-type displaced-to))
-	     (error "One can't displace an array of type ~S into another of ~
-		     type ~S." element-type (array-element-type displaced-to)))
-	   (let ((displacement (or displaced-index-offset 0))
-		 (array-size (array-linear-length dimensions)))
-	     (declare (fixnum displacement array-size))
-	     (if (< (the fixnum (array-total-size displaced-to))
-		    (the fixnum (+ displacement array-size)))
-		 (error "The :displaced-to array is too small."))
-	     (set-array-header array displaced-to array-size
-			       (get-new-fill-pointer array array-size
-						     fill-pointer)
-			       displacement dimensions t)))
-	  ((= array-rank 1)
-	   (let ((old-length (%primitive header-ref array %array-length-slot))
-		 (new-length (car dimensions))
-		 new-data)
-	     (declare (fixnum old-length new-length))
-	     (with-array-data ((old-data array) (old-start)
-			       (old-end old-length))
-	       (cond ((or (%displacedp array) (< old-length new-length))
-		      (setf new-data
-			    (data-vector-from-inits
-			     dimensions new-length array-rank element-type
-			     initial-contents initial-element
-			     initial-element-p))
-		      (replace new-data old-data
-			       :start2 old-start :end2 old-end))
-		      (t (setf new-data
-			       (%primitive shrink-vector old-data new-length))))
-	       (set-array-header array new-data new-length
-				 (get-new-fill-pointer array new-length
-						       fill-pointer)
-				 0 dimensions nil))))
-	  (t
-	   (let ((old-length (%primitive header-ref array %array-length-slot))
-		 (new-length (array-linear-length dimensions)))
-	     (declare (fixnum old-length new-length))
-	     (with-array-data ((old-data array) (old-start)
-			       (old-end old-length))
-	       (declare (ignore old-end))
-	       (let ((new-data (if (or (%displacedp array)
-				       (> new-length old-length))
-				   (data-vector-from-inits
-				    dimensions new-length array-rank
-				    element-type () initial-element
-				    initial-element-p)
-				   old-data)))
-		 (zap-array-data old-data (array-dimensions array) old-start
-				 new-data dimensions new-length element-type
-				 initial-element initial-element-p)
-		 (set-array-header array new-data new-length
-				   new-length 0 dimensions nil)))))))
-  array)
-
-(defun get-new-fill-pointer (old-array new-array-size fill-pointer)
-  (cond ((not fill-pointer)
-	 (%primitive header-ref old-array %array-fill-pointer-slot))
-	((numberp fill-pointer)
-	 fill-pointer)
-	(t new-array-size)))
-
-(defun shrink-vector (vector new-size)
-  "Destructively alters the Vector, changing its length to New-Size, which
-   must be less than or equal to its current size."
-  (cond ((array-header-p vector)
-	 ;; (%primitive shrink-vector
-	 ;;		(%primitive header-ref vector %array-data-slot)
-	 ;;		new-size)
-	 ;; (%primitive header-set vector %array-length-slot new-size)
-	 ;; Instead of shrinking the vector, just set the fill-pointer field.
-	 (%primitive header-set vector %array-fill-pointer-slot new-size)
-	 vector)
-	(t
-	 (%primitive shrink-vector vector new-size))))
-
-(defun set-array-header (array data length fill-pointer displacement dimensions
-			 &optional displacedp)
-  "Fills in array header with provided information.  Returns array."
-  (%primitive header-set array %array-data-slot data)
-  (%primitive header-set array %array-length-slot length)
-  (%primitive header-set array %array-fill-pointer-slot fill-pointer)
-  (%primitive header-set array %array-displacement-slot displacement)
-  (if (listp dimensions)
-      (do ((index %array-first-dim-slot (1+ index))
-	   (dims dimensions (cdr dims)))
-	  ((null dims))
-	(declare (fixnum index))
-	(%primitive header-set array index (car dims)))
-      (%primitive header-set array %array-first-dim-slot dimensions))
-  (%set-array-displacedp array displacedp)
-  array)
-
-
-
-;;;; ZAP-ARRAY-DATA for ADJUST-ARRAY.
-
-;;; Make a temporary to be used when old-data and new-data are EQ.
-;;;
-(defvar *zap-array-data-temp* (%primitive alloc-g-vector 1000 t))
-
-(defun zap-array-data-temp (length element-type initial-element
-			    initial-element-p)
-  (declare (fixnum length))
-  (when (> length (the fixnum (length *zap-array-data-temp*)))
-    (setf *zap-array-data-temp* (%primitive alloc-g-vector length t)))
-  (when initial-element-p
-    (unless (typep initial-element element-type)
-      (error "~S cannot be used to initialize an array of type ~S."
-	     initial-element element-type))
-    (fill (the simple-vector *zap-array-data-temp*) initial-element :end length))
-  *zap-array-data-temp*)
-
-
-;;; ZAP-ARRAY-DATA  --  Internal.
-;;;
-;;; This does the grinding work for ADJUST-ARRAY.  It zaps the data from the
-;;; Old-Data in an arrangement specified by the Old-Dims to the New-Data in an
-;;; arrangement specified by the New-Dims.  Offset is a displaced offset to be
-;;; added to computed indexes of Old-Data.  New-Length, Element-Type,
-;;; Initial-Element, and Initial-Element-P are used when Old-Data and New-Data
-;;; are EQ; in this case, a temporary must be used and filled appropriately.
-;;; When Old-Data and New-Data are not EQ, New-Data has already been filled
-;;; with any specified initial-element.
-;;;
-(defun zap-array-data (old-data old-dims offset new-data new-dims new-length
-		       element-type initial-element initial-element-p)
-  (declare (list old-dims new-dims))
-  (setq old-dims (nreverse old-dims))
-  (setq new-dims (reverse new-dims))
-  (if (eq old-data new-data)
-      (let ((temp (zap-array-data-temp new-length element-type
-				       initial-element initial-element-p)))
-	(zap-array-data-aux old-data old-dims offset temp new-dims)
-	(dotimes (i new-length) (setf (aref new-data i) (aref temp i))))
-      (zap-array-data-aux old-data old-dims offset new-data new-dims)))
-      
-
-(defun zap-array-data-aux (old-data old-dims offset new-data new-dims)
-  (declare (fixnum offset))
-  (let ((limits (mapcar #'(lambda (x y)
-			    (declare (fixnum x y))
-			    (1- (the fixnum (min x y))))
-			old-dims new-dims)))
-    (macrolet ((bump-index-list (index limits)
-		 `(do ((subscripts ,index (cdr subscripts))
-		       (limits ,limits (cdr limits)))
-		      ((null subscripts) nil)
-		    (cond ((< (the fixnum (car subscripts))
-			      (the fixnum (car limits)))
-			   (rplaca subscripts (1+ (the fixnum (car subscripts))))
-			   (return ,index))
-			  (t (rplaca subscripts 0))))))
-      (do ((index (make-list (length old-dims) :initial-element 0)
-		  (bump-index-list index limits)))
-	  ((null index))
-	(setf (aref new-data (row-major-index-from-dims index new-dims))
-	      (aref old-data
-		    (+ (the fixnum (row-major-index-from-dims index old-dims))
-		       offset)))))))
-
-;;; ROW-MAJOR-INDEX-FROM-DIMS  --  Internal.
-;;;
-;;; This figures out the row-major-order index of an array reference from a
-;;; list of subscripts and a list of dimensions.  This is for internal calls
-;;; only, and the subscripts and dim-list variables are assumed to be reversed
-;;; from what the user supplied.
-;;;
-(defun row-major-index-from-dims (rev-subscripts rev-dim-list)
-  (do ((rev-subscripts rev-subscripts (cdr rev-subscripts))
-       (rev-dim-list rev-dim-list (cdr rev-dim-list))
-       (chunk-size 1)
-       (result 0))
-      ((null rev-dim-list) result)
-    (declare (fixnum chunk-size result))
-    (setq result (+ result
-		    (the fixnum (* (the fixnum (car rev-subscripts))
-				   chunk-size))))
-    (setq chunk-size (* chunk-size (the fixnum (car rev-dim-list))))))
-
-
-
-;;;; Some bit stuff.
- 
-(defun bit (bit-array &rest subscripts)
-  "Returns the bit from the Bit-Array at the specified Subscripts."
-  (apply #'aref bit-array subscripts))
-
-(defun %bitset (bit-array &rest stuff)
-  (apply #'%aset bit-array stuff))
-
-(defun sbit (simple-bit-array &rest subscripts)
-  "Returns the bit from the Simple-Bit-Array at the specified Subscripts."
-  (apply #'aref simple-bit-array subscripts))
-
-(defun %sbitset (bit-array &rest stuff)
-  (apply #'%aset bit-array stuff))
-
-(defun bit-array-same-dimensions-p (array1 array2)
-  (and (= (the fixnum (%primitive header-length array1))
-	  (the fixnum (%primitive header-length array2)))
-       (do ((index %array-first-dim-slot (1+ index))
-	    (length (%primitive header-length array1)))
-	   ((= index length) t)
-	 (declare (fixnum index length))
-	 (if (/= (the fixnum (%primitive header-ref array1 index))
-		 (the fixnum (%primitive header-ref array2 index)))
-	     (return nil)))))
-
-(defun bit-array-boole (array1 array2 op result-array)
-  (if (eq result-array t) (setq result-array array1))
-  (cond ((simple-bit-vector-p array1)
-	 (let ((length (%primitive vector-length array1)))
-	   (declare (fixnum length))
-	   (unless (and (simple-bit-vector-p array2)
-			(= (the fixnum (%primitive vector-length array2)) length))
-	     (error "~S and ~S do not have the same dimensions." array1 array2))
-	   (if result-array
-	       (unless (and (simple-bit-vector-p result-array)
-			    (= (the fixnum (%primitive vector-length result-array))
-			       length))
-		 (error "~S and ~S do not have the same dimensions."
-			array1 result-array))
-	       (setq result-array (%primitive alloc-bit-vector length)))
-	   (%primitive bit-bash array1 array2 result-array op)))
-	(t
-	 (unless (bit-array-same-dimensions-p array1 array2)
-	   (error "~S and ~S do not have the same dimensions." array1 array2))
-	 (if result-array
-	     (unless (bit-array-same-dimensions-p array1 result-array)
-	       (error "~S and ~S do not have the same dimensions."
-		      array1 result-array))
-	     (setq result-array (make-array (array-dimensions array1)
-					    :element-type '(mod 2))))
-	 (with-array-data ((data1 array1) (start1) (end1))
-	   (declare (ignore end1))
-	   (with-array-data ((data2 array2) (start2) (end2))
-	     (declare (ignore end2))
-	     (with-array-data ((data3 result-array) (start3) (end3))
-	       (declare (ignore end3))
-	       (let ((length (%primitive header-ref array1 %array-length-slot)))
-		 (declare (fixnum length))
-		 (do ((index 0 (1+ index))
-		      (index1 start1 (1+ index1))
-		      (index2 start2 (1+ index2))
-		      (index3 start3 (1+ index3)))
-		     ((= index length) result-array)
-		   (declare (fixnum index index1 index2 index3))
-		   (setf (sbit data3 index3)
-			 (boole op (sbit data1 index1)
-				(sbit data2 index2))))))))))
-  result-array)
-
-(defun bit-and (bit-array1 bit-array2 &optional result-bit-array)
-  "Performs a bit-wise logical AND on the elements of Bit-Array1 and Bit-Array2
-  putting the results in the Result-Bit-Array."
-  (bit-array-boole bit-array1 bit-array2 boole-and result-bit-array))
-
-(defun bit-ior (bit-array1 bit-array2 &optional result-bit-array)
-  "Performs a bit-wise logical IOR on the elements of Bit-Array1 and Bit-Array2
-  putting the results in the Result-Bit-Array."
-  (bit-array-boole bit-array1 bit-array2 boole-ior result-bit-array))
-
-(defun bit-xor (bit-array1 bit-array2 &optional result-bit-array)
-  "Performs a bit-wise logical XOR on the elements of Bit-Array1 and Bit-Array2
-  putting the results in the Result-Bit-Array."
-  (bit-array-boole bit-array1 bit-array2 boole-xor result-bit-array))
-
-(defun bit-eqv (bit-array1 bit-array2 &optional result-bit-array)
-  "Performs a bit-wise logical EQV  on the elements of Bit-Array1 and Bit-Array2
-  putting the results in the Result-Bit-Array."
-  (bit-array-boole bit-array1 bit-array2 boole-eqv result-bit-array))
-
-(defun bit-nand (bit-array1 bit-array2 &optional result-bit-array)
-  "Performs a bit-wise logical NAND  on the elements of Bit-Array1 and Bit-Array2
-  putting the results in the Result-Bit-Array."
-  (bit-array-boole bit-array1 bit-array2 boole-nand result-bit-array))
-
-(defun bit-nor (bit-array1 bit-array2 &optional result-bit-array)
-  "Performs a bit-wise logical NOR  on the elements of Bit-Array1 and Bit-Array2
-  putting the results in the Result-Bit-Array."
-  (bit-array-boole bit-array1 bit-array2 boole-nor result-bit-array))
-
-(defun bit-andc1 (bit-array1 bit-array2 &optional result-bit-array)
-  "Performs a bit-wise logical ANDC1 on the elements of Bit-Array1 and Bit-Array2
-  putting the results in the Result-Bit-Array."
-  (bit-array-boole bit-array1 bit-array2 boole-andc1 result-bit-array))
-
-(defun bit-andc2 (bit-array1 bit-array2 &optional result-bit-array)
-  "Performs a bit-wise logical ANDC2 on the elements of Bit-Array1 and Bit-Array2
-  putting the results in the Result-Bit-Array."
-  (bit-array-boole bit-array1 bit-array2 boole-andc2 result-bit-array))
-
-(defun bit-orc1 (bit-array1 bit-array2 &optional result-bit-array)
-  "Performs a bit-wise logical ORC1 on the elements of Bit-Array1 and Bit-Array2
-  putting the results in the Result-Bit-Array."
-  (bit-array-boole bit-array1 bit-array2 boole-orc1 result-bit-array))
-
-(defun bit-orc2 (bit-array1 bit-array2 &optional result-bit-array)
-  "Performs a bit-wise logical ORC2 on the elements of Bit-Array1 and Bit-Array2
-  putting the results in the Result-Bit-Array."
-  (bit-array-boole bit-array1 bit-array2 boole-orc2 result-bit-array))
-
-(defun bit-not (bit-array &optional result-bit-array)
-  "Performs a bit-wise logical NOT in the elements of the Bit-Array putting
-  the results into the Result-Bit-Array."
-  (bit-array-boole bit-array bit-array boole-nor result-bit-array))
diff --git a/code/backq.lisp b/code/backq.lisp
deleted file mode 100644
index 4d40fc3485d750828adf4e396963b40ddf7bcd89..0000000000000000000000000000000000000000
--- a/code/backq.lisp
+++ /dev/null
@@ -1,174 +0,0 @@
-;;; -*- Log: code.log; Mode: Lisp; Package: Lisp -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    BACKQUOTE: Code Spice Lispified by Lee Schumacher.
-;;;
-(in-package 'lisp)
-
-
-;;; The flags passed back by BACKQUOTIFY can be interpreted as follows:
-;;;
-;;;   |`,|: [a] => a
-;;;    NIL: [a] => a		;the NIL flag is used only when a is NIL
-;;;      T: [a] => a		;the T flag is used when a is self-evaluating
-;;;  QUOTE: [a] => (QUOTE a)
-;;; APPEND: [a] => (APPEND . a)
-;;;  NCONC: [a] => (NCONC . a) 
-;;;   LIST: [a] => (LIST . a)
-;;;  LIST*: [a] => (LIST* . a)
-;;;
-;;; The flags are combined according to the following set of rules:
-;;;  ([a] means that a should be converted according to the previous table)
-;;;
-;;;   \ car  ||    otherwise    |    QUOTE or     |     |`,@|      |     |`,.|
-;;;cdr \     ||                 |    T or NIL     |                |		 
-;;;================================================================================
-;;;  |`,|    || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a [d]) | NCONC  (a [d])
-;;;  NIL     || LIST    ([a])   | QUOTE    (a)    | <hair>    a    | <hair>    a
-;;;QUOTE or T|| LIST* ([a] [d]) | QUOTE  (a . d)  | APPEND (a [d]) | NCONC (a [d])
-;;; APPEND   || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a . d) | NCONC (a [d])
-;;; NCONC    || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a [d]) | NCONC (a . d)
-;;;  LIST    || LIST  ([a] . d) | LIST  ([a] . d) | APPEND (a [d]) | NCONC (a [d])
-;;;  LIST*   || LIST* ([a] . d) | LIST* ([a] . d) | APPEND (a [d]) | NCONC  (a [d])
-;;;
-;;;<hair> involves starting over again pretending you had read ".,a)" instead
-;;; of ",@a)"
-
-(defvar *backquote-count* 0  "How deep we are into backquotes")
-(defvar *bq-comma-flag* '(|,|))
-(defvar *bq-at-flag* '(|,@|))
-(defvar *bq-dot-flag* '(|,.|))
-(defvar *bq-vector-flag* '(|bqv|))
-
-
-;; This is the actual character macro.
-(defun backquote-macro (stream ignore)
-  (declare (ignore ignore))
-  (let ((*backquote-count* (1+ *backquote-count*)))
-    (multiple-value-bind (flag thing)
-			 (backquotify (read stream t nil t))
-      (if (eq flag *bq-at-flag*)
-	  (error ",@ after backquote in ~S" thing))
-      (if (eq flag *bq-dot-flag*)
-	  (error ",. after backquote in ~S" thing))
-      (values (backquotify-1 flag thing) 'list))))
-
-(defun comma-macro (stream ignore)
-  (declare (ignore ignore))
-  (unless (> *backquote-count* 0)
-    (when *read-suppress*
-      (return-from comma-macro nil))
-    (error "Comma not inside a backquote."))
-  (let ((c (read-char stream))
-	(*backquote-count* (1- *backquote-count*)))
-    (values
-     (cond ((char= c #\@)
-	    (cons *bq-at-flag* (read stream t nil t)))
-	   ((char= c #\.)
-	    (cons *bq-dot-flag* (read stream t nil t)))
-	   (t (unread-char c stream)
-	      (cons *bq-comma-flag* (read stream t nil t))))
-     'list)))
-
-;;; This does the expansion from table 2.
-(defun backquotify (code)
-  (cond ((atom code)
-	 (cond ((null code) (values nil nil))
-	       ((or (numberp code)
-		    (eq code t))
-		;; Keywords are self evaluating. Install after packages.
-		(values t code))
-	       (t (values 'quote code))))
-	((or (eq (car code) *bq-at-flag*)
-	     (eq (car code) *bq-dot-flag*))
-	 (values (car code) (cdr code)))
-	((eq (car code) *bq-comma-flag*)
-	 (comma (cdr code)))
-	((eq (car code) *bq-vector-flag*)
-	 (multiple-value-bind (dflag d) (backquotify (cdr code))
-	   (values 'vector (backquotify-1 dflag d))))
-	(t (multiple-value-bind (aflag a) (backquotify (car code))
-	     (multiple-value-bind (dflag d) (backquotify (cdr code))
-	       (if (eq dflag *bq-at-flag*)
-		   ;; get the errors later.
-		   (error ",@ after dot in ~S" code))
-	       (if (eq dflag *bq-dot-flag*)
-		   (error ",. after dot in ~S" code))
-	       (cond
-		((eq aflag *bq-at-flag*)
-		 (if (null dflag)
-		     (comma a)
-		     (values 'append
-			     (cond ((eq dflag 'append)
-				    (cons a d ))
-				   (t (list a (backquotify-1 dflag d)))))))
-		((eq aflag *bq-dot-flag*)
-		 (if (null dflag)
-		     (comma a)
-		     (values 'nconc
-			     (cond ((eq dflag 'nconc)
-				    (cons a d))
-				   (t (list a (backquotify-1 dflag d)))))))
-		((null dflag)
-		 (if (memq aflag '(quote t nil))
-		     (values 'quote (list a))
-		     (values 'list (list (backquotify-1 aflag a)))))
-		((memq dflag '(quote t))
-		 (if (memq aflag '(quote t nil))
-		     (values 'quote (cons a d ))
-		     (values 'list* (list (backquotify-1 aflag a)
-					  (backquotify-1 dflag d)))))
-		(t (setq a (backquotify-1 aflag a))
-		   (if (memq dflag '(list list*))
-		       (values dflag (cons a d))
-		       (values 'list*
-			       (list a (backquotify-1 dflag d)))))))))))
-
-;;; This handles the <hair> cases 
-(defun comma (code)
-  (cond ((atom code)
-	 (cond ((null code)
-		(values nil nil))
-	       ((or (numberp code) (eq code 't))
-		(values t code))
-	       (t (values *bq-comma-flag* code))))
-	((eq (car code) 'quote)
-	 (values (car code) (cadr code)))
-	((memq (car code) '(append list list* nconc))
-	 (values (car code) (cdr code)))
-	((eq (car code) 'cons)
-	 (values 'list* (cdr code)))
-	(t (values *bq-comma-flag* code))))
-
-;;; This handles table 1.
-(defun backquotify-1 (flag thing)
-  (cond ((or (eq flag *bq-comma-flag*)
-	     (memq flag '(t nil)))
-	 thing)
-	((eq flag 'quote)
-	 (list  'quote thing))
-	((eq flag 'list*)
-	 (cond ((null (cddr thing))
-		(cons 'cons thing))
-	       (t (cons 'list* thing))))
-	((eq flag 'vector)
-	 (list 'apply '#'vector thing))
-	(t (cons (cdr
-		  (assq flag
-			`((cons . cons) (list . list)
-			  (append . append) (nconc . nconc))))
-		 thing))))
-
-
-
-
-(defun backq-init ()
-  (let ((*readtable* std-lisp-readtable))
-    (set-macro-character #\` #'backquote-macro)
-    (set-macro-character #\, #'comma-macro)))
diff --git a/code/c-call.lisp b/code/c-call.lisp
deleted file mode 100644
index ec27554fca0b2240c69da4399d602bdc0054f439..0000000000000000000000000000000000000000
--- a/code/c-call.lisp
+++ /dev/null
@@ -1,935 +0,0 @@
-;;; -*- Mode: Lisp; Package: EXTENSIONS; Log: code.log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    This file contains stuff used for calling out to C routines that are
-;;; linked into the Lisp process.
-;;;
-;;; Written by Rob MacLachlan.
-;;;
-(in-package "EXTENSIONS" :use '("LISP" "SYSTEM"))
-(import '(lisp::enumeration-info lisp::enumeration-info-size
-				 lisp::enumeration-info-kind
-				 lisp::enumeration-info-offset
-				 lisp::enumeration-info-to
-				 lisp::call-lisp-from-c))
-(export '(c-sizeof def-c-type def-c-record def-c-array def-c-pointer
-		   char unsigned-char short unsigned-short
-		   int unsigned-int long unsigned-long
-		   void def-c-routine def-c-variable
-		   def-c-procedure reset-foreign-pointers))
-
-#-new-compiler
-(eval-when (compile)
-  (setq lisp::*bootstrap-defmacro* t))
-
-(defvar foreign-routines-defined NIL
-  "List of symbol/routine name pairs used to reset code pointers
-  for foreign routines.")
-
-(defvar foreign-variables-defined NIL
-  "List of symbol/variable name pairs used to reset pointers to
-  foreign variables.")
-
-(eval-when (compile load eval)
-
-;;; The C-Type structure is used to represent aspects of C data representations
-;;; that aren't directly implemented by Aliens.
-;;;
-(defstruct c-type
-  ;;
-  ;; A form which is a printable representation of this type.
-  description
-  ;;
-  ;; The size in bits of objects of this type.  NIL if the size is variable.
-  (size nil :type (or unsigned-byte null))
-  ;;
-  ;; The bit alignment used for allocating objects of this type.
-  (alignment nil :type (integer 1 32)))
-
-(defun %print-c-type (s stream d)
-  (declare (ignore d))
-  (format stream "#<C-Type ~S>" (c-type-description s)))
-
-
-;;; A c-type which corresponds directly to an alien type.  The Description is
-;;; the alien type.
-;;;
-(defstruct (primitive-type
-	    (:include c-type)
-	    (:print-function %print-c-type)))
-
-
-;;; The Record-Type represnts a c structure type.
-;;;
-(defstruct (record-type
-	    (:include c-type)
-	    (:print-function %print-c-type))
-  ;;
-  ;; A list of the field descriptions for the fields in the record, in order of
-  ;; increasing bit offset.
-  (fields nil :type list))
-
-
-;;; The Field-Info structure describes a single field in a record.  The Size
-;;; recorded here may be larger than the Size in the Type, since more bits may
-;;; be allocated to the field than are actually necessary to hold a value of
-;;; that type.
-;;;
-(defstruct field-info
-  ;;
-  ;; The symbol name of this field.
-  (name nil :type symbol)
-  ;;
-  ;; The c-type of this field.
-  (type nil :type c-type)
-  ;;
-  ;; The bit offset from the start of the record that this field is located at.
-  (offset nil :type unsigned-byte)
-  ;;
-  ;; The number of bits in this field.
-  (size nil :type unsigned-byte))
-
-
-;;; The Array-Type represents a C array type.
-;;;
-(defstruct (array-type
-	    (:include c-type)
-	    (:print-function %print-c-type))
-  ;;
-  ;; The c-type of the elements in the array.
-  (element-type nil :type c-type)
-  ;;
-  ;; The number of bits used to store each element.  May be larger than the
-  ;; Size in the Element-Type due to padding.
-  (element-size nil :type unsigned-byte))
-
-
-;;; The Pointer-Type represents a C pointer type.
-;;;
-(defstruct (pointer-type
-	    (:include c-type)
-	    (:print-function %print-c-type))
-  ;;
-  ;; The type of object pointed to.
-  (to nil :type c-type))
-
-
-;;; An EQ hashtable from the names of c-types to the structures describing them.
-;;;
-(defvar *c-type-names* (make-hash-table :test #'eq))
-
-;;; Find-Alignment  --  Internal
-;;;
-;;;    Return the bit alignment for an object of the specified Size.
-;;;
-(proclaim '(function find-alignment (unsigned-byte) (integer 1 32)))
-(defun find-alignment (size)
-  (cond ((> size 16) 32)
-	((> size 8) 16)
-	((> size 1) 8)
-	(t 1)))
-
-
-;;; Align-Offset  --  Internal
-;;;
-;;;    Return Offset with enough added to bring it out to the specified
-;;; Alignment.
-;;;
-(proclaim '(function align-offset (unsigned-byte (integer 1 32))
-		     unsigned-byte))
-(defun align-offset (offset alignment)
-  (let ((extra (rem offset alignment)))
-    (if (zerop extra) offset (+ offset (- alignment extra)))))
-
-
-;;; Get-C-Type  --  Internal
-;;;
-;;;    Get the C-Type structure corresponding to the supplied Spec.  If the
-;;; spec is a named type, then just return the info.  Otherwise, the Spec must
-;;; be a primitive Alien type with an obvious size.  If we can't decide the
-;;; Spec, we signal an error.
-;;;
-(proclaim '(function get-c-type (t) c-type))
-(defun get-c-type (spec)
-  (cond ((gethash spec *c-type-names*))
-	((memq spec '(c-procedure short-float long-float))
-	 (let ((size (if (eq spec 'long-float) 64 32)))
-	   (make-primitive-type
-	    :description spec
-	    :size size
-	    :alignment (find-alignment size))))
-	((and (listp spec) (> (length spec) 1)
-	      (symbolp (first spec)))
-	 (case (first spec)
-	   ((signed-byte unsigned-byte)
-	    (let ((size (second spec)))
-	      (make-primitive-type
-	       :description spec
-	       :size size
-	       :alignment (find-alignment size))))
-	   (perq-string
-	    (make-primitive-type
-	     :description spec
-	     :size (* (1+ (second spec)) 8)
-	     :alignment 8))
-	   (null-terminated-string
-	    (make-primitive-type
-	     :description spec
-	     :size (* (second spec) 8)
-	     :alignment 8))
-	   (enumeration
-	    (let* ((name (second spec))
-		   (info (get name 'enumeration-info)))
-	      (unless info
-		(error "~S is not a defined enumeration." name))
-	      (let ((size (enumeration-info-size info)))
-		(make-primitive-type
-		 :description spec
-		 :size size
-		 :alignment (find-alignment size)))))
-	   (alien
-	    (let ((size (third spec)))
-	      (unless size
-		(error "Must specify size in Alien C-Type: ~S." spec))
-	      (make-primitive-type
-	       :description spec
-	       :size size
-	       :alignment (find-alignment size))))
-	   (t
-	    (error "~S is not a known C-Type." spec))))
-	(t (error "Losing C-Type: ~S." spec))))
-
-
-); Eval-When (Compile Load Eval)
-
-
-;;;; Exported type operations:
-
-(eval-when (compile load eval)
-
-;;; Symbolicate  --  Internal
-;;;
-;;;    Concatenate together the names of some strings and symbols, producing
-;;; a symbol in the current package.
-;;;
-(proclaim '(function symbolicate (&rest (or string symbol)) symbol))
-(defun symbolicate (&rest things)
-  (values (intern (reduce #'(lambda (x y)
-			      (concatenate 'string (string x) (string y)))
-			  things))))
-
-); Eval-When (Compile Load Eval)
-
-
-;;; C-Sizeof  --  Public
-;;;
-(proclaim '(function c-sizeof (t) unsigned-byte))
-(defun c-sizeof (spec)
-  "Return the size in bits of the C-Type described by Spec."
-  (c-type-size (get-c-type spec)))
-
-(pushnew 'clc::fold-transform (get 'c-sizeof 'clc::clc-transforms))
-
-
-;;; Def-C-Type  --  Public
-;;;
-(defmacro def-c-type (name spec)
-  "Def-C-Type Name Spec
-  Define Name to be an abbreviation for the C-Type indicated by Spec."
-  `(eval-when (compile load eval)
-     (setf (gethash ',name *c-type-names*) ',(get-c-type spec))
-     ',name))
-
-
-;;; Def-C-Record  --  Public
-;;;
-(defmacro def-c-record (name &rest fields)
-  "Name {(Name Type)}*
-  Define a record C-Type.  Name is the name of the type.  The Fields and Types
-  specify the name and type of each field.  An Alien operator Name-Field is
-  defined to select each field.  The Function Make-Name creates a dynamic alien
-  of the appropriate size and type.  Also a pointer to name type is created, so
-  that you can have pointers to a thing of type name in the definition of name.
-  The name of the pointer type is *name."
-  (let* ((info ())
-	 (pname (symbolicate "*" name))
-	 (pos 0)
-	 (align 0)
-	 (res (make-record-type
-	       :description name
-	       :size NIL
-	       :alignment 1
-	       :fields NIL))
-	 (pres (make-pointer-type
-		:description NIL
-		:size 32
-		:alignment 32
-		:to res)))
-    (setf (gethash name *c-type-names*) res)
-    (setf (gethash pname *c-type-names*) pres)
-    (dolist (field fields)
-      (unless (= (length field) 2)
-	(error "Malformed field specification: ~S." field))
-      (let* ((ftype (second field))
-	     (type (if (eq ftype pname) pname (get-c-type (second field))))
-	     (size (if (eq ftype pname) 32 (c-type-size type)))
-	     (start (align-offset pos (if (eq ftype pname) 32
-					  (c-type-alignment type)))))
-	(push (make-field-info :name (first field)
-			       :type type
-			       :offset start
-			       :size size)
-	      info)
-	(unless size
-	  (error "Variable size field ~A in record ~A not allowd."
-		 (first field) name))
-	(setq pos (+ start size))
-	(setq align (max (find-alignment size) align))))
-
-    (setf (record-type-size res) pos)
-    (setf (record-type-alignment res) align)
-    (setf (record-type-fields res) (nreverse info))
-    (setf (pointer-type-description pres) `(alien ,name ,pos))
-    `(progn
-      (eval-when (compile load eval)
-	(setf (gethash ',name *c-type-names*) ',res)
-	(setf (gethash ',pname *c-type-names*) ',pres))
-      (defun ,(symbolicate "MAKE-" name) ()
-	(make-alien ',name ,(c-type-size res)))
-      (defoperator (,(symbolicate "INDIRECT-" pname)
-		    ,(record-type-description res))
-		   ((pointer ,pname))
-	`(alien-indirect (alien-value ,pointer) ,,pos))
-      ,@(define-record-operators res))))
-
-(eval-when (compile load eval)
-
-;;; Define-Record-Operators  --  Internal
-;;;
-;;;    Compute the operator definitions for accessing the fields in Record.
-;;;
-(proclaim '(function define-record-operators (record-type) list))
-(defun define-record-operators (record)
-  (let ((name (c-type-description record)))
-    (mapcar #'(lambda (x)
-		`(defoperator (,(symbolicate name "-" (field-info-name x))
-			       ,(c-type-description (let ((type (field-info-type x)))
-						      (if (structurep type) type
-							  (get-c-type type)))))
-			      ((rec ,name))
-		  `(alien-index (alien-value ,rec)
-				,,(field-info-offset x)
-				,,(field-info-size x))))
-	    (record-type-fields record))))
-
-); Eval-When (Compile Load Eval)
-
-
-;;; Def-C-Array  --  Public
-;;;
-(defmacro def-c-array (name element-type &optional size)
-  "Def-C-Array Name Element-Type [Size]
-  Define Name to be an array C-Type with the specified Element-Type.  If size
-  is not specified, then it is a variable size array."
-  (let* ((eltype (get-c-type element-type))
-	 (elalign (c-type-alignment eltype))
-	 (elsize (align-offset (c-type-size eltype) elalign))
-	 (elts (eval size))
-	 (res (make-array-type :description name
-			       :size (if elts (* elsize elts) nil)
-			       :alignment elalign
-			       :element-type eltype
-			       :element-size elsize)))
-    `(progn
-      (eval-when (compile load eval)
-	(setf (gethash ',name *c-type-names*) ',res))
-
-      (defun ,(symbolicate "MAKE-" name)
-	     ,(if elts () '(size))
-	(make-alien ',name ,(if elts (* elsize elts) `(* ,elsize size))))
-
-      (defoperator (,(symbolicate name "-REF")
-		    ,(c-type-description eltype))
-		   ((array ,name) i)
-	`(alien-index (alien-value ,array) (* ,,elsize ,i) ,,elsize)))))
-
-
-;;; Def-C-Pointer  --  Public
-;;;
-(defmacro def-c-pointer (name to)
-  "Def-C-Pointer Name To
-  Define a pointer C-Type which points to an object of type To."
-  (let* ((type (get-c-type to))
-	 (res (make-pointer-type
-	       :description `(alien ,(c-type-description type)
-				    ,@(when (c-type-size type)
-					`(,(c-type-size type))))
-	       :size 32
-	       :alignment 32
-	       :to type)))
-    `(progn
-      (eval-when (compile load eval)
-	(setf (gethash ',name *c-type-names*) ',res))
-      (defoperator (,(symbolicate "INDIRECT-" name)
-		    ,(c-type-description type))
-		   ((pointer ,name)
-		    ,@(unless (c-type-size type)
-			'(size)))
-	`(alien-indirect (alien-value ,pointer)
-			 ,,(or (c-type-size type) 'size))))))
-
-;;; Some trivial builtin types...
-;;;  
-(setf (gethash 'port *c-type-names*)
-      (make-primitive-type :description 'port
-			   :size 32
-			   :alignment 32))
-
-(setf (gethash 'string-char *c-type-names*)
-      (make-primitive-type :description 'string-char
-			   :size 8
-			   :alignment 8))
-
-(setf (gethash 'boolean *c-type-names*)
-      (make-primitive-type :description 'boolean
-			   :size 1
-			   :alignment 1))
-
-(setf (gethash 'system-area-pointer *c-type-names*)
-      (make-primitive-type :description 'system-area-pointer
-			   :size 32
-			   :alignment 32))
-
-
-;;; Some more standard types:
-
-(def-c-type char (signed-byte 8))
-(def-c-type unsigned-char (unsigned-byte 8))
-(def-c-type short (signed-byte 16))
-(def-c-type unsigned-short (unsigned-byte 16))
-(def-c-type int (signed-byte 32))
-(def-c-type unsigned-int (unsigned-byte 32))
-(def-c-type long (signed-byte 32))
-(def-c-type unsigned-long (unsigned-byte 32))
-
-
-
-(defstruct (routine-info
-	    (:print-function
-	     (lambda (s stream d)
-	       (declare (ignore d))
-	       (format stream "#<Routine-Info ~S>" (routine-info-name s)))))
-  ;;
-  ;; String name of the routine and symbol name of the interface function.
-  (name "" :type string)
-  (function-name nil :type symbol)
-  ;;
-  ;; Symbol name of the variable holding the code pointer for the routine.
-  (code nil :type symbol)
-  ;;
-  ;; The number of words of arguments.
-  (arg-size 0 :type unsigned-byte)
-  ;;
-  ;; The global Alien var that we build the arguments in.  This is also the
-  ;; type of the Alien.
-  (arg-alien nil :type symbol)
-  ;;
-  ;; The number of words of stack allocated for reference args.
-  (result-size 0 :type unsigned-byte)
-  ;;
-  ;;  Similar to Arg-Alien, but we receive results in it.
-  (result-alien nil :type symbol)
-  ;;
-  ;; List of Arg-Info structures.
-  (args nil :type list)
-  ;;
-  ;; The specified return-type for the function value.  Null if Void was
-  ;; specified.
-  (return-type nil :type (or c-type null)))
-
-
-(defstruct arg-info
-  ;;
-  ;; Symbol name of the arg.
-  (name nil :type symbol)
-  ;;
-  ;; C-Type describing the actual argument to the routine.
-  (type nil :type c-type)
-  ;;
-  ;; Specified mode and options.
-  mode
-  options
-  ;;
-  ;; Names of the operators that access this arg in the Args and Results
-  ;; Aliens.
-  (operator nil :type symbol)
-  (result-operator nil :type symbol)
-  )
-
-
-;;;
-;;;    A list of top-level forms that are emitted before the Defun.  This is
-;;; built in reverse order.
-;;;
-(defvar *output-forms*)
-
-(defmacro def-c-routine (name (return-type &key) &rest specs)
-  "Def-C-Routine Name (Return-Type Option*)
-                    {(Arg-Name Arg-Type [Mode] Arg-Option*)}*
-
-  Define a foreign interface function for the routine with the specified string
-  Name.  Normally the interface function is named by interning the uppercased
-  name in the current package.  A different interface function name may be
-  specified by using a list (Name Function-Name) in the place of Name.
-  
-  Return-Type is the C-Type for the C function return value.  Void may be used
-  to specify a function with no result.
-
-  The remaining forms specifiy individual arguments that are passed to the
-  routine.  Arg-Name is a symbol that names the argument, primarily for
-  documentation.  Arg-Type is the C-Type of the argument.  Mode specifies the
-  say that the argument is passed.
-
-  :In
-        An :In argument is simply passed by value.  The value to be passed is
-        obtained from argument(s) to the interface function.  No values are
-        returned for :In arguments.  This is the default mode.
-
-  :Out
-        The specified argument type must be a pointer to a fixed sized object.
-        A pointer to a preallocated object is passed to the routine, and the
-        the object is accessed on return, with the value(s) being returned from
-        the interface function.
-
-  :Copy
-        Similar to :In, except that the argument values are stored in a
-        preallocated object, and a pointer to the object is passed instead of
-        the values themselves.
-
-  :In-Out
-        A combination of :Out and :Copy.  A pointer to the argument is passed,
-        with the object being initialized from supplied argument(s) and
-        return value(s) being determined by accessing the object on return."
-
-  (let ((info (make-routine-info)))
-    (cond ((stringp name)
-	   (setf (routine-info-name info) name)
-	   (setf (routine-info-function-name info)
-		 (intern (string-upcase name))))
-	  ((and (listp name) (= (length name) 2)
-		(stringp (first name)) (symbolp (second name)))
-	   (setf (routine-info-name info) (first name))
-	   (setf (routine-info-function-name info) (second name)))
-	  (t
-	   (error "Malformed routine name specification: ~S." name)))
-
-    (let ((arg-info ()))
-      (dolist (spec specs)
-	(unless (and (listp spec) (>= (length spec) 2))
-	  (error "Bad argument spec: ~S." spec))
-	(let ((arg-name (first spec))
-	      (arg-type (get-c-type (second spec)))
-	      (mode (or (third spec) :in))
-	      (options (cdddr spec)))
-	  (when (oddp (length options))
-	    (error "Odd number of options in ~S." spec))
-	  (unless (symbolp arg-name)
-	    (error "Arg name is not a symbol: ~S." arg-name))
-	  (push (make-arg-info :name arg-name :type arg-type
-			       :mode mode :options options)
-		arg-info)))
-
-      (setf (routine-info-args info) (nreverse arg-info)))
-
-    (unless (eq return-type 'void)
-      (setf (routine-info-return-type info) (get-c-type return-type)))
-
-    (let ((*output-forms* ()))
-      (link-routine-entry info)
-      (allocate-arguments info)
-      (multiple-value-bind (arg-names stores value-names values binds)
-			   (access-arguments info)
-	`(progn
-	   (compiler-let ((*alien-eval-when* '(compile eval)))
-	     ,@(nreverse *output-forms*))
-	   (defun ,(routine-info-function-name info) ,arg-names
-	     ,(make-doc-string info value-names)
-	     (alien-bind (,@(when (routine-info-arg-alien info)
-			      `((args ,(routine-info-arg-alien info))))
-			    ,@(when (routine-info-result-alien info)
-				`((results ,(routine-info-result-alien info)))))
-			 ,@stores
-		(let ((return-value
-		       (%primitive call-foreign
-				   ,(routine-info-code info)
-				   ,(if (routine-info-arg-alien info)
-					'(alien-sap (alien-value args)) 0)
-				   ,(truncate (+ (routine-info-arg-size info)
-						 31) 32))))
-		  return-value
-		  (let* ,binds
-		    (values
-		     ,@(when (routine-info-return-type info)
-			 `(,(coerce-from-integer (routine-info-return-type info)
-						 'return-value)))
-		     ,@values))))))))))
-
-
-;;; Allocate-Argument, Allocate-Result  --  Internal
-;;;
-;;;    Allocate storage for an argument of the specified Type for the routine
-;;; specified by Info.  Name is the name of the argument.  Stuff is pushed onto
-;;; *Output-Forms* as needed.  Allocate-Result is the same except that it
-;;; allocates stuff in the result Alien.
-;;;
-(proclaim '(ftype (function (routine-info c-type symbol) symbol)
-		  allocate-argument allocate-result))
-(defun allocate-argument (info type name)
-  (multiple-value-bind (operator size)
-		       (allocate-field (routine-info-arg-alien info)
-				       (routine-info-arg-size info)
-				       type name)
-    (setf (routine-info-arg-size info) size)
-    operator))
-;;;
-(defun allocate-result (info type name)
-  (multiple-value-bind (operator size)
-		       (allocate-field (routine-info-result-alien info)
-				       (routine-info-result-size info)
-				       type name)
-    (setf (routine-info-result-size info) size)
-    operator))
-
-;;; Allocate-Field  --  Internal
-;;;
-;;;    Pad Size up to the next 32 bit boundry, then create an operator that
-;;; accesses a field of the specified type.  We return the operator name and
-;;; the new amount of stuff allocated.
-;;;
-(proclaim '(function allocate-field (symbol unsigned-byte c-type symbol)
-		     (values symbol unsigned-byte)))
-(defun allocate-field (alien size type name)
-  (let ((base (align-offset size 32))
-	(opname (symbolicate alien "-" name))
-	(ctsize (c-type-size type)))
-    (unless ctsize
-      (error "Cannot pass variable size argument: ~S." type))
-    (if (< ctsize 32)
-	(incf base (- 32 ctsize)))
-    (push `(defoperator (,opname ,(c-type-description type))
-			((alien ,alien))
-	     `(alien-index (alien-value ,alien) ,,base
-			   ,,ctsize))
-	  *output-forms*)
-    (values opname (+ ctsize base))))
-
-
-;;; Allocate-Arguments  --  Internal
-;;;
-;;;    Allocate operators and Aliens for the arguments and results.
-;;;
-(proclaim '(function allocate-arguments (routine-info) void))
-(defun allocate-arguments (info)
-  (let ((name (routine-info-function-name info)))
-    (setf (routine-info-arg-alien info) (symbolicate name "-args"))
-    (setf (routine-info-result-alien info) (symbolicate name "-results")))
-
-  (dolist (arg (routine-info-args info))
-    (let ((type (arg-info-type arg))
-	  (name (arg-info-name arg)))
-      (setf (arg-info-operator arg)
-	    (allocate-argument info type name))
-      (ecase (arg-info-mode arg)
-	(:in)
-	((:copy :in-out :out)
-	 (unless (pointer-type-p type)
-	   (error "~S argument ~S, has non-pointer type."
-		  (arg-info-mode arg) name))
-	 (setf (arg-info-result-operator arg)
-	       (allocate-result info (pointer-type-to type) name))
-	 (push `(setf (alien-access (,(arg-info-operator arg)
-				     ,(routine-info-arg-alien info))
-				    'system-area-pointer)
-		      (alien-sap (,(arg-info-result-operator arg)
-				  ,(routine-info-result-alien info))))
-	       *output-forms*)))))
-
-  (macrolet ((foo (s n)
-	       `(cond ((zerop (,s info))
-		       (setf (,n info) nil))
-		      (t
-		       (setq *output-forms*
-			     (nconc *output-forms*
-				    `((defalien ,(,n info) ,(,n info) ,(,s info)))))))))
-    (foo routine-info-arg-size routine-info-arg-alien)
-    (foo routine-info-result-size routine-info-result-alien)))
-
-
-;;; Access-Arguments  --  Internal
-;;;
-;;;    Return stuff to access the argument in a call to the routine specified
-;;; by Info.  Values:
-;;;
-;;; 1] A list of the input argument names.
-;;; 2] A list of input arg storing forms.
-;;; 3] A list of the names of the result values.
-;;; 4] A list of result value forms.
-;;; 5] A list of let* bindings to make around the value forms.
-;;;
-(proclaim '(function access-arguments (routine-info)
-		     (values list list list list)))
-(defun access-arguments (info)
-  (let ((arg-names ())
-	(stores ())
-	(value-names ())
-	(values ())
-	(binds ()))
-    (dolist (arg (routine-info-args info))
-      (let ((mode (arg-info-mode arg)))
-	(when (eq mode :in)
-	  (multiple-value-bind (form names)
-			       (access-one-value
-				(arg-info-type arg)
-				:write
-				`(,(arg-info-operator arg) (alien-value args))
-				(arg-info-name arg))
-	    (setq arg-names (nconc arg-names names))
-	    (setq stores (nconc stores (list form)))))
-
-	(when (member mode '(:copy :in-out))
-	  (multiple-value-bind (form names)
-			       (access-one-value
-				(pointer-type-to (arg-info-type arg))
-				:write
-				`(,(arg-info-result-operator arg) (alien-value results))
-				(arg-info-name arg))
-	    (setq arg-names (nconc arg-names names))
-	    (setq stores (nconc stores (list form)))))
-
-	(when (member mode '(:out :in-out))
-	  (multiple-value-bind (forms names b)
-			       (access-one-value
-				(pointer-type-to (arg-info-type arg))
-				:read
-				`(,(arg-info-result-operator arg) (alien-value results))
-				(arg-info-name arg))
-	    (setq value-names (nconc value-names names))
-	    (setq values (nconc values forms))
-	    (setq binds (nconc binds b))))))
-
-    (values arg-names stores value-names values binds)))
-
-
-;;; Access-One-Value  --  Internal
-;;;
-;;;    Read or write an alien value that is described by a c-type.
-;;; Type	- The C-Type of the field to be accessed.
-;;; Kind	- :read or :write
-;;; Alien	- The Alien expression for the place to access.
-;;; Name	- The name of the field to access.  If :Write, this variable is
-;;;		  bound to the value to store.
-;;;
-;;; Returns values:
-;;;  1] If :read, a list of forms which are to be the values for the arg
-;;;     If :write, a form which does the store.
-;;;  2] A list of the names of the values produced or arguments used.  In
-;;;     the :read case, this is really just documentation.
-;;;  3] If :read, a list of let* binding forms to make around the code.
-;;;
-(proclaim '(function access-one-value (c-type (member :read :write) t symbol)
-		     (values list list list)))
-(defun access-one-value (type kind alien name)
-  (typecase type
-    (primitive-type
-     (values (if (eq kind :read)
-		 `((alien-access ,alien))
-		 `(setf (alien-access ,alien) ,name))
-	     `(,name)))
-    (pointer-type
-     (values (if (eq kind :read)
-		 `((alien-access ,alien 'alien))
-		 `(setf (alien-access ,alien 'system-area-pointer) ,name))
-	     `(,name)))
-    (t
-     (values (if (eq kind :read)
-		 `((copy-alien ,alien))
-		 `(alien-assign ,alien ,name))
-	     `(,name)))))
-
-
-;;; Coerce-From-Integer  --  Internal
-;;;
-;;;    Return a form that converts a 32bit signed integer into the kind of
-;;; object specified by Type.
-;;;
-(proclaim '(function coerce-from-integer (c-type t) t))
-(defun coerce-from-integer (type value)
-  (typecase type
-    (primitive-type
-     (let ((desc (c-type-description type)))
-       (if (atom desc)
-	   (case desc
-	     (port value)
-	     (boolean `(not (zerop ,value)))
-	     (string-char `(code-char ,value))
-	     (system-area-pointer `(int-sap ,value))
-	     (short-float `(int-sap
-			    (logior (ash ,value (- clc::short-float-shift-16))
-				    (ash clc::short-float-4bit-type
-					 (- 32 clc::short-float-shift-16)))))
-	     (t
-	      (error "Don't know how to hack ~S return type." desc)))
-	   (case (first desc)
-	     (signed-byte value)
-	     (unsigned-byte
-	      (if (> (second desc) 31)
-		  `(ldb (byte 32 0) ,value)
-		  value))
-	     (enumeration
-	      (let ((info (get (cadr desc) 'enumeration-info)))
-		(when (null info)
-		  (error "~S is not a defined enumeration." desc))
-		(ecase (enumeration-info-kind info)
-		  (:vector
-		   `(svref ,(enumeration-info-to info)
-			   (+ ,(enumeration-info-offset info) ,value)))
-		  (`(cdr (assoc ,value) ,(enumeration-info-to info))))))
-	     (t
-	      (error "Don't know how to hack ~S return type." desc))))))
-    (pointer-type
-     (let ((to (pointer-type-to type)))
-       (unless (c-type-size to)
-	 (error "Cannot return pointer to unknown size object."))
-       (let ((tds (c-type-description to)))
-	 (if (or (eq tds 'null-terminated-string)
-		 (and (listp tds) (eq (car (the list tds))
-				      'null-terminated-string)))
-	     `(if (eq ,value 0) NIL
-		  (let ((av (lisp::make-alien-value (int-sap ,value) 0
-						    ,(c-type-size to)
-						    ',tds)))
-		    (alien-bind ((s av ,tds))
-		      (alien-access (alien-value s)))))
-	     `(if (eq ,value 0) NIL
-		  (lisp::make-alien-value (int-sap ,value) 0 ,(c-type-size to)
-					  ',tds))))))
-    (t
-     (error "Don't know how to hack ~S return type." type))))
-
-
-;;; Make-Doc-String  --  Internal
-;;;
-;;;    Make a doc string for the interface routine described by Info.  Values
-;;; is a list of the names of the by-reference return values.
-;;;
-(proclaim '(function make-doc-string (routine-info list) string))
-(defun make-doc-string (info values)
-  (let ((*print-pretty* t)
-	(*print-case* :downcase))
-    (format nil "Interface to foreign routine ~S~:[; returns no values.~;~
-	    ~:*, return values:~%  ~A~]"
-	    (routine-info-name info)
-	    (if (routine-info-return-type info)
-		(cons 'return-value values)
-		values))))
-
-;;; Link-Routine-Entry  --  Internal
-;;;
-;;;    Emit stuff needed to look up a foreign routine and stash the code
-;;; pointer in a variable.
-;;;
-(proclaim '(function link-routine-entry (routine-info) void))
-(defun link-routine-entry (info)
-  (let ((name (symbolicate (routine-info-function-name info) "-code"))
-	(item (gensym)))
-    (push `(defparameter ,name (get-code-pointer ,(routine-info-name info)))
-	  *output-forms*)
-    (push `(let ((,item (cons ',name ',(routine-info-name info))))
-	     (when (not (member ,item foreign-routines-defined :test #'equal))
-	       (push ,item foreign-routines-defined)))
-	  *output-forms*)
-    (setf (routine-info-code info) name)))
-
-
-;;; Def-C-Variable defines a global C-Variable, so that it is available to
-;;; Lisp.  It accepts the name of the variable (as a string) and the type
-;;; of the variable.
-
-(defmacro def-c-variable (name type)
-  "Defines a foreign variable so that it is available from Lisp.
-  Name should be a string with the name of the foreign variable and
-  type is the foreign type of the variable."
-  (let* ((symbol (intern (string-upcase name)))
-	 (c-info (get-c-type type))
-	 (c-type (if (primitive-type-p c-info)
-		     (c-type-description c-info)
-		     type))
-	 (c-size (c-type-size c-info))
-	 (item (gensym)))
-    `(let ((,item (cons ',symbol ',name)))
-       (when (not (member ,item foreign-variables-defined :test #'equal))
-	 (push ,item foreign-variables-defined))
-       (defalien ,symbol ,c-type ,c-size
-	 (lisp::sap-int (get-data-pointer ,name))))))
-
-#|
-;;; Def-C-Procedure defines data structures etc. so that C can be passed
-;;; a pointer to a C procedure object which when called will invoke a Lisp
-;;; function.  Def-C-Procedure accepts three arguments: a symbol whose
-;;; value is set to an object which can be written to alien-structures
-;;; that will look like a c procedure object; a number which is a constant
-;;; number of arguments that the C routine will be called with; and a Lisp
-;;; function (an object callable as a function) which should accept the
-;;; same number of arguments and will be called when the C procedure object
-;;; is invoked.
-
-(defmacro def-c-procedure (name nargs lfunc)
-  "Assigns to the value of the symbol name  an object which can be
-  passed to a foreign function as a procedure object.  Nargs is the
-  number of arguments the procedure should accept.  Lfunc is the Lisp
-  function will be called when the procedure is called.  Lfunc should
-  be callable by apply."
-  (let ((var (gensym)))
-  `(defparameter ,name
-     (let ((,var (%primitive alloc-static-g-vector 3)))
-       (setf (svref ,var 0)
-	     (int-sap (logior (ash clc::type-assembler-code
-				   (+ clc::type-shift-16 16))
-			      (get 'clc::call-lisp
-				   'lisp::%loaded-address))))
-       (setf (svref ,var 1) ,nargs)
-       (setf (svref ,var 2) ,lfunc)
-       ,var))))
-
-;;; Call-Lisp-from-C is a Lisp function that gains control when a C
-;;; function calls a procedure object that is defined as above.  It
-;;; wraps an unwind-protect around the call to the function, so that
-;;; if we throw passed it, the c-stack-information will be reset.
-
-(defun call-lisp-from-c (old-c-stack procedure &rest args)
-  (unwind-protect
-    (let ((rv (apply (svref procedure 2) args)))
-	(%primitive return-to-c old-c-stack rv))
-    (%primitive reset-c-stack old-c-stack)))
-
-;;; Reset-foreign-pointers goes through the list of all defined foreign
-;;; functions and variables and sets the pointers to their new location.
-
-(defun reset-foreign-pointers ()
-  "Reset all the code and variable pointers that may have moved."
-  (dolist (x foreign-routines-defined)
-    (setf (symbol-value (car x)) (get-code-pointer (cdr x))))
-  (dolist (x foreign-variables-defined)
-    (setf (lisp::alien-value-sap (symbol-value (car x)))
-	  (get-data-pointer (cdr x)))))
-|#
-
-#-new-compiler
-(eval-when (compile)
-  (setq lisp::*bootstrap-defmacro* nil))
diff --git a/code/char.lisp b/code/char.lisp
deleted file mode 100644
index b1bfccabde0e765e1832964c0265821683a7dbe0..0000000000000000000000000000000000000000
--- a/code/char.lisp
+++ /dev/null
@@ -1,466 +0,0 @@
-;;; -*- Log: code.log; Package: Lisp -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; Character functions for Spice Lisp.  Part of the standard Spice Lisp
-;;; environment.
-;;;
-;;; This file assumes the use of ASCII codes and the specific character formats
-;;; used in Spice Lisp and Vax Common Lisp.  It is optimized for performance
-;;; rather than for portability and elegance, and may have to be rewritten if
-;;; the character representation is changed.
-;;;
-;;; Written by Guy Steele.
-;;; Rewritten by David Dill.
-;;; Hacked up for speed by Scott Fahlman.
-;;; Font support flushed and type hackery rewritten by Rob MacLachlan.
-;;;
-(in-package 'lisp)
-
-(export '(char-code-limit char-font-limit char-bits-limit standard-char-p
-	  graphic-char-p string-char-p alpha-char-p upper-case-p lower-case-p
-	  both-case-p digit-char-p alphanumericp char= char/= char< char>
-	  char<= char>= char-equal char-not-equal char-lessp char-greaterp
-	  char-not-greaterp char-not-lessp character char-code char-bits
-	  char-font code-char make-char char-upcase char-downcase
-	  digit-char char-int int-char char-name name-char char-control-bit
-	  char-meta-bit char-hyper-bit char-super-bit char-bit set-char-bit))
-
-
-;;; Compile some trivial character operations via inline expansion:
-;;;
-(proclaim '(inline standard-char-p
-		   graphic-char-p string-char-p alpha-char-p upper-case-p
-		   lower-case-p both-case-p alphanumericp char-bits
-		   char-int))
-
-
-(defconstant char-code-limit 256
-  "The upper exclusive bound on values produced by CHAR-CODE.")
-(defconstant char-font-limit 1
-  "The upper exclusive bound on values produced by CHAR-FONT.")
-(defconstant char-bits-limit 256
-  "The upper exclusive bound on values produced by CHAR-BITS.")
-
-(defconstant char-control-bit 1
-  "This bit indicates a control character.")
-(defconstant char-meta-bit 2
-  "This bit indicates a meta character.")
-(defconstant char-super-bit 4
-  "This bit indicates a super character.")
-(defconstant char-hyper-bit 8
-  "This bit indicates a hyper character.")
-
-
-(defparameter char-name-alist
-	`(("NULL" . ,(code-char 0))
-	  ("BELL" . ,(code-char 7))
-	  ("BACKSPACE" . ,(code-char 8)) ("BS" . ,(code-char 8))
-	  ("TAB" . ,(code-char 9))
-	  ("LINEFEED" . ,(code-char 10)) ("LF" . ,(code-char 10))
-	  ("VT" . ,(code-char 11))
-	  ("PAGE" . ,(code-char 12)) ("FORM" . ,(code-char 12))
-	  ("FORMFEED" . ,(code-char 12)) ("FF" . ,(code-char 12))
-	  ("RETURN" . ,(code-char 13)) ("NL" . ,(code-char 10))
-	  ("NEWLINE" . ,(code-char 10))  ("CR" . ,(code-char 13))
-	  ("ALTMODE" . ,(code-char 27)) ("ALT" . ,(code-char 27))
-	  ("ESCAPE" . ,(code-char 27)) ("ESC" . ,(code-char 27))
-	  ("SPACE" . ,(code-char 32)) ("SP" . ,(code-char 32))
-	  ("RUBOUT" . ,(code-char 127)) ("DELETE" . ,(code-char 127)))
-  "This is the alist of (character-name . character) for characters
-  with long names.  The first name in this list for a given character
-  is used on typeout and is the preferred form for input.")
-
-
-;;;; Accessor functions:
-
-(defun char-code (char)
-  "Given a character object argument, char-code returns the code attribute
-   of that object as a non-negative integer."
-  (ldb %character-code-byte (char-int char)))
-
-(defun char-bits (char)
-  "Given a character object argument, char-code returns the bits attribute
-   of that object as a non-negative integer."
-  (ldb %character-control-byte (char-int char)))
-
-(defun char-font (char)
-  "Given a character object argument, char-code returns the font attribute
-   of that object as 0."
-  (declare (ignore char))
-  0)
-
-(defun char-int (char)
-  "The argument must be a character-object.  Returns the font, bits, and
-  code fields as a single non-negative integer.  Implementation dependent.
-  Used mostly for hashing."
-  (declare (character char))
-  (%primitive make-fixnum char))
-
-
-(defun int-char (n)
-  "Performs the inverse of char-int.  The argument must be a non-negative
-  integer of the appropriate size.  It is turned into a character object."
-  (declare (type unsigned-byte n))
-  (cond ((or (not (fixnump n))
-	     (not (<= 0 (the fixnum n) %character-int-mask)))
-	 nil)
-	((zerop (ldb %character-control-byte (the fixnum n)))
-	 (%primitive make-immediate-type n %string-char-type))
-	(t
-	 (%primitive make-immediate-type n %bitsy-char-type))))
-
-
-(defun code-char (code &optional (bits 0) (font 0))
-  "All three arguments, must be non-negative integers; the last two are 
-   optional with default values of 0 (for the bits and font attributes).
-   Returns a character object with the specified code, bits, and font,
-   or returns NIL if this is not possible."
-  (cond ((not (and (< -1 code char-code-limit) (zerop font))) nil)
-	((zerop bits) (code-char code))
-	((< -1 bits char-bits-limit)
-	 (%primitive make-immediate-type 
-		     (dpb bits %character-control-byte code)
-		     %bitsy-char-type))
-	(t nil)))
-
-
-(defun character (object)
-  "Coerces its argument into a character object if possible.  Accepts
-  characters, strings and symbols of length 1, and integers."
-  (typecase object
-    (character object)
-    (integer (int-char object))
-    (string (if (= 1 (the fixnum (length (the string object))))
-		(char object 0)
-		(error "String is not of length one: ~S" object)))
-    (symbol (if (= 1 (the fixnum (length (symbol-name object))))
-		(schar (symbol-name object) 0)
-		(error "Symbol name is not of length one: ~S" object)))
-    (t
-     (error "~S cannot be coerced to a character."))))
-
-
-(defun make-char (char &optional (bits 0) (font 0))
-  "Replaces the bits and font attributes of the specified character with
-  those supplied by the user as fixnums.  Bits and font both default to 0."
-  (declare (character char))
-  (and (< -1 bits char-bits-limit)
-       (zerop font)
-       (int-char (dpb bits %character-control-byte (char-code char)))))
-
-
-(defun char-name (char)
-  "Given a character object, char-name returns the name for that
-  object (a symbol)."
-  (car (rassoc char char-name-alist)))
-
-
-(defun name-char (name)
-  "Given an argument acceptable to string, name-char returns a character
-  object whose name is that symbol, if one exists.  Otherwise, () is returned."
-  (cdr (assoc (string name) char-name-alist :test #'string-equal)))
-
-
-(defun char-bit (char name)
-  "Returns T if the named bit is set in character object CHAR.  Else,
-  returns NIL.  Legal names are :CONTROL, :META, :HYPER, and :SUPER."
-  (logtest (case name
-	     (:control char-control-bit)
-	     (:meta char-meta-bit)
-	     (:hyper char-hyper-bit)
-	     (:super char-super-bit))
-	   (char-bits char)))
-
-
-(defun set-char-bit (char name newvalue)
-  "Returns a character just like CHAR except that the named bit is
-  set or cleared, according to whether NEWVALUE is non-null or NIL.
-  Legal bit names are :CONTROL, :META, :HYPER, and :SUPER."
-  (let ((bit (case name
-	      (:control char-control-bit)
-	      (:meta char-meta-bit)
-	      (:hyper char-hyper-bit)
-	      (:super char-super-bit)
-	      (t 0))))
-    (code-char (char-code char)
-	       (if newvalue
-		   (logior bit (char-bits char))
-		   (logand (lognot bit) (char-bits char)))
-	       (char-font char))))
-
-
-;;;; Predicates:
-
-(defun standard-char-p (char)
-  "The argument must be a character object.  Standard-char-p returns T if the
-   argument is a standard character -- one of the 95 ASCII printing characters
-   or <return>."
-  (declare (character char))
-  (and (typep char 'string-char)
-       (let ((n (char-code (the string-char char))))
-	 (or (< 31 n 127)
-	     (= n 13)
-	     (= n 10)))))
-
-
-(defun graphic-char-p (char)
-  "The argument must be a character object.  Graphic-char-p returns T if the
-  argument is a printing character (space through ~ in ASCII), otherwise
-  returns ()."
-  (declare (character char))
-  (and (typep char 'string-char)
-       (< 31
-	  (char-code (the string-char char))
-	  127)))
-
-
-(defun string-char-p (char)
-  "The argument must be a character object.  String-char-p returns T if the
-   argument can be stored in a string."
-  (declare (character char))
-  (typep char 'string-char))
-
-
-(defun alpha-char-p (char)
-  "The argument must be a character object.  Alpha-char-p returns T if the
-   argument is an alphabetic character, A-Z or a-z; otherwise ()."
-  (declare (character char))
-  (let ((m (char-code char)))
-    (or (< 64 m 91) (< 96 m 123))))
-
-
-(defun upper-case-p (char)
-  "The argument must be a character object; upper-case-p returns T if the
-   argument is an upper-case character, () otherwise."
-  (declare (character char))
-  (< 64
-     (char-code char)
-     91))
-
-
-(defun lower-case-p (char)
-  "The argument must be a character object; lower-case-p returns T if the 
-   argument is a lower-case character, () otherwise."
-  (declare (character char))
-  (< 96
-     (char-code char)
-     123))
-
-
-(defun both-case-p (char)
-  "The argument must be a character object.  Both-case-p returns T if the
-  argument is an alphabetic character and if the character exists in
-  both upper and lower case.  For ASCII, this is the same as Alpha-char-p."
-  (declare (character char))
-  (let ((m (char-code char)))
-    (or (< 64 m 91) (< 96 m 123))))
-
-
-(defun digit-char-p (char &optional (radix 10.))
-  "If char is a digit in the specified radix, returns the fixnum for
-  which that digit stands, else returns NIL.  Radix defaults to 10
-  (decimal)."
-  (declare (character char))
-  (let ((m (- (char-code char) 48)))
-    (cond ((<= radix 10.)
-	   ;; Special-case decimal and smaller radices.
-	   (if (and (>= m 0) (< m radix))  m  nil))
-	  ;; Cannot handle radix past Z.
-	  ((> radix 36)
-	   (error "~S too large to be an input radix."  radix))
-	  ;; Digits 0 - 9 are used as is, since radix is larger.
-	  ((and (>= m 0) (< m 10)) m)
-	  ;; Check for upper case A - Z.
-	  ((and (>= (setq m (- m 7)) 10) (< m radix)) m)
-	  ;; Also check lower case a - z.
-	  ((and (>= (setq m (- m 32)) 10) (< m radix)) m)
-	  ;; Else, fail.
-	  (t nil))))
-
-
-(defun alphanumericp (char)
-  "Given a character-object argument, alphanumericp returns T if the
-   argument is either numeric or alphabetic."
-  (declare (character char))
-  (let ((m (char-code char)))
-    (or (< 47 m 58) (< 64 m 91) (< 96 m 123))))
-
-
-(defun char= (character &rest more-characters)
-  "Returns T if all of its arguments are the same character."
-  (do ((clist more-characters (cdr clist)))
-      ((atom clist) T)
-    (unless (eq (car clist) character) (return nil))))
-
-
-(defun char/= (character &rest more-characters)
-  "Returns T if no two of its arguments are the same character."
-  (do* ((head character (car list))
-	(list more-characters (cdr list)))
-       ((atom list) T)
-    (unless (do* ((l list (cdr l)))                  ;inner loop returns T 
-		 ((atom l) T)			     ; iff head /= rest.
-	      (if (eq head (car l)) (return nil)))
-      (return nil))))
-
-
-(defun char< (character &rest more-characters)
-  "Returns T if its arguments are in strictly increasing alphabetic order."
-  (do* ((c character (car list))
-	(list more-characters (cdr list)))
-       ((atom list) T)
-    (unless (< (char-int c)
-	       (char-int (car list)))
-      (return nil))))
-
-
-(defun char> (character &rest more-characters)
-  "Returns T if its arguments are in strictly decreasing alphabetic order."
-  (do* ((c character (car list))
-	(list more-characters (cdr list)))
-       ((atom list) T)
-    (unless (> (char-int c)
-	       (char-int (car list)))
-      (return nil))))
-
-
-(defun char<= (character &rest more-characters)
-  "Returns T if its arguments are in strictly non-decreasing alphabetic order."
-  (do* ((c character (car list))
-	(list more-characters (cdr list)))
-       ((atom list) T)
-    (unless (<= (char-int c)
-		(char-int (car list)))
-      (return nil))))
-
-
-(defun char>= (character &rest more-characters)
-  "Returns T if its arguments are in strictly non-increasing alphabetic order."
-  (do* ((c character (car list))
-	(list more-characters (cdr list)))
-       ((atom list) T)
-    (unless (>= (char-int c)
-		(char-int (car list)))
-      (return nil))))
-
-
-
-;;; Equal-Char-Code is used by the following functions as a version of char-int
-;;;  which loses font, bits, and case info.
-
-(defmacro equal-char-code (character)
-  `(let ((ch (char-code ,character)))
-     (if (< 96 ch 123) (- ch 32) ch)))
-
-
-
-(defun char-equal (character &rest more-characters)
-  "Returns T if all of its arguments are the same character.
-  Font, bits, and case are ignored."
-  (do ((clist more-characters (cdr clist)))
-      ((atom clist) T)
-    (unless (= (equal-char-code (car clist))
-	       (equal-char-code character))
-      (return nil))))
-
-
-(defun char-not-equal (character &rest more-characters)
-  "Returns T if no two of its arguments are the same character.
-   Font, bits, and case are ignored."
-  (do* ((head character (car list))
-	(list more-characters (cdr list)))
-       ((atom list) T)
-    (unless (do* ((l list (cdr l)))
-		 ((atom l) T)
-	      (if (= (equal-char-code head)
-		     (equal-char-code (car l)))
-		  (return nil)))
-      (return nil))))
-
-
-(defun char-lessp (character &rest more-characters)
-  "Returns T if its arguments are in strictly increasing alphabetic order.
-   Font, bits, and case are ignored."
-  (do* ((c character (car list))
-	(list more-characters (cdr list)))
-       ((atom list) T)
-    (unless (< (equal-char-code c)
-	       (equal-char-code (car list)))
-      (return nil))))
-
-
-(defun char-greaterp (character &rest more-characters)
-  "Returns T if its arguments are in strictly decreasing alphabetic order.
-   Font, bits, and case are ignored."
-  (do* ((c character (car list))
-	(list more-characters (cdr list)))
-       ((atom list) T)
-    (unless (> (equal-char-code c)
-	       (equal-char-code (car list)))
-      (return nil))))
-
-
-(defun char-not-greaterp (character &rest more-characters)
-  "Returns T if its arguments are in strictly non-decreasing alphabetic order.
-   Font, bits, and case are ignored."
-  (do* ((c character (car list))
-	(list more-characters (cdr list)))
-       ((atom list) T)
-    (unless (<= (equal-char-code c)
-		(equal-char-code (car list)))
-      (return nil))))
-
-
-(defun char-not-lessp (character &rest more-characters)
-  "Returns T if its arguments are in strictly non-increasing alphabetic order.
-   Font, bits, and case are ignored."
-  (do* ((c character (car list))
-	(list more-characters (cdr list)))
-       ((atom list) T)
-    (unless (>= (equal-char-code c)
-		(equal-char-code (car list)))
-      (return nil))))
-
-
-
-
-;;;; Miscellaneous functions:
-
-(defun char-upcase (char)
-  "Returns a character with the same bits and font as the input character,
-  converted to upper-case if that is possible."
-  (declare (character char))
-  (cond ((typep char 'string-char)
-	 (char-upcase (the string-char char)))
-	((lower-case-p char)
-	 (int-char (- (char-int char) 32)))
-	(t
-	 char)))
-
-
-(defun char-downcase (char)
-  "Returns a character with the same bits and font as the input character,
-  converted to lower-case if that is possible."
-  (declare (character char))
-  (cond ((typep char 'string-char)
-	 (char-downcase (the string-char char)))
-	((upper-case-p char)
-	 (int-char (+ (char-int char) 32)))
-	(t
-	 char)))
-
-
-(defun digit-char (weight &optional (radix 10) (font 0))
-  "All arguments must be integers.  Returns a character object that
-  represents a digit of the given weight in the specified radix.  Returns
-  NIL if no such character exists.  The character will have the specified
-  font attributes."
-  (and (>= weight 0) (< weight radix) (< weight 36)
-       (code-char (if (< weight 10) (+ 48 weight) (+ 55 weight))
-		  0 font)))
diff --git a/code/clx-ext.lisp b/code/clx-ext.lisp
deleted file mode 100644
index 73f45fa2344ceb3f3f62e7ee37af85bca480bb70..0000000000000000000000000000000000000000
--- a/code/clx-ext.lisp
+++ /dev/null
@@ -1,590 +0,0 @@
-;;; -*- Package: Extensions; Log: code.log; Mode: Lisp -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; Spice Lisp is currently incomplete and under active development.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; This file contains code to extend CLX in the CMU Common Lisp environment.
-;;;
-;;; Written by Bill Chiles and Chris Hoover.
-;;;
-
-(in-package "EXTENSIONS")
-
-(export '(open-clx-display with-clx-event-handling enable-clx-event-handling
-	  disable-clx-event-handling object-set-event-handler
-	  default-clx-event-handler *display-event-handlers*
-	  flush-display-events carefully-add-font-paths
-
-	  serve-key-press serve-key-release serve-button-press
-	  serve-button-release serve-motion-notify serve-enter-notify
-	  serve-leave-notify serve-focus-in serve-focus-out 
-	  serve-exposure serve-graphics-exposure serve-no-exposure
-	  serve-visibility-notify serve-create-notify serve-destroy-notify
-	  serve-unmap-notify serve-map-notify serve-map-request
-	  serve-reparent-notify serve-configure-notify serve-gravity-notify
-	  serve-resize-request serve-configure-request serve-circulate-notify
-	  serve-circulate-request serve-property-notify serve-selection-clear
-	  serve-selection-request serve-selection-notify serve-colormap-notify
-	  serve-client-message))
-
-
-
-;;;; OPEN-CLX-DISPLAY.
-
-(defun open-clx-display (&optional (string (cdr (assoc :display
-						       *environment-list*
-						       :test #'eq))))
-  "Parses a display specification including display and screen numbers.
-   This returns nil when there is no DISPLAY environment variable.  If string
-   is non-nil, and any fields are missing in the specification, this signals an
-   error.  This returns the display and screen objects."
-  (when string
-    (let* ((string (coerce string 'simple-string))
-	   (length (length string))
-	   (host-name "unix")
-	   (display-num nil)
-	   (screen-num nil))
-      (declare (simple-string string))
-      (let ((colon (position #\: string :test #'char=)))
-	(cond ((null colon)
-	       (error "Missing display number in DISPLAY environment variable."))
-	      (t
-	       (unless (zerop colon) (setf host-name (subseq string 0 colon)))
-	       (let* ((start (1+ colon))
-		      (first-dot (position #\. string
-					   :test #'char= :start start)))
-		 (cond ((= start (or first-dot length))
-			(error "Badly formed display number in DISPLAY ~
-				environment variable."))
-		       ((null first-dot)
-			(setf display-num (parse-integer string :start start)))
-		       (t
-			(setf display-num (parse-integer string :start start
-							 :end first-dot))
-			(let* ((start (1+ first-dot))
-			       (second-dot (position #\. string :test #'char=
-						     :start start)))
-			  (cond ((= start (or second-dot length))
-				 (error "Badly formed screen number in ~
-					 DISPLAY environment variable."))
-				(t
-				 (setf screen-num
-				       (parse-integer string :start start
-						      :end second-dot)))))))))))
-      (let ((display (xlib:open-display host-name :display display-num)))
-	(cond (screen-num
-	       (let* ((screens (xlib:display-roots display))
-		      (num-screens (length screens)))
-		 (when (>= screen-num num-screens)
-		   (xlib:close-display display)
-		   (error "No such screen number (~D)." screen-num))
-		 (values display (elt screens screen-num))))
-	      (t
-	       (values display (xlib:display-default-screen display))))))))
-
-
-;;;; Font Path Manipulation
-
-(defun carefully-add-font-paths (display font-pathnames
-					 &optional (operation :append))
-  "Adds the list of font pathnames, Font-Pathnames, to the font path of
-  the server Display but does so carefully by checking to make sure that
-  the font pathnames are not already on the server's font path.  If any
-  of the font pathnames are on the server's font path, they will remain
-  in their current positions.  Operation may be specified as either
-  :prepend or :append and specifies whether to add the additional font
-  pathnames to the beginning or the end of the server's original font
-  path."
-  (let ((font-path (xlib:font-path display))
-	(result ()))
-    (dolist (elt font-pathnames)
-      (let ((font-dir (namestring elt)))
-	(unless (member font-dir font-path :test #'string=)
-	  (push font-dir result))))
-    (when result
-      (ecase operation
-	(:prepend
-	 (setf (xlib:font-path display) (revappend result font-path)))
-	(:append
-	 (setf (xlib:font-path display) (append font-path (nreverse result))))))))
-
-
-
-;;;; Enabling and disabling event handling through SYSTEM:SERVE-EVENT.
-
-(defvar *clx-fds-to-displays* (make-hash-table :test #'eql)
-  "This is a hash table that maps CLX file descriptors to CLX display
-   structures.  For every CLX file descriptor know to SYSTEM:SERVE-EVENT,
-   there must be a mapping from that file descriptor to its CLX display
-   structure when events are handled via SYSTEM:SERVE-EVENT.")
-
-(defvar *display-event-handlers* nil
-  "This is an alist mapping displays to user functions to be called when
-   SYSTEM:SERVE-EVENT notices input on a display connection.  Do not modify
-   this directly; use EXT:ENABLE-CLX-EVENT-HANDLING.  A given display
-   should be represented here only once.")
-
-(defmacro with-clx-event-handling ((display handler) &rest body)
-  "Evaluates body in a context where events are handled for the display
-   by calling handler on the display.  This destroys any previously established
-   handler for display."
-  `(unwind-protect
-       (progn
-	 (enable-clx-event-handling ,display ,handler)
-	 ,@body)
-     (disable-clx-event-handling ,display)))
-
-;;; ENABLE-CLX-EVENT-HANDLING associates the display with the handler in
-;;; *display-event-handlers*.  It also uses SYSTEM:ADD-FD-HANDLER to have
-;;; SYSTEM:SERVE-EVENT call CALL-DISPLAY-EVENT-HANDLER whenever anything shows
-;;; up from the display. Since CALL-DISPLAY-EVENT-HANDLER is called on a
-;;; file descriptor, the file descriptor is also mapped to the display in
-;;; *clx-fds-to-displays*, so the user's handler can be called on the display.
-;;;
-(defun enable-clx-event-handling (display handler)
-  "After calling this, when SYSTEM:SERVE-EVENT notices input on display's
-   connection to the X11 server, handler is called on the display.  Handler
-   is invoked in a dynamic context with an error handler bound that will
-   flush all events from the display and return.  By returning, it declines
-   to handle the error, but it will have cleared all events; thus, entering
-   the debugger will not result in infinite errors due to streams that wait
-   via SYSTEM:SERVE-EVENT for input.  Calling this repeatedly on the same
-   display establishes handler as a new handler, replacing any previous one
-   for display."
-  (check-type display xlib:display)
-  (let ((change-handler (assoc display *display-event-handlers*)))
-    (if change-handler
-	(setf (cdr change-handler) handler)
-	(let ((fd (xlib::display-input-stream display)))
-	  (system:add-fd-handler fd :input #'call-display-event-handler)
-	  (setf (gethash fd *clx-fds-to-displays*) display)
-	  (push (cons display handler) *display-event-handlers*)))))
-
-;;; CALL-DISPLAY-EVENT-HANDLER maps the file descriptor to its display and maps
-;;; the display to its handler.  If we can't find the display, we remove the
-;;; file descriptor using SYSTEM:INVALIDATE-DESCRIPTOR and try to remove the
-;;; display from *display-event-handlers*.  This is necessary to try to keep
-;;; SYSTEM:SERVE-EVENT from repeatedly trying to handle the same event over and
-;;; over.  This is possible since many CMU Common Lisp streams loop over
-;;; SYSTEM:SERVE-EVENT, so when the debugger is entered, infinite errors are
-;;; possible.
-;;;
-(defun call-display-event-handler (file-descriptor)
-  (let ((display (gethash file-descriptor *clx-fds-to-displays*)))
-    (unless display
-      (system:invalidate-descriptor file-descriptor)
-      (setf *display-event-handlers*
-	    (delete file-descriptor *display-event-handlers*
-		    :key #'(lambda (d/h)
-			     (xlib::display-input-stream (car d/h)))))
-      (error "File descriptor ~S not associated with any CLX display.~%~
-                It has been removed from system:serve-event's knowledge."
-	     file-descriptor))
-    (let ((handler (cdr (assoc display *display-event-handlers*))))
-      (unless handler
-	(flush-display-events display)
-	(error "Display ~S not associated with any event handler." display))
-      (handler-bind ((error #'(lambda (condx)
-				(declare (ignore condx))
-				(flush-display-events display))))
-	(funcall handler display)))))
-
-(defun disable-clx-event-handling (display)
-  "Undoes the effect of EXT:ENABLE-CLX-EVENT-HANDLING."
-  (setf *display-event-handlers*
-	(delete display *display-event-handlers* :key #'car))
-  (let ((fd (xlib::display-input-stream display)))
-    (remhash fd *clx-fds-to-displays*)
-    (system:invalidate-descriptor fd)))
-
-
-
-;;;; Object set event handling.
-
-;;; This is bound by OBJECT-SET-EVENT-HANDLER, so DISPATCH-EVENT can clear
-;;; events on the display before signalling any errors.  This is necessary
-;;; since reading on certain CMU Common Lisp streams involves SERVER, and
-;;; getting an error while trying to handle an event causes repeated attempts
-;;; to handle the same event.
-;;;
-(defvar *process-clx-event-display* nil)
-
-(defvar *object-set-event-handler-print* nil)
-
-(proclaim '(declaration values))
-
-(defun object-set-event-handler (display)
-  "This display event handler uses object sets to map event windows cross
-   event types to handlers.  It uses XLIB:EVENT-CASE to bind all the slots
-   of each event, calling the handlers on all these values in addition to
-   the event key and send-event-p.  Describe EXT:SERVE-MUMBLE, where mumble
-   is an event keyword name for the exact order of arguments.
-   :mapping-notify and :keymap-notify events are ignored since they do not
-   occur on any particular window.  After calling a handler, each branch
-   returns t to discard the event.  While the handler is executing, all
-   errors go through a handler that flushes all the display's events and
-   returns.  This prevents infinite errors since the debug and terminal
-   streams loop over SYSTEM:SERVE-EVENT.  This function returns t if there
-   were some event to handle, nil otherwise.  It returns immediately if
-   there is no event to handle."
-  (macrolet ((dispatch (event-key &rest args)
-	       `(multiple-value-bind (object object-set)
-				     (lisp::map-xwindow event-window)
-		  (unless object
-		    (cond ((not (typep event-window 'xlib:window))
-			   (xlib:discard-current-event display)
-			   (warn "Discarding ~S event on non-window ~S."
-				 ,event-key event-window)
-			   (return-from object-set-event-handler nil))
-			  (t
-			   (flush-display-events display)
-			   (error "~S not a known X window.~%~
-			           Received event ~S."
-				  event-window ,event-key))))
-		  (handler-bind ((error #'(lambda (condx)
-					    (declare (ignore condx))
-					    (flush-display-events display))))
-		    (when *object-set-event-handler-print*
-		      (print ,event-key) (force-output))
-		    (funcall (gethash ,event-key
-				      (lisp::object-set-table object-set)
-				      (lisp::object-set-default-handler
-				       object-set))
-			     object ,event-key
-			     ,@args))
-		  (setf result t))))
-    (let ((*process-clx-event-display* display)
-	  (result nil))
-      (xlib:event-case (display :timeout 0)
-	((:KEY-PRESS :KEY-RELEASE :BUTTON-PRESS :BUTTON-RELEASE)
-	     (event-key event-window root child same-screen-p
-	      x y root-x root-y state time code send-event-p)
-	 (dispatch event-key event-window root child same-screen-p
-		   x y root-x root-y state time code send-event-p))
-	(:MOTION-NOTIFY (event-window root child same-screen-p
-			 x y root-x root-y state time hint-p send-event-p)
-	 (dispatch :motion-notify event-window root child same-screen-p
-		   x y root-x root-y state time hint-p send-event-p))
-	(:ENTER-NOTIFY (event-window root child same-screen-p
-			x y root-x root-y state time mode kind send-event-p)
-	 (dispatch :enter-notify event-window root child same-screen-p
-		   x y root-x root-y state time mode kind send-event-p))
-	(:LEAVE-NOTIFY (event-window root child same-screen-p
-			x y root-x root-y state time mode kind send-event-p)
-	 (dispatch :leave-notify event-window root child same-screen-p
-		   x y root-x root-y state time mode kind send-event-p))
-	(:EXPOSURE (event-window x y width height count send-event-p)
-	 (dispatch :exposure event-window x y width height count send-event-p))
-	(:GRAPHICS-EXPOSURE (event-window x y width height count major minor
-			     send-event-p)
-	 (dispatch :graphics-exposure event-window x y width height
-		   count major minor send-event-p))
-	(:NO-EXPOSURE (event-window major minor send-event-p)
-	 (dispatch :no-exposure event-window major minor send-event-p))
-	(:FOCUS-IN (event-window mode kind send-event-p)
-	 (dispatch :focus-in event-window mode kind send-event-p))
-	(:FOCUS-OUT (event-window mode kind send-event-p)
-	 (dispatch :focus-out event-window mode kind send-event-p))
-	(:KEYMAP-NOTIFY ()
-	 (warn "Ignoring keymap notify event.")
-	 (when *object-set-event-handler-print*
-	   (print :keymap-notify) (force-output))
-	 (setf result t))
-	(:VISIBILITY-NOTIFY (event-window state send-event-p)
-	 (dispatch :visibility-notify event-window state send-event-p))
-	(:CREATE-NOTIFY (event-window window x y width height border-width
-			 override-redirect-p send-event-p)
-	 (dispatch :create-notify event-window window x y width height
-		   border-width override-redirect-p send-event-p))
-	(:DESTROY-NOTIFY (event-window window send-event-p)
-	 (dispatch :destroy-notify event-window window send-event-p))
-	(:UNMAP-NOTIFY (event-window window configure-p send-event-p)
-	 (dispatch :unmap-notify event-window window configure-p send-event-p))
-	(:MAP-NOTIFY (event-window window override-redirect-p send-event-p)
-	 (dispatch :map-notify event-window window override-redirect-p
-		   send-event-p))
-	(:MAP-REQUEST (event-window window send-event-p)
-	 (dispatch :map-request event-window window send-event-p))
-	(:REPARENT-NOTIFY (event-window window parent x y override-redirect-p
-			   send-event-p)
-	 (dispatch :reparent-notify event-window window parent x y
-		   override-redirect-p send-event-p))
-	(:CONFIGURE-NOTIFY (event-window window x y width height border-width
-			    above-sibling override-redirect-p send-event-p)
-	 (dispatch :configure-notify event-window window x y width height
-		   border-width above-sibling override-redirect-p
-		   send-event-p))
-	(:GRAVITY-NOTIFY (event-window window x y send-event-p)
-	 (dispatch :gravity-notify event-window window x y send-event-p))
-	(:RESIZE-REQUEST (event-window width height send-event-p)
-	 (dispatch :resize-request event-window width height send-event-p))
-	(:CONFIGURE-REQUEST (event-window window x y width height border-width
-			     stack-mode above-sibling value-mask send-event-p)
-	 (dispatch :configure-request event-window window x y width height
-		   border-width stack-mode above-sibling value-mask
-		   send-event-p))
-	(:CIRCULATE-NOTIFY (event-window window place send-event-p)
-	 (dispatch :circulate-notify event-window window place send-event-p))
-	(:CIRCULATE-REQUEST (event-window window place send-event-p)
-	 (dispatch :circulate-request event-window window place send-event-p))
-	(:PROPERTY-NOTIFY (event-window atom state time send-event-p)
-	 (dispatch :property-notify event-window atom state time send-event-p))
-	(:SELECTION-CLEAR (event-window selection time send-event-p)
-	 (dispatch :selection-notify event-window selection time send-event-p))
-	(:SELECTION-REQUEST (event-window requestor selection target property
-			     time send-event-p)
-	 (dispatch :selection-request event-window requestor selection target
-		   property time send-event-p))
-	(:SELECTION-NOTIFY (event-window selection target property time
-			    send-event-p)
-	 (dispatch :selection-notify event-window selection target property time
-		   send-event-p))
-	(:COLORMAP-NOTIFY (event-window colormap new-p installed-p send-event-p)
-	 (dispatch :colormap-notify event-window colormap new-p installed-p
-		   send-event-p))
-	(:MAPPING-NOTIFY (request)
-	 (warn "Ignoring mapping notify event -- ~S." request)
-	 (when *object-set-event-handler-print*
-	   (print :mapping-notify) (force-output))
-	 (setf result t))
-	(:CLIENT-MESSAGE (event-window format data send-event-p)
-	 (dispatch :client-message event-window format data send-event-p)))
-      result)))
-
-(defun default-clx-event-handler (object event-key event-window &rest ignore)
-  (declare (ignore ignore))
-  (flush-display-events *process-clx-event-display*)
-  (error "No handler for event type ~S on ~S in ~S."
-	 event-key object (lisp::map-xwindow event-window)))
-
-(defun flush-display-events (display)
-  "Dumps all the events in display's event queue including the current one
-   in case this is called from within XLIB:EVENT-CASE, etc."
-  (xlib:discard-current-event display)
-  (xlib:event-case (display :discard-p t :timeout 0)
-    (t () nil)))
-
-
-
-;;;; Key and button service.
-
-(defun serve-key-press (object-set fun)
-  "Associate a method in the object-set with :key-press events.  The method
-   is called on the object the event occurred, event key, event window, root,
-   child, same-screen-p, x, y, root-x, root-y, state, time, code, and
-   send-event-p."
-  (setf (gethash :key-press (lisp::object-set-table object-set)) fun))
-
-(defun serve-key-release (object-set fun)
-  "Associate a method in the object-set with :key-release events.  The method
-   is called on the object the event occurred, event key, event window, root,
-   child, same-screen-p, x, y, root-x, root-y, state, time, code, and
-   send-event-p."
-  (setf (gethash :key-release (lisp::object-set-table object-set)) fun))
-
-(defun serve-button-press (object-set fun)
-  "Associate a method in the object-set with :button-press events.  The method
-   is called on the object the event occurred, event key, event window, root,
-   child, same-screen-p, x, y, root-x, root-y, state, time, code, and
-   send-event-p."
-  (setf (gethash :button-press (lisp::object-set-table object-set)) fun))
-
-(defun serve-button-release (object-set fun)
-  "Associate a method in the object-set with :button-release events.  The
-   method is called on the object the event occurred, event key, event window,
-   root, child, same-screen-p, x, y, root-x, root-y, state, time, code, and
-   send-event-p."
-  (setf (gethash :button-release (lisp::object-set-table object-set)) fun))
-
-
-
-;;;; Mouse service.
-
-(defun serve-motion-notify (object-set fun)
-  "Associate a method in the object-set with :motion-notify events.  The method
-   is called on the object the event occurred, event key, event window, root,
-   child, same-screen-p, x, y, root-x, root-y, state, time, hint-p, and
-   send-event-p."
-  (setf (gethash :motion-notify (lisp::object-set-table object-set)) fun))
-
-(defun serve-enter-notify (object-set fun)
-  "Associate a method in the object-set with :enter-notify events.  The method
-   is called on the object the event occurred, event key, event window, root,
-   child, same-screen-p, x, y, root-x, root-y, state, time, mode, kind,
-   and send-event-p."
-  (setf (gethash :enter-notify (lisp::object-set-table object-set)) fun))
-
-(defun serve-leave-notify (object-set fun)
-  "Associate a method in the object-set with :leave-notify events.  The method
-   is called on the object the event occurred, event key, event window, root,
-   child, same-screen-p, x, y, root-x, root-y, state, time, mode, kind,
-   and send-event-p."
-  (setf (gethash :leave-notify (lisp::object-set-table object-set)) fun))
-
-
-
-;;;; Keyboard service.
-
-(defun serve-focus-in (object-set fun)
-  "Associate a method in the object-set with :focus-in events.  The method
-   is called on the object the event occurred, event key, event window, mode,
-   kind, and send-event-p."
-  (setf (gethash :focus-in (lisp::object-set-table object-set)) fun))
-
-(defun serve-focus-out (object-set fun) 
-  "Associate a method in the object-set with :focus-out events.  The method
-   is called on the object the event occurred, event key, event window, mode,
-   kind, and send-event-p."
-  (setf (gethash :focus-out (lisp::object-set-table object-set)) fun))
-
-
-
-;;;; Exposure service.
-
-(defun serve-exposure (object-set fun)
-  "Associate a method in the object-set with :exposure events.  The method
-   is called on the object the event occurred, event key, event window, x, y,
-   width, height, count, and send-event-p."
-  (setf (gethash :exposure (lisp::object-set-table object-set)) fun))
-
-(defun serve-graphics-exposure (object-set fun)
-  "Associate a method in the object-set with :graphics-exposure events.  The
-   method is called on the object the event occurred, event key, event window,
-   x, y, width, height, count, major, minor, and send-event-p."
-  (setf (gethash :graphics-exposure (lisp::object-set-table object-set)) fun))
-
-(defun serve-no-exposure (object-set fun)
-  "Associate a method in the object-set with :no-exposure events.  The method
-   is called on the object the event occurred, event key, event window, major,
-   minor, and send-event-p."
-  (setf (gethash :no-exposure (lisp::object-set-table object-set)) fun))
-  
-
-
-;;;; Structure service.
-
-(defun serve-visibility-notify (object-set fun)
-  "Associate a method in the object-set with :visibility-notify events.  The
-   method is called on the object the event occurred, event key, event window,
-   state, and send-event-p."
-  (setf (gethash :visibility-notify (lisp::object-set-table object-set)) fun))
-
-(defun serve-create-notify (object-set fun)
-  "Associate a method in the object-set with :create-notify events.  The
-   method is called on the object the event occurred, event key, event window,
-   window, x, y, width, height, border-width, override-redirect-p, and
-   send-event-p."
-  (setf (gethash :create-notify (lisp::object-set-table object-set)) fun))
-
-(defun serve-destroy-notify (object-set fun)
-  "Associate a method in the object-set with :destroy-notify events.  The
-   method is called on the object the event occurred, event key, event window,
-   window, and send-event-p."
-  (setf (gethash :destroy-notify (lisp::object-set-table object-set)) fun))
-
-(defun serve-unmap-notify (object-set fun)
-  "Associate a method in the object-set with :unmap-notify events.  The
-   method is called on the object the event occurred, event key, event window,
-   window, configure-p, and send-event-p."
-  (setf (gethash :unmap-notify (lisp::object-set-table object-set)) fun))
-
-(defun serve-map-notify (object-set fun)
-  "Associate a method in the object-set with :map-notify events.  The
-   method is called on the object the event occurred, event key, event window,
-   window, override-redirect-p, and send-event-p."
-  (setf (gethash :map-notify (lisp::object-set-table object-set)) fun))
-
-(defun serve-map-request (object-set fun)
-  "Associate a method in the object-set with :map-request events.  The
-   method is called on the object the event occurred, event key, event window,
-   window, and send-event-p."
-  (setf (gethash :map-request (lisp::object-set-table object-set)) fun))
-
-(defun serve-reparent-notify (object-set fun)
-  "Associate a method in the object-set with :reparent-notify events.  The
-   method is called on the object the event occurred, event key, event window,
-   window, parent, x, y, override-redirect-p, and send-event-p."
-  (setf (gethash :reparent-notify (lisp::object-set-table object-set)) fun))
-
-(defun serve-configure-notify (object-set fun)
-  "Associate a method in the object-set with :configure-notify events.  The
-   method is called on the object the event occurred, event key, event window,
-   window, x, y, width, height, border-width, above-sibling,
-   override-redirect-p, and send-event-p."
-  (setf (gethash :configure-notify (lisp::object-set-table object-set)) fun))
-
-(defun serve-gravity-notify (object-set fun)
-  "Associate a method in the object-set with :gravity-notify events.  The
-   method is called on the object the event occurred, event key, event window,
-   window, x, y, and send-event-p."
-  (setf (gethash :gravity-notify (lisp::object-set-table object-set)) fun))
-
-(defun serve-resize-request (object-set fun)
-  "Associate a method in the object-set with :resize-request events.  The
-   method is called on the object the event occurred, event key, event window,
-   width, height, and send-event-p."
-  (setf (gethash :resize-request (lisp::object-set-table object-set)) fun))
-
-(defun serve-configure-request (object-set fun)
-  "Associate a method in the object-set with :configure-request events.  The
-   method is called on the object the event occurred, event key, event window,
-   window, x, y, width, height, border-width, stack-mode, above-sibling,
-   value-mask, and send-event-p."
-  (setf (gethash :configure-request (lisp::object-set-table object-set)) fun))
-
-(defun serve-circulate-notify (object-set fun)
-  "Associate a method in the object-set with :circulate-notify events.  The
-   method is called on the object the event occurred, event key, event window,
-   window, place, and send-event-p."
-  (setf (gethash :circulate-notify (lisp::object-set-table object-set)) fun))
-
-(defun serve-circulate-request (object-set fun)
-  "Associate a method in the object-set with :circulate-request events.  The
-   method is called on the object the event occurred, event key, event window,
-   window, place, and send-event-p."
-  (setf (gethash :circulate-request (lisp::object-set-table object-set)) fun))
-
-
-
-;;;; Misc. service.
-
-(defun serve-property-notify (object-set fun)
-  "Associate a method in the object-set with :property-notify events.  The
-   method is called on the object the event occurred, event key, event window,
-   atom, state, time, and send-event-p."
-  (setf (gethash :property-notify (lisp::object-set-table object-set)) fun))
-
-(defun serve-selection-clear (object-set fun)
-  "Associate a method in the object-set with :selection-clear events.  The
-   method is called on the object the event occurred, event key, event window,
-   selection, time, and send-event-p."
-  (setf (gethash :selection-clear (lisp::object-set-table object-set)) fun))
-
-(defun serve-selection-request (object-set fun)
-  "Associate a method in the object-set with :selection-request events.  The
-   method is called on the object the event occurred, event key, event window,
-   requestor, selection, target, property, time, and send-event-p."
-  (setf (gethash :selection-request (lisp::object-set-table object-set)) fun))
-
-(defun serve-selection-notify (object-set fun)
-  "Associate a method in the object-set with :selection-notify events.  The
-   method is called on the object the event occurred, event key, event window,
-   selection, target, property, time, and send-event-p."
-  (setf (gethash :selection-notify (lisp::object-set-table object-set)) fun))
-
-(defun serve-colormap-notify (object-set fun)
-  "Associate a method in the object-set with :colormap-notify events.  The
-   method is called on the object the event occurred, event key, event window,
-   colormap, new-p, installed-p, and send-event-p."
-  (setf (gethash :colormap-notify (lisp::object-set-table object-set)) fun))
-
-(defun serve-client-message (object-set fun)
-  "Associate a method in the object-set with :client-message events.  The
-   method is called on the object the event occurred, event key, event window,
-   format, data, and send-event-p."
-  (setf (gethash :client-message (lisp::object-set-table object-set)) fun))
diff --git a/code/commandline.lisp b/code/commandline.lisp
deleted file mode 100644
index 2ae87e6af6fb8aa3f18d03f2586ce7aad517d816..0000000000000000000000000000000000000000
--- a/code/commandline.lisp
+++ /dev/null
@@ -1,188 +0,0 @@
-;;; -*- Mode: Lisp; Package: Extensions; Log: code.log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; Stuff to eat the command line passed to us from the shell.
-;;; Written by Bill Chiles.
-;;;
-
-(in-package "EXTENSIONS")
-(export '(*command-line-words* *command-line-switches*
-	  *command-switch-demons* *command-line-utility-name*
-	  *command-line-strings* cmd-switch-string command-line-switch-p
-	  cmd-switch-name cmd-switch-value cmd-switch-words command-line-switch
-	  defswitch cmd-switch-arg get-command-line-switch))
-
-(defvar *command-line-switches* ()
-  "A list of cmd-switch's representing the arguments used to invoke
-  this process.")
-
-(defvar *command-line-utility-name* ""
-  "The string name that was used to invoke this process.")
-
-(defvar *command-line-words* ()
-  "A list of words between the utility name and the first switch.")
-
-(defvar *command-line-strings* ()
-  "A list of strings obtained from the command line that invoked this process.")
-
-(defvar *command-switch-demons* ()
-  "An Alist of (\"argument-name\" . demon-function)")
-
-
-
-(defstruct (command-line-switch (:conc-name cmd-switch-)
-				(:constructor make-cmd-switch
-					      (name value words))
-				(:print-function print-command-line-switch))
-  name         		;the name of the switch
-  value                 ;the value of that switch
-  words                 ;random words dangling between switches assigned to the
-                        ;preceeding switch
-  )
-
-(defun print-command-line-switch (object stream n)
-  (declare (ignore n))
-  (write-string "#<Command Line Switch " stream)
-  (prin1 (cmd-switch-name object) stream)
-  (let ((value (cmd-switch-value object))
-	(words (cmd-switch-words object)))
-    (when (or value words) (write-string " -- " stream)
-      (when value (prin1 value stream))
-      (when words (prin1 words stream))))
-  (write-string ">" stream))
-
-
-
-;;;; Processing the command strings.
-
-(defun process-command-strings ()
-  (setq *command-line-words* nil)
-  (setq *command-line-switches* nil)
-  (let ((cmd-strings lisp::lisp-command-line-list)
-	str)
-    (declare (special lisp::lisp-command-line-list))
-    ;; Set some initial variables.
-    ;; 
-    (setf *command-line-strings* (copy-list lisp::lisp-command-line-list))
-    (setf *command-line-utility-name* (pop cmd-strings))
-    (setq str (pop cmd-strings))
-    ;; Set initial command line words.
-    ;; 
-    (loop
-      (unless str (return nil))
-      (unless (zerop (length (the simple-string str)))
-	(when (char= (schar str 0) #\-) 
-	  (setq *command-line-words* (reverse *command-line-words*))
-	  (return nil))
-	(push str *command-line-words*))
-      (setq str (pop cmd-strings)))
-    ;; Set command line switches.
-    ;; 
-    (loop
-      (unless str
-	(return (setf *command-line-switches*
-		      (nreverse *command-line-switches*))))
-      (let* ((position (position #\= (the simple-string str) :test #'char=))
-	     (switch (subseq (the simple-string str) 1 position))
-	     (value (if position
-			(subseq (the simple-string str) (1+ position)
-				(length (the simple-string str))))))
-	(setq str (pop cmd-strings))
-	;; Set this switches words until the next switch.
-	;; 
-	(let (word-list)
-	  (loop
-	    (unless str
-	      (push (make-cmd-switch switch value (nreverse word-list))
-		    *command-line-switches*)
-	      (return nil))
-	    (unless (zerop (length (the simple-string str)))
-	      (when (char= #\- (schar str 0))
-		(push (make-cmd-switch switch value (nreverse word-list))
-		      *command-line-switches*)
-		(return nil))
-	      (push str word-list))
-	    (setq str (pop cmd-strings))))))))
-
-(defun get-command-line-switch (sname)
-  "Accepts the name of a switch as a string and returns the value of the
-   switch.  If no value was specified, then any following words are returned.
-   If there are no following words, then t is returned.  If the switch was not
-   specified, then nil is returned."
-  (let* ((name (if (char= (schar sname 0) #\-) (subseq sname 1) sname))
-	 (switch (find name *command-line-switches*
-		       :test #'string-equal
-		       :key #'cmd-switch-name)))
-    (when switch
-      (or (cmd-switch-value switch)
-	  (cmd-switch-words switch)
-	  T))))
-
-
-
-;;;; Defining Switches and invoking demons.
-
-(defvar *complain-about-illegal-switches* t
-  "When set, invoking switch demons complains about illegal switches that have
-   not been defined with DEFSWITCH.")
-
-;;; This is a list of legal switch names.  DEFSWITCH sets this, and
-;;; INVOKE-SWITCH-DEMONS makes sure all the switches it sees are on this
-;;; list.
-;;;
-(defvar *legal-cmd-line-switches* nil)
-
-;;; INVOKE-SWITCH-DEMONS cdrs down the list of *command-line-switches*.  For
-;;; each switch, it checks to see if there is a switch demon with the same
-;;; name.  If there is, then that demon is called as a function on the switch.
-;;;
-(defun invoke-switch-demons (&optional (switches *command-line-switches*)
-					 (demons *command-switch-demons*))
-  (dolist (switch switches t)
-    (let* ((name (cmd-switch-name switch))
-	   (demon (cdr (assoc name demons :test #'string-equal))))
-      (cond (demon (funcall demon switch))
-	    ((or (member name *legal-cmd-line-switches* :test #'string-equal)
-		 (not *complain-about-illegal-switches*)))
-	    (t (warn "~S is an illegal switch" switch))))))
-
-(defmacro defswitch (name &optional function)
-  "Associates function with the switch name in *command-switch-demons*.  Name
-   is a simple-string that does not begin with a hyphen, unless the switch name
-   really does begin with one.  Function is optional, but defining the switch
-   is necessary to keep invoking switch demons from complaining about illegal
-   switches.  This can be inhibited with *complain-about-illegal-switches*."
-  (let ((gname (gensym))
-	(gfunction (gensym)))
-    `(let ((,gname ,name)
-	   (,gfunction ,function))
-       (check-type ,gname simple-string)
-       (check-type ,gfunction (or symbol function) "a symbol or function")
-       (push ,gname *legal-cmd-line-switches*)
-       (when ,gfunction
-	 (push (cons ,gname ,gfunction) *command-switch-demons*)))))
-
-
-(defun eval-switch-demon (switch)
-  (eval (read-from-string (cmd-switch-arg switch))))
-(defswitch "eval" #'eval-switch-demon)
-
-(defun load-switch-demon (switch)
-  (load (cmd-switch-arg switch)))
-(defswitch "load" #'load-switch-demon)
-
-(defun cmd-switch-arg (switch)
-  (or (cmd-switch-value switch)
-      (car (cmd-switch-words switch))
-      (car *command-line-words*)))
-
-(defswitch "core")
-(defswitch "init")
-(defswitch "noinit")
-(defswitch "hinit")
diff --git a/code/debug-info.lisp b/code/debug-info.lisp
deleted file mode 100644
index e5c49b0797e384a1c5be9e357c6768bdbc1db315..0000000000000000000000000000000000000000
--- a/code/debug-info.lisp
+++ /dev/null
@@ -1,340 +0,0 @@
-;;; -*- Log: code.log; Package: C -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    This file contains structures used for recording debugger information.
-;;;
-(in-package "C")
-
-
-;;;; SC-Offsets:
-;;;
-;;;    We represent the place where some value is stored with a SC-OFFSET,
-;;; which is the SC number and offset encoded as an integer.
-
-(defconstant sc-offset-scn-byte (byte 5 0))
-(defconstant sc-offset-offset-byte (byte 22 5))
-(deftype sc-offset () '(unsigned-byte 27))
-
-(defmacro make-sc-offset (scn offset)
-  `(dpb ,scn sc-offset-scn-byte
-	(dpb ,offset sc-offset-offset-byte 0)))
-
-(defmacro sc-offset-scn (sco) `(ldb sc-offset-scn-byte ,sco))
-(defmacro sc-offset-offset (sco) `(ldb sc-offset-offset-byte ,sco))
-
-
-;;;; Variable length integers:
-;;;
-;;;    The debug info representation makes extensive use of integers encoded in
-;;; a byte vector using a variable number of bytes:
-;;;    0..253 => the integer
-;;;    254 => read next two bytes for integer
-;;;    255 => read next four bytes for integer
-
-;;; READ-VAR-INTEGER  --  Interface
-;;;
-;;;    Given a byte vector Vec and an index variable Index, read a variable
-;;; length integer and advance index.
-;;;
-(defmacro read-var-integer (vec index)
-  (once-only ((val `(aref ,vec ,index)))
-    `(cond ((<= ,val 253)
-	    (incf ,index)
-	    ,val)
-	   ((= ,val 254)
-	    (prog1
-		(logior (aref ,vec (+ ,index 1))
-			(ash (aref ,vec (+ ,index 2)) 8))
-	      (incf ,index 3)))
-	   (t
-	    (prog1
-		(logior (aref ,vec (+ ,index 1))
-			(ash (aref ,vec (+ ,index 2)) 8)
-	      		(ash (aref ,vec (+ ,index 3)) 16)
-	      		(ash (aref ,vec (+ ,index 4)) 24))
-	      (incf ,index 5))))))
-
-
-;;; WRITE-VAR-INTEGER  --  Interface
-;;;
-;;;    Takes an adjustable vector Vec with a fill pointer and pushes the
-;;; variable length representation of Int on the end.
-;;;
-(defun write-var-integer (int vec)
-  (declare (type (unsigned-byte 32) int))
-  (cond ((<= int 253)
-	 (vector-push-extend int vec))
-	(t
-	 (let ((32-p (<= int #xFFFF)))
-	   (vector-push-extend (if 32-p 255 254) vec)
-	   (vector-push-extend (ldb (byte 8 0) int) vec)
-	   (vector-push-extend (ldb (byte 8 8) int) vec)
-	   (when 32-p
-	     (vector-push-extend (ldb (byte 8 16) int) vec)
-	     (vector-push-extend (ldb (byte 8 24) int) vec)))))
-  (undefined-value))
-
-
-
-;;;; Packed strings:
-;;;
-;;;    A packed string is a variable length integer length followed by the
-;;; character codes.
-
-
-;;; READ-VAR-STRING  --  Interface
-;;;
-;;;    Read a packed string from Vec starting at Index, leaving advancing
-;;; Index.
-;;;
-(defmacro read-var-string (vec index)
-  (once-only ((len `(read-var-integer ,vec ,index)))
-    (once-only ((res `(make-string ,len)))
-      `(progn
-	 (%primitive byte-blt ,vec ,index ,res 0 ,len)
-	 (incf ,index ,len)
-	 ,res))))
-
-
-;;; WRITE-VAR-STRING  --  Interface
-;;;
-;;;    Write String into Vec (adjustable, fill-pointer) represented as the
-;;; length (in a var-length integer) followed by the codes of the characters.
-;;;
-(defun write-var-string (string vec)
-  (declare (simple-string string))
-  (let ((len (length string)))
-    (write-var-integer len vec)
-    (dotimes (i len)
-      (vector-push-extend (char-code (schar string i)) vec)))
-  (undefined-value))
-
-
-;;;; Packed bit vectors:
-;;;
-
-;;; READ-PACKED-BIT-VECTOR  --  Interface
-;;;
-;;;    Read the specified number of Bytes out of Vec at Index and convert them
-;;; to a bit-vector.  Index is incremented.
-;;;
-(defmacro read-packed-bit-vector (bytes vec index)
-  (once-only ((n-bytes bytes))
-    (once-only ((n-res `(make-array (* ,n-bytes 8) :element-type 'bit)))
-      `(progn
-	 (%primitive byte-blt ,vec ,index ,n-res 0 ,n-bytes)
-	 (incf ,index ,n-bytes)
-	 ,n-res))))
-
-
-;;; WRITE-PACKED-BIT-VECTOR  --  Interface
-;;;
-;;;    Write Bits out to Vec.  Bits must be an eight-bit multiple.
-;;;
-(defun write-packed-bit-vector (bits vec)
-  (declare (type simple-bit-vector bits))
-  (let ((len (ash (length bits) -3))
-	(start (fill-pointer vec)))
-    (dotimes (i len)
-      (vector-push-extend 0 vec))
-    (lisp::with-array-data ((data vec) (ig1) (ig2))
-      (declare (ignore ig1 ig2))
-      (%primitive byte-blt bits 0 data start (+ start len))))
-  (undefined-value))
-
-
-;;;; Compiled debug variables:
-;;;
-;;;    Compiled debug variables are in a packed binary representation in the
-;;; DEBUG-FUNCTION-VARIABLES:
-;;;    single byte of boolean flags:
-;;;        uninterned name
-;;;	   packaged name
-;;;        environment-live
-;;;        has distinct save location
-;;;        has ID (name not unique in this fun)
-;;;    name length in bytes (as var-length integer)
-;;;    ...name bytes...
-;;;    [if packaged, var-length integer that is package name length]
-;;;     ...package name bytes...]
-;;;    [If has ID, ID as var-length integer]
-;;;    SC-Offset of primary location (as var-length integer)
-;;;    [If has save SC, SC-Offset of save location (as var-length integer)]
-
-(defconstant compiled-debug-variable-uninterned		#b00000001)
-(defconstant compiled-debug-variable-packaged		#b00000010)
-(defconstant compiled-debug-variable-environment-live	#b00000100)
-(defconstant compiled-debug-variable-save-loc-p		#b00001000)
-(defconstant compiled-debug-variable-id-p		#b00010000)
-
-
-;;;; Compiled debug blocks:
-;;;
-;;;    Compiled debug blocks are in a packed binary representation in the
-;;; DEBUG-FUNCTION-BLOCKS:
-;;;    number of successors + bit flags (single byte)
-;;;        elsewhere-p
-;;;    ...ordinal number of each successor in the function's blocks vector...
-;;;    number of locations in this block
-;;;    kind of first location (single byte)
-;;;    delta from previous PC (or from 0 if first location in function.)
-;;;    [offset of first top-level form, if no function TLF-NUMBER]
-;;;    form number of first source form
-;;;    first live mask (length in bytes determined by number of VARIABLES)
-;;;    ...more <kind, delta, top-level form offset, form-number, live-set>
-;;;       tuples...
-
-
-(defconstant compiled-debug-block-nsucc-byte (byte 2 0))
-(defconstant compiled-debug-block-elsewhere-p #b00000100)
-
-(defconstant compiled-code-location-kind-byte (byte 3 0))
-(defconstant compiled-code-location-kinds
-  '#(:unknown-return :known-return :internal-error :non-local-exit
-		     :block-start))
-
-
-
-;;;; Debug function:
-
-(defstruct debug-function)
-
-(defstruct (compiled-debug-function (:include debug-function))
-  ;;
-  ;; The name of this function.  If from a DEFUN, etc., then this is the
-  ;; function name, otherwise it is a descriptive string.
-  (name nil :type (or simple-string cons symbol))
-  ;;
-  ;; The kind of function (same as FUNCTIONAL-KIND):
-  (kind nil :type (member nil :optional :external :top-level :cleanup))
-  ;;
-  ;; A vector of the packed binary representation of variable locations in this
-  ;; function.  These are in alphabetical order by name.  This ordering is used
-  ;; in lifetime info to refer to variables: the first entry is 0, the second
-  ;; entry is 1, etc.  Variable numbers are *not* the byte index at which the
-  ;; representation of the location starts.  The entire vector must be parsed
-  ;; before function, alphabetically sorted by the NAME.  This slot may be NIL
-  ;; to save space.
-  (variables nil :type (or (simple-array (unsigned-byte 8) (*)) null))
-  ;;
-  ;; A vector of the packed binary representation of the COMPILED-DEBUG-BLOCKS
-  ;; in this function, in the order that the blocks were emitted.  The first
-  ;; block is the start of the function.  This slot may be NIL to save space.
-  (blocks nil :type (or (simple-array (unsigned-byte 8) (*)) null))
-  ;;
-  ;; If all code locations in this function are in the same top-level form,
-  ;; then this is the number of that form, otherwise NIL.  If NIL, then each
-  ;; code location represented in the BLOCKS specifies the TLF number.
-  (tlf-number nil :type (or index null))
-  ;;
-  ;; A vector describing the variables that the argument values are stored in
-  ;; within this function.  The locations are represented by the ordinal number
-  ;; of the entry in the VARIABLES.  The locations are in the order that the
-  ;; arguments are actually passed in, but special marker symbols can be
-  ;; interspersed to indicate the orignal call syntax:
-  ;;
-  ;; DELETED
-  ;;    There was an argument to the function in this position, but it was
-  ;;    deleted due to lack of references.  The value cannot be recovered.
-  ;;
-  ;; SUPPLIED-P
-  ;;    The following location is the supplied-p value for the preceding
-  ;;    keyword or optional.
-  ;;
-  ;; REST-ARG
-  ;;    The following location holds the list of rest args.
-  ;;
-  ;; MORE-ARG
-  ;;    The following two locations are the more arg context and count.
-  ;;
-  ;; <any other symbol>
-  ;;    The following location is the value of the keyword argument with the
-  ;;    specified name.
-  ;;
-  ;; This may be NIL to save space.  If no symbols are present, then this will
-  ;; be represented with an I-vector with sufficiently large element type.
-  (arguments nil :type (or (simple-array * (*)) null))
-  ;;
-  ;; There are three alternatives for this slot:
-  ;; 
-  ;; A vector
-  ;;    A vector of SC-OFFSETS describing the return locations.  The
-  ;;    vector element type is chosen to hold the largest element.
-  ;;
-  ;; :Standard 
-  ;;    The function returns using the standard unknown-values convention.
-  ;;
-  ;; :Fixed
-  ;;    The function returns using the a fixed-values convention, but we
-  ;;    elected not to store a vector to save space.
-  (returns :fixed :type (or (simple-array * (*)) (member :standard :fixed)))
-  ;;
-  ;; SC-Offsets describing where the return PC and return CONT are kept.
-  (return-pc nil :type sc-offset)
-  (old-cont nil :type sc-offset)
-  ;;
-  ;; The earliest PC in this function at which the environment is properly
-  ;; initialized (arguments moved from passing locations, etc.)
-  (start-pc nil :type unsigned-byte))
-
-
-(defstruct debug-source
-  ;;
-  ;; This slot indicates where the definition came from:
-  ;;    :File - from a file (Compile-File)
-  ;;    :Lisp - from Lisp (Compile)
-  ;;  :Stream - from a non-file stream (Compile-From-Stream)
-  (from nil :type (member :file :stream :lisp))
-  ;;
-  ;; If :File, the file name, if :Lisp, the lambda compiled, otherwise some
-  ;; descriptive string.
-  (name nil :type (or pathname list simple-string))
-  ;;
-  ;; The universal time that the source was written, or NIL if unavailable.
-  (created nil :type (or unsigned-byte null))
-  ;;
-  ;; The universal time that the source was compiled.
-  (compiled nil :type unsigned-byte)
-  ;;
-  ;; The source path root number of the first form read from this source (i.e.
-  ;; the total number of forms converted previously in this compilation.)
-  (source-root 0 :type index)
-  ;;
-  ;; The file-positions of each truly top-level form read from this file (if
-  ;; applicable).  The vector element type will be chosen to hold the largest
-  ;; element.  May be null to save space.
-  (start-positions nil :type (or (simple-array * (*)) null)))
-
-
-(defstruct debug-info)
-
-(defstruct (compiled-debug-info (:include debug-info))
-  ;;
-  ;; Some string describing something about the code in this component.
-  (name nil :type simple-string)
-  ;;
-  ;; A list of DEBUG-SOURCE structures describing where the code for this
-  ;; component came from, in the order that they were read.
-  ;;
-  ;; *** NOTE: the offset of this slot is wired into the fasl dumper so that it
-  ;; *** can backpatch the source info when compilation is complete.
-  (source nil :type list)
-  ;;
-  ;; The name of the package that DEBUG-FUNCTION-VARIABLES were dumped relative
-  ;; to.  Locations that aren't packaged are in this package.
-  (package nil :type simple-string)
-  ;;
-  ;; A simple-vector of alternating Debug-Function structures and fixnum
-  ;; PCs.  This is used to map PCs to functions, so that we can figure out
-  ;; what function we were running in.  The function is valid between the PC
-  ;; before it (inclusive) and the PC after it (exclusive).  The PCs are in
-  ;; sorted order, so we can binary-search.  We omit the first and last PC,
-  ;; since their values are 0 and the length of the code vector.  Null only
-  ;; temporarily.
-  (function-map nil :type (or simple-vector null)))
diff --git a/code/debug.lisp b/code/debug.lisp
deleted file mode 100644
index 1c1d0c2e0a9490553014d28ad6a7608e5d046682..0000000000000000000000000000000000000000
--- a/code/debug.lisp
+++ /dev/null
@@ -1,442 +0,0 @@
-;;; -*- Mode: Lisp; Package: Debug; Log: code.log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; Spice Lisp Debugger.
-;;;
-;;; Written by Steve Handerson
-;;; Pages 6 through 9 rewritten by Bill Chiles.
-;;;
-;;; **********************************************************************
-;;;
-(in-package "DEBUG" :use '("LISP" "SYSTEM"))
-
-
-(export '(internal-debug *flush-debug-errors* backtrace debug-function
-	  show-all debug-return local show hide argument pc
-	  function-name hide-defaults *debug-print-level*
-	  *debug-print-length* *debug-hidden-functions*))
-
-
-
-(in-package "LISP")
-(export '(invoke-debugger *debugger-hook*))
-
-
-(in-package "DEBUG")
-
-;;;
-;;; Used to communicate to debug-loop that we are at a step breakpoint.
-;;;
-
-(define-condition step-condition (simple-condition))
-  "*Print-level* is bound to this value when debug prints a function call.")
-;;;; Variables, parameters, and constants.
-
-  "*Print-length* is bound to this value when debug prints a function call.")
-  null, use *PRINT-LEVEL*")
-(defvar *inside-debugger-p* nil
-  "This is T while evaluating expressions in the debugger.")
-
-
-(defparameter *debug-print-length* 5
-  "*PRINT-LENGTH* is bound to this value when debug prints a function call.  If
-  null, use *PRINT-LENGTH*.")
-
-(defvar *in-the-debugger* nil
-  "When true, the LIST-LOCATIONS command only displays block start locations.
-  "The default contents of *debug-prompt*."
-   Otherwise, all locations are displayed.")
-
-  "If true, list the code location type in the LIST-LOCATIONS command.")
-
-;;; A list of the types of code-locations that should not be stepped to and
-;;; should not be listed when listing breakpoints.
-;;;
-  "A lambda of no args that prints the debugger prompt on *debug-io*.")
-
-;;; Code locations of the possible breakpoints
-;;;
-Prompt is <stack-level>':'<frame-number>(<command-level>*']').
-Frames look like calls, C signifying a catch frame.
-Expressions get evaluated in the frame's lexical environment,
-  setting * and friends like the top level read-eval-print loop.
-Debug commands do not affect * and friends.
-;;;
-(defvar *breakpoints* nil)
-(declaim (type list *breakpoints*))
-
-;;; A list of breakpoint-info structures of the made and active step
-;;; breakpoints.
-  PUSH     rebinds things in another command level.  Good for hide/show.
-  ABORT    returns to the previous abort restart case.
-;;;
-(defvar *step-breakpoints* nil)  
-;;;
-(defvar *number-of-steps* 1)
-  F  go to numbered frame (prompts if not given).
-  S  search for a specified function (prompts), 
-     an optional number of times (does not prompt).
-  R  searches up the stack, optional times.
-(declaim (type integer *number-of-steps*))
-;;;
-(defvar *default-breakpoint-debug-function* nil)
-  ?              prints all kinds of groovy things.
-  L              lists locals in current function.
-  P, PP          displays current function call.  
-
-Functions/macros for your enjoyment:
- (DEBUG:DEBUG-RETURN expression [frame])  returns with values from an active frame.
- (DEBUG:ARGUMENT n [frame])              shows the nth  supplied argument.
- (DEBUG:PC [frame])                 shows the next pc to be executed.
-;;; Returns a list of the next code-locations following the one passed.  One of
-;;; the *bad-code-location-types* will not be returned.
-;;;
-(defun next-code-locations (code-location)
-    (di:do-debug-block-locations (block-code-location debug-block)
-    (setf kind (di:breakpoint-kind (breakpoint-info-breakpoint place)))
-    (format t "Cannot step, in elsewhere code~%"))
-   (t
-(proclaim '(inline pointer+ stack-ref valid-env-p cstack-pointer-valid-p))
-	  (di:activate-breakpoint bp)
-(defun pointer+ (x y)
-  (%primitive sap+ x (ash y 2)))
-	     (t ,other)))))
-(defun stack-ref (s n)
-  (%primitive read-control-stack (pointer+ s n)))
-
-(defun escape-reg (f n)
-  (stack-ref f (+ n %escape-frame-general-register-start-slot)))
-
-(defun valid-env-p (env)
-  (and (functionp env)
-       (eql (%primitive get-vector-subtype env)
-	    %function-constants-subtype)))
-
-(defun cstack-pointer-valid-p (x)
-  (and (%primitive pointer< x (%primitive current-sp))
-       (not (%primitive pointer< x
-			(%primitive make-immediate-type 0
-				    %control-stack-type)))))
-
-(defun check-valid (x)
-  (unless (cstack-pointer-valid-p x)
-    (error "Invalid control stack pointer."))
-  x)
-
-(defun print-code-and-stuff (env pc)
-  (let* ((code (%primitive header-ref env %function-code-slot))
-	 (code-int (%primitive make-fixnum code)))
-    (format t "~A, Code = #x~X, PC = ~D"
-	    (%primitive header-ref env %function-name-slot)
-	    (logior code-int (ash %code-type 27))
-	    (- (%primitive make-fixnum pc) code-int))))
-
-;;; Backtrace prints a history of calls on the stack.
-
-(defun backtrace (&optional (frames most-positive-fixnum)
-			    (*standard-output* *debug-io*))
-  "Show a listing of the call stack going down from the current frame.  Frames
-  is how many frames to show."
-  (do ((callee (%primitive current-cont)
-	       (stack-ref callee c::old-cont-save-offset))
-       (n 0 (1+ n)))
-      ((or (not (cstack-pointer-valid-p callee))
-	   (>= n frames))
-       (values))
-    (let* ((caller (stack-ref callee c::old-cont-save-offset))
-	   (pc (stack-ref callee c::return-pc-save-offset)))
-      (unless (cstack-pointer-valid-p caller)
-	(return (values)))
-      (let ((env (stack-ref caller c::env-save-offset)))
-	(cond 
-	 ((eql env 0)
-	  (let ((env (escape-reg caller c::env-offset)))
-	    (cond ((eql (%primitive get-type env) %trap-type)
-		   (format t "~%<undefined> ~S"
-			   (escape-reg caller c::call-name-offset))
-		   (setq callee
-			 (check-valid
-			  (escape-reg caller c::old-cont-offset))))
-		  ((valid-env-p env)
-		   (format t "~%<escape frame> ")
-		   (print-code-and-stuff
-		    env
-		    (escape-reg caller c::return-pc-offset))
-		   (setq callee
-			 (check-valid
-			  (stack-ref callee c::old-cont-save-offset))))
-		  (t
-		   (error "Escaping frame ENV invalid?")))))
-	 ((valid-env-p env)
-	  (terpri)
-	  (print-code-and-stuff env pc))
-	 (t
-	  (format t "~%<invalid frame>")))))))
-
-    (make-unprintable-object "unavailable-arg")))
-;;;; DEBUG
-;;; PRINT-FRAME-CALL -- Interface
-;;;
-;;; This prints a representation of the function call causing frame to exist.
-;;; Verbosity indicates the level of information to output; zero indicates just
-   which causes the standard debugger to execute.")
-(defun print-frame-call (frame &key (print-length *print-length*)
-			       (number nil))
-  (let ((*print-length* (or *debug-print-length* print-length))
-(defvar *debug-abort*)
-	(*print-level* (or *debug-print-level* print-level)))
-      (when number
-	(format t "~&~S: " (di:frame-number frame)))
-      (format t "~S" frame))
-     (t
-      (when number
-	(format t "~&~S: " (di:frame-number frame)))
-    (when (>= verbosity 2)
-      (let ((loc (di:frame-code-location frame)))
-	 (*debug-abort* (find-restart 'abort))
-	(handler-case
-	    (progn
-	 (*error-output* *debug-io*))
-
-;;;; Invoke-debugger.
-
-(defvar *debugger-hook* nil
-   which causes the standard debugger to execute.  The system passes the value
-   of this variable to the function because it binds *debugger-hook* to nil
-   around the invocation.")
-    (do ((p restarts (cdr p))
-	 (i 0 (1+ i)))
-	((endp p))
-      (format s "~&  ~D: ~A~%" i (car p)))))
-	 ;; Rebind some printer control variables.
-;;; INTERNAL-DEBUG calls the debug loop.  This is used in DEBUG and
-;;; CONDITIONS::ERROR-ERROR.
-	 (*print-readably* nil)
-;;; SHOW-RESTARTS -- Internal.
-  (let ((*in-the-debugger* T)
-	(*read-suppress* NIL))
-  (when restarts
-    (format s "~&Restarts:~%")
-    (let ((count 0)
-	  (names-used '(nil))
-	  (max-name-len 0))
-      (dolist (restart restarts)
-
-;;; NTH-ARG -- Internal.
-;;;
-;;; This returns the n'th arg as the user sees it from args, the result of
-;;; Interface to *debug-commands*.
-;;; 
-(defmacro def-debug-command (name &rest body)
-    (dolist (ele args (error "Argument specification out of range -- ~S." n))
-      (lambda-list-element-dispatch ele
-      (defun ,fun-name () ,@body)
-      (push (cons ,name #',fun-name) *debug-commands*)
-				      (di:frame-code-location *current-frame*)
-		   (error "Unused rest-arg before n'th argument.")
-(defun debug-command-p (form)
-  (if (symbolp form)
-      (cdr (assoc (symbol-name form) *debug-commands* :test #'string=))))
-(defun debug-command-p (form &optional other-commands)
-	;; Return the right value.
-(defun make-restart-commands (&optional (restarts *debug-restarts*))
-(def-debug-command "FRAME" (&optional
-;;; 
-(def-debug-command "Q"
-	   (princ "You are here."))
-	  ((> n current)
-(def-debug-command "GO"
-	    (setf *current-frame*
-		  (do ((prev *current-frame* lead)
-
-(def-debug-command "PUSH"
-  (invoke-debugger *debug-condition*))
-
-(def-debug-command "ABORT"
-  (invoke-restart *debug-abort*))
-		       (lead (di:frame-down *current-frame*)
-(def-debug-command "RESTART"
-		      ((null lead)
-		       (princ "Bottom of stack encountered.")
-		       prev)
-      (write-string "Restart number: ")
-	  (t
-    (invoke-restart-interactively (nth num *debug-restarts*))))
-;;;
-
-;;;
-;;; 
-(def-debug-command "H"
-  (princ debug-help-string))
-	  (princ "No such restart.")))))
-(def-debug-command "ERROR"
-;;; Information commands.
-;;;
- 
-;;; BACKTRACE-DEBUG-COMMAND binds *inside-debugger-p*, so BACKTRACE will
-;;; not reparse the stack.  *inside-debugger-p* is only bound to non-nil
-;;; when doing evaluations in the debug loop.
-;;; 
-(def-debug-command "BACKTRACE"
-  (let ((*inside-debugger-p* t))
-    (backtrace (read-if-available most-positive-fixnum))))
-   printing a prompting line to continue with output.")
-  (let* ((end -1)
-(defvar *flush-debug-errors* t
-  "Don't recursively call DEBUG on errors while within the debugger if non-nil.")
-	     (let ((code-loc (di:debug-function-start-location place)))
-(def-debug-command "FLUSH"
-  (setf *flush-debug-errors* (not *flush-debug-errors*)))
-
-	(when old-bp-info
-	  (di:deactivate-breakpoint (breakpoint-info-breakpoint old-bp-info))
-	  (setf *breakpoints* (remove old-bp-info *breakpoints*))
-	  (format t "Note: previous breakpoint removed.~%"))
-	(push new-bp-info *breakpoints*))
-      (print-breakpoint-info (first *breakpoints*))
-  (if (not (listen-skip-whitespace in))
-      (princ prompt out))
-
-;;; list all breakpoints set
-(def-debug-command "LIST-BREAKPOINTS" ()
-  (if (listen-skip-whitespace stream)
-	(sort *breakpoints* #'< :key #'breakpoint-info-breakpoint-number))
-  (dolist (info *breakpoints*)
-
-
-
-;;;; Debug-Loop.
-
-(defun debug-loop ()
-  (let ((*debug-command-level* (1+ *debug-command-level*)))
-    (loop
-     (catch 'debug-loop-catcher
-       (handler-bind ((error #'(lambda (condition)
-				 (when *flush-debug-errors*
-				   (clear-input *debug-io*)
-				   (princ condition)
-				   (format t "~&Error flushed ...")
-				   (throw 'debug-loop-catcher nil))
-				 (invoke-debugger condition))))
-	 (funcall *debug-prompt*)
-	 (let* ((exp (read))
-		(cmd-fun (debug-command-p exp))
-		;; Must bind level for restart function created for this abort.
-		(level *debug-command-level*))
-	   (with-simple-restart (abort "Return to debug level ~D." level)
-	     (if cmd-fun
-		 (funcall cmd-fun)
-		 (debug-eval-print exp)))))))))
-
-(defun debug-eval-print (exp)
-  (setq +++ ++ ++ + + - - exp)
-  (let* ((values (multiple-value-list (eval -)))
-	 (*standard-output* *debug-io*))
-    (fresh-line)
-    (if values (prin1 (car values)))
-    (dolist (x (cdr values))
-      (fresh-line)
-      (prin1 x))
-    (setq /// // // / / values)
-    (setq *** ** ** * * (car values))
-    ;; Make sure nobody passes back an unbound marker.
-    (unless (boundp '*)
-      (setq * nil)
-      (fresh-line)
-      (princ "Setting * to NIL -- was unbound marker."))))
-    (print-breakpoint-info info)))
-
-(def-debug-command-alias "LB" "LIST-BREAKPOINTS")
-(def-debug-command-alias "LBP" "LIST-BREAKPOINTS")
-
-;;; remove breakpoint n or all if none given
-(def-debug-command "DELETE-BREAKPOINT" ()
-  (let* ((index (read-if-available nil))
-	 (bp-info
-	  (find index *breakpoints* :key #'breakpoint-info-breakpoint-number)))
-    (cond (bp-info
-	   (di:delete-breakpoint (breakpoint-info-breakpoint bp-info))
-	   (setf *breakpoints* (remove bp-info *breakpoints*))
-	   (format t "Breakpoint ~S removed.~%" index))
-	  (index (format t "Breakpoint doesn't exist."))
-	  (t
-	   (dolist (ele *breakpoints*)
-	     (di:delete-breakpoint (breakpoint-info-breakpoint ele)))
-	   (setf *breakpoints* nil)
-	   (format t "All breakpoints deleted.~%")))))
-
-(def-debug-command-alias "DBP" "DELETE-BREAKPOINT")
-
-
-;;;
-;;; Miscellaneous commands.
-;;;
-
-(def-debug-command "FLUSH-ERRORS" ()
-  (if (setf *flush-debug-errors* (not *flush-debug-errors*))
-      (write-line "Errors now flushed.")
-      (write-line "Errors now create nested debug levels.")))
-
-
-(def-debug-command "DESCRIBE" ()
-  (let* ((curloc (di:frame-code-location *current-frame*))
-	 (debug-fun (di:code-location-debug-function curloc))
-	 (function (di:debug-function-function debug-fun)))
-    (if function
-	(describe function)
-	(format t "Can't figure out the function for this frame."))))
-
-
-;;;
-;;; Editor commands.
-;;;
-
-(def-debug-command "EDIT-SOURCE" ()
-  (unless (typep *terminal-io* 'ed::ts-stream)
-    (error "The debugger's EDIT-SOURCE command only works in slave Lisps ~
-	    connected to a Hemlock editor."))
-  (let* ((wire (ed::ts-stream-wire *terminal-io*))
-	 (location (maybe-block-start-location
-		    (di:frame-code-location *current-frame*)))
-	 (d-source (di:code-location-debug-source location))
-	 (name (di:debug-source-name d-source)))
-    (ecase (di:debug-source-from d-source)
-      (:file
-       (let* ((tlf-offset (di:code-location-top-level-form-offset location))
-	      (local-tlf-offset (- tlf-offset
-				   (di:debug-source-root-number d-source)))
-	      (char-offset (aref (or (di:debug-source-start-positions d-source)
-				     (error "No start positions map."))
-				 local-tlf-offset)))
-	 (wire:remote wire
-	   (ed::edit-source-location (namestring name)
-				     (di:debug-source-created d-source)
-				     tlf-offset local-tlf-offset char-offset
-				     (di:code-location-form-number location)))
-	 (wire:wire-force-output wire)))
-      ((:lisp :stream)
-       (wire:remote wire
-	 (ed::cannot-edit-source-location))
-       (wire:wire-force-output wire)))))
-
-
-
-;;;; Debug loop command utilities.
-
-(defun read-prompting-maybe (prompt &optional (in *standard-input*)
-				    (out *standard-output*))
-  (unless (ext:listen-skip-whitespace in)
-    (princ prompt out)
-    (force-output out))
-  (read in))
-
-(defun read-if-available (default &optional (stream *standard-input*))
-  (if (ext:listen-skip-whitespace stream)
-      (read stream)
-      default))
diff --git a/code/defmacro.lisp b/code/defmacro.lisp
deleted file mode 100644
index aae4551ce1625c04690e3725a86dcb17a54680d5..0000000000000000000000000000000000000000
--- a/code/defmacro.lisp
+++ /dev/null
@@ -1,413 +0,0 @@
-;;; -*- Log: code.log; Mode: Lisp; Package: Lisp -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; This file contains the DEFMACRO function that is part of the
-;;; standard Spice Lisp environment.  For the version that runs in
-;;; Maclisp, see file DEFMACRO.LSP.
-;;;
-;;; Written by Scott Fahlman.
-;;;
-;;; Ugly code, since I can't create macros here and need to stay close to
-;;; Maclisp, so that it will be easy to create a derivitive version to use
-;;; in the cross compiler.  Even without this, there's so much going on
-;;; in the arglist that the code has to be hairy.
-;;;
-(in-package 'lisp)
-(export '(defmacro deftype))
-
-;;; The following specials are used for communication during argument-list
-;;; parsing for a macro or macro-like form.
-
-(proclaim '(special %arg-count %min-args %restp %let-list
-		    %keyword-tests *keyword-package*
-		    %env-arg-name %env-arg-used))
-
-;;; The following is an ugly way of getting an optional arg passed in to
-;;; Analyze1.  Bootstrapping problems in Maclisp force me to do this.
-
-(defvar *default-default* nil)
-(defvar *key-finder* 'find-keyword)
-
-;;; Parse-Defmacro  --  Semi-Public
-;;;
-;;;    Provides a clean interface to ANALYZE1
-;;;
-(defun parse-defmacro (arglist whole code errloc &key (path `(cdr ,whole))
-				((:environment %env-arg-name)) error-string
-				(doc-string-allowed t)
-				((:default-default *default-default*) nil)
-				((:key-finder *key-finder*) 'find-keyword))
-  "For use by macros and macro-like forms that must parse some form
-  according to a defmacro-like argument list, ARGLIST.  The first value
-  returned is a LET* form which binds things and then evalutes the
-  specified CODE.  WHOLE is the variable which is bound to the entire
-  arglist, or NIL if &whole is illegal.  ERRLOC is the name of the function
-  being worked on, for use in error messages.  The second value is a list
-  of ignore declarations for the WHOLE and ENVIRONMENT vars, if appropriate.
-
-  PATH is an access expression for getting to the object to be parsed,
-  which defaults to the CDR of WHOLE.
-  
-  ENVIRONMENT is the place where the macroexpansion environment
-  may be found.  If not supplied, then no &environment arg is allowed.
-
-  ERROR-STRING is used as the argument to error if an incorrect number of
-  arguments are supplied.  The additional error arguments are ERRLOC and
-  the number of arguments supplied.  If not supplied, then no argument count
-  error checking is done.
-
-  DOC-STRING-ALLOWED indicates whether a doc-string should be parsed out of
-  the body.  If one is found, it is returned as the third value.
-  
-  DEFAULT-DEFAULT is the default value for unsupplied arguments, which defaults
-  to NIL.
-
-  KEY-FINDER the function used to do keyword lookup.  It defaults to a function
-  that does the right thing.
-
-  The fourth and fifth values are the minimum and maximum number of arguments
-  allowed, in case you care about that kind of thing.  The fifth value is NIL
-  if there is no upper limit."
-  (multiple-value-bind (body local-decs doc)
-		       (parse-body code nil doc-string-allowed)
-
-    (let ((%arg-count 0) (%min-args 0)
-	  (%restp nil) (%let-list nil)
-	  (%keyword-tests nil)
-	  (%env-arg-used nil))
-      (analyze1 arglist path errloc whole)
-    
-      (let ((arg-test (if error-string (defmacro-arg-test whole)))
-	    (body
-	     `(let* ,(nreverse %let-list)
-		,@ local-decs
-		(progn
-		 ,@ %keyword-tests
-		 ,@ body))))
-	(values
-	 (if arg-test
-	     `(if ,arg-test
-		  (error ,error-string ',errloc (length ,path))
-		  ,body)
-	     body)
-	 ;; Wrong if no error check and arglist composed entirely of &environment
-	 ;; args, but anyone who does that deserves to lose...
-	 `(,@(unless (or arg-test arglist) `((declare (ignore ,whole))))
-	   ,@(when (and %env-arg-name (not %env-arg-used))
-	       `((declare (ignore ,%env-arg-name)))))
-	 doc
-	 %min-args
-	 (if %restp nil %arg-count))))))
-
-;;; ANALYZE1 is implemented as a finite-state machine that steps
-;;; through the legal parts of an arglist in order: required, optional,
-;;; rest, key, and aux.  The results are accumulated in a set of special
-;;; variables: %let-list, %arg-count, %min-args, %restp, and %keyword-tests.
-;;;
-;;; ANALYZE1 is called by ANALYZE-ARGLIST to do the work for required and
-;;; optional args.  It calls other functions if &rest, &key, or &aux are
-;;; encountered.
-
-(defun analyze1 (arglist path errloc whole)
-  (do ((args arglist (cdr args))
-       (optionalp nil)
-       a temp)
-      ((atom args)
-       (cond ((null args) nil)
-	     ;; Varlist is dotted, treat as &rest arg and exit.
-	     (t (push (list args path) %let-list)
-		(setq %restp t))))
-    (setq a (car args))
-    (cond ((eq a '&whole)
-	   (cond ((and whole (cdr args) (symbolp (cadr args)))
-		  (push (list (cadr args) whole) %let-list)
-		  (setq %restp t)
-		  (setq args (cdr args)))
-		 (t (error "Illegal or ill-formed &whole arg in ~S." errloc))))
-	  ((eq a '&environment)
-	   (cond ((and %env-arg-name (cdr args) (symbolp (cadr args)))
-		  (push `(,(cadr args) ,%env-arg-name) %let-list)
-		  (setq %env-arg-used t)
-		  (setq args (cdr args)))
-		 (t (error "Illegal or ill-formed &environment arg in ~S."
-			   errloc))))
-	  ((eq a '&optional)
-	   (and optionalp
-		(cerror "Ignore it."
-			"Redundant &optional flag in varlist of ~S." errloc))
-	   (setq optionalp t))
-	  ((or (eq a '&rest) (eq a '&body))
-	   (return (analyze-rest (cdr args) path errloc whole)))
-	  ((eq a '&key)
-	   ;; Create a rest-arg, then do keyword analysis.
-	   (setq temp (gensym))
-	   (setq %restp t)
-	   (push (list temp path) %let-list)
-	   (return (analyze-key (cdr args) temp errloc)))
-	  ((eq a '&allow-other-keys)
-	   (cerror "Ignore it."
-		   "Stray &ALLOW-OTHER-KEYS in arglist of ~S." errloc))
-	  ((eq a '&aux)
-	   (return (analyze-aux (cdr args) errloc)))
-	  ((not optionalp)
-	   (setq %min-args (1+ %min-args))
-	   (setq %arg-count (1+ %arg-count))
-	   (cond ((symbolp a)
-		  (push `(,a (car ,path)) %let-list))
-		 ((atom a)
-		  (cerror "Ignore this item."
-			  "Non-symbol variable name in ~S." errloc))
-		 (t (let ((%min-args 0) (%arg-count 0) (%restp nil)
-			  (new-whole (gensym)))
-		      (push (list new-whole `(car ,path)) %let-list)
-		      (analyze1 a new-whole errloc new-whole))))
-	   (setq path `(cdr ,path)))
-	  ;; It's an optional arg.
-	  (t (setq %arg-count (1+ %arg-count))
-	     (cond ((symbolp a)
-		    ;; Just a symbol.  Bind to car of path or default.
-		    (push `(,a (cond (,path (car ,path))
-				     (t ,*default-default*)))
-			  %let-list))
-		   ((atom a)
-		    (cerror "Ignore this item."
-			    "Non-symbol variable name in ~S." errloc))
-		   ((symbolp (car a))
-		    ;; Car of list is a symbol.  Bind to car of path or
-		    ;; to default value.
-		    (push `(,(car a)
-			    (cond (,path (car ,path))
-				  (t ,(cond ((> (length a) 1) (cadr a))
-					    (t *default-default*)))))
-			  %let-list)
-		    ;; Handle supplied-p variable, if any.
-		    (and (> (length a) 2)
-			 (push `(,(caddr a) (not (null ,path))) %let-list)))
-		   ;; Then destructure arg against contents of this gensym.
-		   (t (setq temp (gensym))
-		      (push `(,temp
-			      (cond (,path (car ,path))
-				    (t ,(cond ((cddr a) (cadr a))
-					      (t *default-default*)))))
-			    %let-list)
-		      (let ((%min-args 0) (%arg-count 0) (%restp nil))
-			(analyze1 (car a) temp errloc nil))
-		      ;; Handle supplied-p variable if any.
-		      (and (> (length a) 2)
-			   (push `(,(caddr a) (not (null ,path))) %let-list))))
-	     (setq path `(cdr ,path))))))
-
-
-;;; This deals with the portion of the arglist following any &rest flag.
-
-(defun analyze-rest (arglist path errloc whole)
-  (when (atom arglist)
-    (error "Bad &rest or &body arg in ~S." errloc))
-  (prog ((rest-arg (car arglist))
-	 (more (cdr arglist)))
-    (cond ((symbolp rest-arg)
-	   (push (list rest-arg path) %let-list))
-	  ((and (consp rest-arg) (> (length (the list rest-arg)) 1))
-	   (unless %env-arg-name
-	     (error "Hairy &body not allowed when no environment available."))
-	   (let ((decls-var (second rest-arg))
-		 (doc-var (third rest-arg))
-		 (n-body (gensym)) (n-decls (gensym)) (n-doc (gensym)))
-	     (setq rest-arg (first rest-arg))
-	     (when doc-var (push doc-var %let-list))
-	     (push decls-var %let-list)
-	     (push `(,rest-arg
-		     (multiple-value-bind (,n-body ,n-decls ,n-doc)
-					  (parse-body ,path ,%env-arg-name
-						      ,(not (null doc-var)))
-		       (setq ,decls-var ,n-decls)
-		       ,(if doc-var `(setq ,doc-var ,n-doc) n-doc)
-		       ,n-body))
-		   %let-list)))
-	  (t
-	   (error "Bad &rest or &body arg in ~S." errloc)))
-		 
-    (setq %restp t)
-    TRY-AGAIN
-    (cond ((null more) nil)
-	  ((atom more)
-	   (cerror "Ignore the illegal terminator."
-		   "Dotted arglist terminator after &rest arg in ~S." errloc))
-	  ((eq (car more) '&key)
-	   (analyze-key (cdr more) rest-arg errloc))
-	  ((eq (car more) '&aux)
-	   (analyze-aux (cdr more) errloc))
-	  ((eq (car more) '&allow-other-keys)
-	   (cerror "Ignore it."
-		   "Stray &ALLOW-OTHER-KEYS in arglist of ~S." errloc))
-	  ((eq (cadr arglist) '&whole)
-	   (cond ((and whole (cdr more) (symbolp (cadr more)))
-		  (push (list (cadr more) whole) %let-list)
-		  (setq more (cddr more))
-		  (go try-again))
-		 (t (error "Ill-formed or illegal &whole arg in ~S."
-			   errloc))))
-	  ((eq (cadr arglist) '&environment)
-	   (cond ((and %env-arg-name (cdr more) (symbolp (cadr more)))
-		  (push `(,(cadr more) ,%env-arg-name) %let-list)
-		  (setq %env-arg-used t)
-		  (setq more (cddr more))
-		  (go try-again))
-		 (t (error "Ill-formed or illegal &environment arg in ~S."
-			   errloc)))))))
-
-;;; Analyze stuff following &aux.
-
-(defun analyze-aux (arglist errloc)
-  (do ((args arglist (cdr args)))
-      ((null args))
-    (cond ((atom args)
-	   (cerror "Ignore the illegal terminator."
-		   "Dotted arglist after &AUX in ~S." errloc)
-	   (return nil))
-	  ((atom (car args))
-	   (push (list (car args) nil) %let-list))
-	  (t (push (list (caar args) (cadar args)) %let-list)))))
-
-
-;;; Handle analysis of keywords, perhaps with destructuring over the keyword
-;;; variable.  Assumes the remainder of the calling form has already been
-;;; bound to the variable passed in as RESTVAR.
-
-(defun analyze-key (arglist restvar errloc)
-  (let ((temp (gensym))
-	(check-keywords t)
-	(keywords-seen nil))
-    (push temp %let-list)
-    (do ((args arglist (cdr args))
-	 a k sp-var temp1)
-	((atom args)
-	 (cond ((null args) nil)
-	       (t (cerror "Ignore the illegal terminator."
-			  "Dotted arglist after &key in ~S." errloc))))
-      (setq a (car args))
-      (cond ((eq a '&allow-other-keys)
-	     (setq check-keywords nil))
-	    ((eq a '&aux)
-	     (return (analyze-aux (cdr args) errloc)))
-	    ;; Just a top-level variable.  Make matching keyword.
-	    ((symbolp a)
-	     (setq k (make-keyword a))
-	     (push `(,a (cond ((setq ,temp (,*key-finder* ',k ,restvar))
-			       (car ,temp))
-			      (t nil)))
-		   %let-list)
-	     (push k keywords-seen))
-	    ;; Filter out error that might choke defmacro.
-	    ((atom a)
-	     (cerror "Ignore this item."
-		     "~S -- non-symbol variable name in arglist of ~S."
-		     a errloc))
-	    ;; Deal with the common case: (var [init [svar]]) 
-	    ((symbolp (car a))
-	     (setq k (make-keyword (car a)))
-	     ;; Deal with supplied-p variable, if any.
-	     (cond ((and (cddr a) (symbolp (caddr a)))
-		    (setq sp-var (caddr a))
-		    (push (list sp-var nil) %let-list))
-		   (t (setq sp-var nil)))
-	     (push `(,(car a)
-		     (cond ((setq ,temp (,*key-finder* ',k ,restvar))
-			    ,@(and sp-var `((setq ,sp-var t)))
-			    (car ,temp))
-			   (t ,(cadr a))))
-		   %let-list)
-	     (push k keywords-seen))
-	    ;; Filter out more error cases that might kill defmacro.
-	    ((or (atom (car a)) (not (keywordp (caar a))) (atom (cdar a)))
-	     (cerror "Ignore this item."
-		     "~S -- ill-formed keyword arg in ~S." (car a) errloc))
-	    ;; Next case is ((:key var) [init [supplied-p]]).
-	    ((symbolp (cadar a))
-	     (setq k (caar a))
-	     ;; Deal with supplied-p variable, if any.
-	     (cond ((and (cddr a) (symbolp (caddr a)))
-		    (setq sp-var (caddr a))
-		    (push (list sp-var nil) %let-list))
-		   (t (setq sp-var nil)))
-	     (push `(,(cadar a)
-		     (cond ((setq ,temp (,*key-finder* ',k ,restvar))
-			    ,@(and sp-var `((setq ,sp-var t)))
-			    (car ,temp))
-			   (t ,(cadr a))))
-		   %let-list)
-	     (push k keywords-seen))
-	    ;; Same case, but must destructure the "variable".
-	    (t (setq k (caar a))
-	       (setq temp1 (gensym))
-	       (cond ((and (cddr a) (symbolp (caddr a)))
-		      (setq sp-var (caddr a))
-		      (push (list sp-var nil) %let-list))
-		     (t (setq sp-var nil)))
-	       (push `(,temp1
-		       (cond ((setq ,temp (,*key-finder* ',k ,restvar))
-			      ,@(and sp-var `((setq ,sp-var t)))
-			      (car ,temp))
-			     (t ,(cadr a))))
-		     %let-list)
-	       (push k keywords-seen)
-	       (let ((%min-args 0) (%arg-count 0) (%restp nil))
-		      (analyze1 (cadar a) temp1 errloc nil)))))
-    (and check-keywords
-	 (push `(keyword-test ,restvar ',keywords-seen) %keyword-tests))))
-	    
-
-;;; Functions that must be around when the macros produced by DEFMACRO are
-;;; expanded.
-
-(defun make-keyword (s)
-  "Takes a non-keyword symbol S and returns the corresponding keyword."
-  (intern (symbol-name s) *keyword-package*))
-
-
-(defun find-keyword (keyword keylist)
-  "If keyword is present in the keylist, return a list of its argument.
-  Else, return NIL."
-  (do ((l keylist (cddr l)))
-      ((atom l) nil)
-    (cond ((atom (cdr l))
-	   (cerror "Stick a NIL on the end and go on."
-		   "Unpaired item in keyword portion of macro call.")
-	   (rplacd l (list nil))
-	   (return nil))
-	  ((eq (car l) keyword) (return (list (cadr l)))))))
-
-
-(defun keyword-test (keylist legal)
-  "Check whether all keywords in a form are legal.  KEYLIST is the portion
-  of the calling form containing keywords.  LEGAL is the list of legal
-  keywords.  If the keyword :allow-other-keyws is present in KEYLIST,
-  just return without complaining about anything."
-  (cond ((memq ':allow-other-keys keylist) nil)
-	(t (do ((kl keylist (cddr kl)))
-	       ((atom kl) nil)
-	     (cond ((memq (car kl) legal))
-		   (t (cerror "Ignore it."
-			      "~S illegal or unknown keyword." (car kl))))))))
-
-;;; Return a form which tests whether an illegal number of arguments 
-;;; have been supplied.  Args is the name of the variable to which
-;;; the arglist is bound.
-;;;
-(defun defmacro-arg-test (args)
-  (cond ((and (zerop %min-args) %restp) nil)
-	((zerop %min-args)
-	 `(> (length ,args) ,(1+ %arg-count)))
-	(%restp
-	 `(< (length ,args) ,(1+ %min-args)))
-	((= %min-args %arg-count)
-	 `(not (= (length ,args) ,(1+ %min-args))))
-	(t
-	 `(or (> (length ,args) ,(1+ %arg-count))
-	      (< (length ,args) ,(1+ %min-args))))))
diff --git a/code/defstruct.lisp b/code/defstruct.lisp
deleted file mode 100644
index 7206cbd7ebbc2f07d65e1ec204a367828b6efab8..0000000000000000000000000000000000000000
--- a/code/defstruct.lisp
+++ /dev/null
@@ -1,594 +0,0 @@
-;;; -*- Log: code.log; Package: C -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; Defstruct structure definition package (Mark II).
-;;; Written by Skef Wholey and Rob MacLachlan.
-;;;
-(in-package 'c)
-(export '(lisp::defstruct) "LISP")
-
-;;; In Spice Lisp, the default structure representation is a simple-vector with
-;;; the subtype field set to 1.  The first element is used to hold the name of
-;;; the structure.  This piece of implementation-dependency resides in the
-;;; macros defined here.
-;;;
-(proclaim '(inline structurify))
-(defun structurify (structure)
-  "Frobs a vector to turn it into a named structure.  Returns the vector."
-  (%primitive set-vector-subtype structure %g-vector-structure-subtype))
-
-
-;;; This version of Defstruct is implemented using Defstruct, and is free of
-;;; Maclisp compatability nonsense.  For bootstrapping, you're on your own.
-
-(defun print-defstruct-description (structure stream depth)
-  (declare (ignore depth))
-  (format stream "#<Defstruct-Description for ~S>" (dd-name structure)))
-
-;;; DSD-Name  --  Internal
-;;;
-;;;    Return the the name of a defstruct slot as a symbol.  We store it
-;;; as a string to avoid creating lots of worthless symbols at load time.
-;;;
-(defun dsd-name (dsd)
-  (intern (string (dsd-%name dsd)) (symbol-package (dsd-accessor dsd))))
-
-(defun print-defstruct-slot-description (structure stream depth)
-  (declare (ignore depth))
-  (format stream "#<Defstruct-Slot-Description for ~S>" (dsd-name structure)))
-
-
-
-;;; The legendary macro itself.
-
-;;; ### Bootstrap hack...
-;;; Install this definition only into the new compiler's environment so that we
-;;; don't break the bootstrap environment.
-;;;
-(compiler-let ((lisp::*bootstrap-defmacro* t))
-
-(defmacro defstruct (name-and-options &rest slot-descriptions)
-  "Defstruct {Name | (Name Option*)} {Slot | (Slot [Default] {Key Value}*)}
-  Define the structure type Name.  See the manual for details."
-  (let* ((defstruct (parse-name-and-options name-and-options))
-	 (name (dd-name defstruct)))
-    (parse-slot-descriptions defstruct slot-descriptions)
-    (if (eq (dd-type defstruct) 'structure)
-	`(progn
-	   (%compiler-defstruct ',defstruct)
-	   ,@(define-constructor defstruct)
-	   ,@(define-boa-constructors defstruct)
-	   
-	   ;;
-	   ;; So the print function is in the right lexical environment, and
-	   ;; can be compiled...
-	   (let ((new ',defstruct))
-	     ,@(let ((pf (dd-print-function defstruct)))
-		 (when pf
-		   `((setf (info type printer ',name)
-			   ,(if (symbolp pf)
-				`',pf
-				`#',pf)))))
-	     (%defstruct new))
-	   ',name)
-	`(progn
-	   (eval-when (compile load eval)
-	     (setf (info type kind ',name) nil)
-	     (setf (info type structure-info ',name) ',defstruct))
-	   ,@(define-constructor defstruct)
-	   ,@(define-boa-constructors defstruct)
-	   ,@(define-predicate defstruct)
-	   ,@(define-accessors defstruct)
-	   ,@(define-copier defstruct)
-	   ',name))))
-
-); Compiler-Let
-	   
-
-;;;; Parsing:
-
-(defun parse-name-and-options (name-and-options)
-  (if (atom name-and-options)
-      (setq name-and-options (list name-and-options)))
-  (do* ((options (cdr name-and-options) (cdr options))
-	(name (car name-and-options))
-	(print-function nil)
-	(pf-supplied-p)
-	(conc-name (concat-pnames name '-))
-	(constructor (concat-pnames 'make- name))
-	(saw-constructor)
-	(boa-constructors '())
-	(copier (concat-pnames 'copy- name))
-	(predicate (concat-pnames name '-p))
-	(include)
-	(saw-type)
-	(type 'structure)
-	(saw-named)
-	(offset 0))
-       ((null options)
-	(make-defstruct-description
-	 :name name
-	 :conc-name conc-name
-	 :constructor constructor
-	 :boa-constructors boa-constructors
-	 :copier copier
-	 :predicate predicate
-	 :include include
-	 :print-function print-function
-	 :type type
-	 :lisp-type (cond ((eq type 'structure) 'simple-vector)
-			  ((eq type 'vector) 'simple-vector)
-			  ((eq type 'list) 'list)
-			  ((and (listp type) (eq (car type) 'vector))
-			   (cons 'simple-array (cdr type)))
-			  (t (error "~S is a bad :TYPE for Defstruct." type)))
-	 :named (if saw-type saw-named t)
-	 :offset offset))
-    (if (atom (car options))
-	(case (car options)
-	  (:constructor (setq saw-constructor t
-			      constructor (concat-pnames 'make- name)))
-	  (:copier)
-	  (:predicate)
-	  (:named (setq saw-named t))
-	  (t (error "The Defstruct option ~S cannot be used with 0 arguments."
-		    (car options))))
-	(let ((option (caar options))
-	      (args (cdar options)))
-	  (case option
-	    (:conc-name (setq conc-name (car args)))
-	    (:constructor (cond ((cdr args)
-				 (unless saw-constructor
-				   (setq constructor nil))
-				 (push args boa-constructors))
-				(t
-				 (setq saw-constructor t)
-				 (setq constructor
-				       (or (car args)
-					   (concat-pnames 'make- name))))))
-	    (:copier (setq copier (car args)))
-	    (:predicate (setq predicate (car args)))
-	    (:include
-	     (setf include args)
-	     (let* ((name (car include))
-		    (included-structure
-		     (info type structure-info name))
-		    (included-print-function
-		     (if included-structure
-			 (dd-print-function included-structure))))
-	       (unless included-structure
-		 (error "Cannot find description of structure ~S to use for ~
-		         inclusion."
-			name))
-	       (unless pf-supplied-p
-		 (setf print-function included-print-function))))
-	    (:print-function
-	     (setf print-function (car args))
-	     (setf pf-supplied-p t))
-	    (:type (setf saw-type t type (car args)))
-	    (:named (error "The Defstruct option :NAMED takes no arguments."))
-	    (:initial-offset (setf offset (car args)))
-	    (t (error "~S is an unknown Defstruct option." option)))))))
-
-
-
-;;;; Stuff to parse slot descriptions.
-
-;;; PARSE-SLOT-DESCRIPTIONS parses the slot descriptions (surprise) and does
-;;; any structure inclusion that needs to be done.
-;;;
-(defun parse-slot-descriptions (defstruct slots)
-  ;; First strip off any doc string and stash it in the Defstruct.
-  (when (stringp (car slots))
-    (setf (dd-doc defstruct) (car slots))
-    (setq slots (cdr slots)))
-  ;; Then include stuff.  We add unparsed items to the start of the Slots.
-  (when (dd-include defstruct)
-    (let* ((included-name (car (dd-include defstruct)))
-	   (included-thing (info type structure-info included-name))
-	   (modified-slots (cdr (dd-include defstruct))))
-      (unless included-thing
-	(error "Cannot find description of structure ~S to use for inclusion."
-	       included-name))
-      (setf (dd-includes defstruct)
-	    (cons (dd-name included-thing) (dd-includes included-thing)))
-      (setf (dd-offset defstruct) (dd-offset included-thing))
-      (do* ((islots (mapcar #'(lambda (slot)
-				`(,(dsd-name slot) ,(dsd-default slot)
-				  :type ,(dsd-type slot)
-				  :read-only ,(dsd-read-only slot)))
-			    (dd-slots included-thing)))
-	    (islots* islots (cdr islots*)))
-	   ((null islots*)
-	    (setq slots (nconc islots slots)))
-	(let* ((islot (car islots*))
-	       (modifiee (find (car islot) modified-slots
-			       :key #'(lambda (x) (if (atom x) x (car x)))
-			       :test #'string=)))
-	  (when modifiee
-	    (cond ((symbolp modifiee)
-		   ;; If it's just a symbol, nilify the default.
-		   (setf (cadr islot) nil))
-		  ((listp modifiee)
-		   ;; If it's a list, parse new defaults and options.
-		   (setf (cadr islot) (cadr modifiee))
-		   (when (cddr modifiee)
-		     (do ((options (cddr modifiee) (cddr options)))
-			 ((null options))
-		       (case (car options)
-			 (:type
-			  (setf (cadddr islot) (cadr options)))
-			 (:read-only
-			  (setf (cadr (cddddr islot)) (cadr options)))
-			 (t
-			  (error "Bad option in included slot spec: ~S."
-				 (car options)))))))))))))
-  ;; Finally parse the slots into Slot-Description objects.
-  (do ((slots slots (cdr slots))
-       (index (+ (dd-offset defstruct) (if (dd-named defstruct) 1 0))
-	      (1+ index))
-       (descriptions ()))
-      ((null slots)
-       (setf (dd-length defstruct) index)
-       (setf (dd-slots defstruct) (nreverse descriptions)))
-    (let* ((slot (car slots))
-	   (name (if (atom slot) slot (car slot))))
-      (when (keywordp name)
-	(warn "Keyword slot name indicates possible syntax error in DEFSTRUCT ~
-	       -- ~S."
-	      name))
-      (push
-       (if (atom slot)
-	   (make-defstruct-slot-description
-	    :%name (string name)
-	    :index index
-	    :accessor (concat-pnames (dd-conc-name defstruct) name)
-	    :type t)
-	   (do ((options (cddr slot) (cddr options))
-		(default (cadr slot))
-		(type t)
-		(read-only nil))
-	       ((null options)
-		(make-defstruct-slot-description
-		 :%name (string name)
-		 :index index
-		 :accessor (concat-pnames (dd-conc-name defstruct) name)
-		 :default default
-		 :type type
-		 :read-only read-only))
-	     (case (car options)
-	       (:type (setq type (cadr options)))
-	       (:read-only (setq read-only (cadr options))))))
-       descriptions))))
-
-
-
-;;;; Default structure access and copiers:
-;;;
-;;;    In the normal case of structures that have a real type (i.e. no :Type
-;;; option was specified), we want to optimize things for space as well as
-;;; speed, since there can be thousands of defined slot accesors.
-;;;
-;;;    What we do is defined the accessors and copier as closures over
-;;; general-case code.  Since the compiler will normally open-code accesors,
-;;; the (minor) efficiency penalty is not a concern.
-
-;;; Typep-To-Structure  --  Internal
-;;;
-;;;    Return true if Obj is an object of the structure type specified by Info.
-;;; This is called by the accessor closures, which have a handle on the type's
-;;; Defstruct-Description.
-;;;
-(proclaim '(inline typep-to-structure))
-(defun typep-to-structure (obj info)
-  (declare (type defstruct-description info) (inline member))
-  (and (structurep obj)
-       (let ((name (%primitive header-ref obj 0)))
-	 (or (eq name (dd-name info))
-	     (member name (dd-included-by info) :test #'eq)))))
-
-#+new-compiler
-;;; %Defstruct  --  Internal
-;;;
-;;;    Do miscellaneous load-time actions for the structure described by Info.
-;;; Define setters, accessors, copier, predicate, documentation, instantiate
-;;; definition in load-time env.  This is only called for default structures.
-;;;
-(defun %defstruct (info)
-  (declare (type defstruct-description info))
-  (setf (info type defined-structure-info (dd-name info)) info)
-  
-  (dolist (slot (dd-slots info))
-    (let ((dsd slot))
-      (setf (symbol-function (dsd-accessor slot))
-	    #'(lambda (structure)
-		(declare (optimize (speed 3) (safety 0)))
-		(unless (typep-to-structure structure info)
-		  (error "Structure for accessor ~S is not a ~S:~% ~S"
-			 (dsd-accessor dsd) (dd-name info) structure))
-		(%primitive header-ref structure (dsd-index dsd))))
-      
-      (unless (dsd-read-only slot)
-	(setf (fdefinition `(setf ,(dsd-accessor slot)))
-	      #'(lambda (structure new-value)
-		  (declare (optimize (speed 3) (safety 0)))
-		  (unless (typep-to-structure structure info)
-		    (error "Structure for setter ~S is not a ~S:~% ~S"
-			   `(setf ,(dsd-accessor dsd)) (dd-name info)
-			   structure))
-		  (unless (typep new-value (dsd-type dsd))
-		    (error "New-Value for setter ~S is not a ~S:~% ~S."
-			   `(setf ,(dsd-accessor dsd)) (dsd-type dsd)
-			   new-value))
-		  (%primitive header-set structure (dsd-index dsd)
-			      new-value))))))
-
-  (when (dd-predicate info)
-    (setf (symbol-function (dd-predicate info))
-	  #'(lambda (object)
-	      (declare (optimize (speed 3) (safety 0)))
-	      (if (typep-to-structure object info) t nil))))
-
-  (when (dd-copier info)
-    (setf (symbol-function (dd-copier info))
-	  #'(lambda (structure)
-	      (declare (optimize (speed 3) (safety 0)))
-	      (unless (typep-to-structure structure info)
-		(error "Structure for copier ~S is not a ~S:~% ~S"
-		       (dd-copier info) (dd-name info) structure))
-
-	      (let ((len (dd-length info)))
-		(declare (fixnum len))
-		(do ((i 1 (1+ i))
-		     (res (%primitive alloc-g-vector len nil)))
-		    ((= i len)
-		     (%primitive header-set res 0 (dd-name info))
-		     (structurify res))
-		  (declare (fixnum i))
-		  (%primitive header-set res i
-			      (%primitive header-ref structure i)))))))
-  (when (dd-doc info)
-    (setf (documentation (dd-name info) 'type) (dd-doc info))))
-
-
-;;; Define-Accessors returns a list of function definitions for accessing and
-;;; setting the slots of the a typed Defstruct.  The functions are proclaimed
-;;; to be inline, and the types of their arguments and results are declared as
-;;; well.  We count on the compiler to do clever things with Elt.
-
-(defun define-accessors (defstruct)
-  (do ((slots (dd-slots defstruct) (cdr slots))
-       (stuff '())
-       (type (dd-lisp-type defstruct)))
-      ((null slots) stuff)
-    (let* ((slot (car slots))
-	   (name (dsd-accessor slot))
-	   (index (dsd-index slot))
-	   (slot-type (dsd-type slot)))
-      (push
-       `(progn
-	  (proclaim '(inline ,name (setf ,name)))
-	  (defun ,name (structure)
-	    (declare (type ,type structure))
-	    (the ,slot-type (elt structure ,index)))
-	  ,@(unless (dsd-read-only slot)
-	      `((defun (setf ,name) (structure new-value)
-		  (declare (type ,type structure) (type ,slot-type new-value))
-		  (setf (elt structure ,index) new-value)))))
-       stuff))))
-
-
-;;; Define-Constructor returns a definition for the constructor function of the
-;;; given Defstruct.  If the structure is implemented as a vector and is named,
-;;; we structurify it.  If the structure is a vector of some specialized type,
-;;; we can't use the Vector function.
-;;;
-;;; If we are defining safe accessors, we also check the types of the values to
-;;; make sure that they are legal.
-;;;
-(defun define-constructor (defstruct)
-  (let ((name (dd-constructor defstruct)))
-    (when name
-      (let* ((initial-cruft
-	      (if (dd-named defstruct)
-		  (make-list (1+ (dd-offset defstruct))
-			     :initial-element `',(dd-name defstruct))
-		  (make-list (dd-offset defstruct))))
-	     (slots (dd-slots defstruct))
-	     (names (mapcar #'dsd-name slots))
-	     (args (mapcar #'(lambda (slot)
-			       `(,(dsd-name slot) ,(dsd-default slot)))
-			   slots)))
-	`((defun ,name ,(if args `(&key ,@args))
-	    (declare
-	     ,@(mapcar #'(lambda (slot)
-			   `(type ,(dsd-type slot) ,(dsd-name slot)))
-		       slots))
-	    ,(case (dd-type defstruct)
-	       (list
-		`(list ,@initial-cruft ,@names))
-	       (structure
-		`(truly-the ,(dd-name defstruct)
-			    (structurify
-			     (vector ,@initial-cruft ,@names))))
-	       (vector
-		`(vector ,@initial-cruft ,@names))
-	       (t
-		(do ((sluts slots (cdr sluts))
-		     (sets '())
-		     (temp (gensym)))
-		    ((null sluts)
-		     `(let ((,temp (make-array
-				    ,(dd-length defstruct)
-				    :element-type
-				    ',(cadr (dd-lisp-type defstruct)))))
-			,@(when (dd-named defstruct)
-			    `(setf (aref ,temp ,(dd-offset defstruct))
-				   ',(dd-name defstruct)))
-			,@sets
-			,temp))
-		  (let ((slot (car sluts)))
-		    (push `(setf (aref ,temp ,(dsd-index slot))
-				 ,(dsd-name slot))
-			  sets)))))))))))
-
-
-
-;;;; Support for By-Order-Argument Constructors.
-
-;;; FIND-LEGAL-SLOT   --  Internal
-;;;
-;;;    Given a defstruct description and a slot name, return the corresponding
-;;; slot if it exists, or signal an error if not.
-;;;
-(defun find-legal-slot (defstruct name)
-  (or (find name (dd-slots defstruct) :key #'dsd-name :test #'string=)
-      (error "~S is not a defined slot name in the ~S structure."
-	     name (dd-name defstruct))))
-
-
-;;; Define-Boa-Constructors defines positional constructor functions.  We
-;;; generate code to set each variable not specified in the arglist to the
-;;; default given in the Defstruct.  We just slap required args in, as with
-;;; rest args and aux args.  Optionals are treated a little differently.  Those
-;;; that aren't supplied with a default in the arg list are mashed so that
-;;; their default in the arglist is the corresponding default from the
-;;; Defstruct.
-;;;
-(defun define-boa-constructors (defstruct)
-  (do* ((boas (dd-boa-constructors defstruct) (cdr boas))
-	(name (car (car boas)) (car (car boas)))
-	(args (copy-list (cadr (car boas))) (copy-list (cadr (car boas))))
-	(slots (dd-slots defstruct) (dd-slots defstruct))
-	(slots-in-arglist '() '())
-	(defuns '()))
-       ((null boas) defuns)
-    ;; Find the slots in the arglist and hack the defaultless optionals.
-    (do ((args args (cdr args))
-	 (arg-kind 'required))
-	((null args))
-      (let ((arg (car args)))
-	(cond ((not (atom arg))
-	       (push (find-legal-slot defstruct (car arg)) slots-in-arglist))
-	      ((memq arg '(&optional &rest &aux &key))
-	       (setq arg-kind arg))
-	      (t
-	       (case arg-kind
-		 ((required &rest &aux)
-		  (push (find-legal-slot defstruct arg) slots-in-arglist))
-		 ((&optional &key)
-		  (let ((dsd (find-legal-slot defstruct arg)))
-		    (push dsd slots-in-arglist)
-		    (rplaca args (list arg (dsd-default dsd))))))))))
-    
-    ;; Then make a list that can be used with a (list ...) or (vector...).
-    (let ((initial-cruft
-	   (if (dd-named defstruct)
-	       (make-list (1+ (dd-offset defstruct))
-			  :initial-element `',(dd-name defstruct))
-	       (make-list (dd-offset defstruct))))
-	  (thing (mapcar #'(lambda (slot)
-			     (if (memq slot slots-in-arglist)
-				 (dsd-name slot)
-				 (dsd-default slot)))
-			 slots)))
-      (push
-       `(defun ,name ,args
-	  (declare
-	   ,@(mapcar #'(lambda (slot)
-			 `(type ,(dsd-type slot) ,(dsd-name slot)))
-		     slots-in-arglist))
-	  ,(case (dd-type defstruct)
-	     (list
-	      `(list ,@initial-cruft ,@thing))
-	     (structure
-	      `(truly-the ,(dd-name defstruct)
-			  (structurify (vector ,@initial-cruft ,@thing))))
-	     (vector
-	      `(vector ,@initial-cruft ,@thing))
-	     (t
-	      (do ((things thing (cdr things))
-		   (index 0 (1+ index))
-		   (sets '())
-		   (temp (gensym)))
-		  ((null things)
-		   `(let ((,temp (make-array
-				  ,(dd-length defstruct)
-				  :element-type
-				  ',(cadr (dd-lisp-type defstruct)))))
-		      ,@(when (dd-named defstruct)
-			  `(setf (aref ,temp ,(dd-offset defstruct))
-				 ',(dd-name defstruct)))
-		      ,@sets
-		      ,temp))
-		(push `(setf (aref ,temp index) ,(car things))
-		      sets)))))
-       defuns))))
-
-;;; Define-Copier returns the definition for a copier function of a typed
-;;; Defstruct if one is desired.
-
-(defun define-copier (defstruct)
-  (when (dd-copier defstruct)
-    `((defun ,(dd-copier defstruct) (structure)
-	(declare (type ,(dd-lisp-type defstruct) structure))
-	(subseq structure 0 ,(dd-length defstruct))))))
-
-
-;;; Define-Predicate returns a definition for a predicate function if one is
-;;; desired.  This is only called for typed structures, since the default
-;;; structure predicate is implemented as a closure. 
-
-(defun define-predicate (defstruct)
-  (let ((name (dd-name defstruct))
-	(pred (dd-predicate defstruct)))
-    (when (and pred (dd-named defstruct))
-      (let ((ltype (dd-lisp-type defstruct)))
-	`((defun ,pred (object)
-	    (and (typep object ',ltype)
-		 (eq (elt (the ,ltype object) ,(dd-offset defstruct))
-		     ',name))))))))
-
-
-;;; Structure-Predicate  --  Internal
-;;;
-;;;    The typep transform in typetran calls this function when it encounters
-;;; an unknown symbol type specifier.  If the referred-to type is in fact a
-;;; structure type that has a predicate, then we open-code the normal case of
-;;; an exact match, and otherwise call the predicate.
-;;;
-(defun structure-predicate (object type)
-  (let ((def (info type structure-info type)))
-    (if (and def (eq (dd-type def) 'structure) (dd-predicate def))
-	`(and (structurep ,object)
-	      (or (eq (%primitive header-ref ,object 0) ',type)
-		  (,(dd-predicate def) ,object)))
-	`(lisp::structure-typep ,object ',type))))
-
-
-;;; Random sorts of stuff.
-
-(defun default-structure-print (structure stream depth)
-  (declare (ignore depth))
-  (write-string "#S(" stream)
-  (prin1 (svref structure 0) stream)
-  (do ((index 1 (1+ index))
-       (length (length structure))
-       (slots (dd-slots (info type defined-structure-info (svref structure 0)))
-	      (cdr slots)))
-      ((or (= index length)
-	   (and *print-length*
-		(= index *print-length*)))
-       (if (= index length)
-	   (write-string ")" stream)
-	   (write-string "...)" stream)))
-    (write-char #\space stream)
-    (prin1 (dsd-name (car slots)) stream)
-    (write-char #\space stream)
-    (prin1 (svref structure index) stream)))
diff --git a/code/describe.lisp b/code/describe.lisp
deleted file mode 100644
index 5d985ce4f01a8cb81675b2622f9a7b14558af000..0000000000000000000000000000000000000000
--- a/code/describe.lisp
+++ /dev/null
@@ -1,318 +0,0 @@
-;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (Scott.Fahlman@cs.cmu.edu). 
-;;; **********************************************************************
-;;;
-;;; This is the describe mechanism for Common Lisp.
-;;;
-;;; Written by Skef Wholey or Rob MacLachlan originally.
-;;; Cleaned up, reorganized, and enhanced by Blaine Burks.
-;;;
-;;; This should be done better using CLOS more effectively once CMU Common
-;;; Lisp is brought up to the new standard.  The TYPECASE in DESCRIBE-AUX
-;;; should be unnecessary.	-- Bill Chiles
-;;;
-
-(in-package "LISP")
-
-(export '(describe *describe-level* *describe-verbose*
-		   *describe-implementation-details* *describe-print-level*
-		   *describe-print-length* *describe-indentation*))
-
-
-;;;; DESCRIBE public switches.
-
-(defvar *describe-level* 2
-  "Depth of recursive descriptions allowed.")
-
-(defvar *describe-verbose* nil
-  "If non-nil, descriptions may provide interpretations of information and
-  pointers to additional information.  Normally nil.")
-
-(defvar *describe-implementation-details* nil
-  "If non-null, normally concealed implementation information won't be.")
-
-(defvar *describe-print-level* 2
-  "*print-level* gets bound to this inside describe.")
-
-(defvar *describe-print-length* 5
-  "*print-length gets bound to this inside describe.")
-
-(defvar *describe-indentation* 3
-  "Number of spaces that sets off each line of a recursive description.")
-
-(defvar *in-describe* nil
-  "Used to tell whether we are doing a recursive describe.")
-(defvar *current-describe-level* 0
-  "Used to implement recursive description cutoff.  Don't touch.")
-(defvar *describe-output* nil
-  "An output stream used by Describe for indenting and stuff.")
-(defvar *used-documentation* nil "Documentation already described.")
-(defvar *described-objects* nil
-  "List of all objects describe within the current top-level call to describe.")
-(defvar *current-describe-object* nil
-  "The last object passed to describe.")
-
-;;; DESCRIBE sets up the output stream and calls DESCRIBE-AUX, which does the
-;;; hard stuff.
-;;;
-(defun describe (x &optional (stream *standard-output*))
-  "Prints a description of the object X.
-  See also *describe-level*, defdescribe, *describe-verbose*,
-  *describe-implementation-details*, *describe-print-level*,
-  *describe-print-length*, and *describe-indentation*."
-  (unless *describe-output*
-    (setq *describe-output* (make-indenting-stream *standard-output*)))
-  (cond (*in-describe*
-	 (unless (or (eq x nil) (eq x t))
-	   (let ((*current-describe-level* (1+ *current-describe-level*))
-		 (*current-describe-object* x))
-	     (indenting-further *describe-output* *describe-indentation*
-	       (describe-aux x)))))
-	(t
-	 (setf (indenting-stream-stream *describe-output*) stream)
-	 (let ((*standard-output* *describe-output*)
-	       (*print-level* *describe-print-level*)
-	       (*print-length* *describe-print-length*)
-	       (*used-documentation* ())
-	       (*described-objects* ())
-	       (*in-describe* t)
-	       (*current-describe-object* x))
-	   (describe-aux x))
-	 (values))))
-
-;;; DESCRIBE-AUX does different things for each type.  The order of the
-;;; TYPECASE branches matters with respect to:
-;;;    - symbols and functions until the new standard makes them disjoint.
-;;;    - packages and structure since packages are structures.
-;;; We punt a given call if the current level is greater than *describe-level*,
-;;; or if we detect an object into which we have already descended.
-;;;
-(defun describe-aux (x)
-  (when (or (not (integerp *describe-level*))
-	    (minusp *describe-level*))
-    (error "*describe-level* should be a nonnegative integer - ~A."
-	   *describe-level*))
-  (when (or (>= *current-describe-level* *describe-level*)
-	    (member x *described-objects*))
-    (return-from describe-aux x))
-  (push x *described-objects*)
-  (typecase x
-    (symbol (describe-symbol x))
-    (function (describe-function x))
-    (package (describe-package x))
-    (hash-table (describe-hash-table x))
-    (structure (describe-structure x))
-    (array (describe-array x))
-    (fixnum (describe-fixnum x))
-    (t (default-describe x)))
-  x)
-
-
-
-;;;; Implementation properties.
-
-;;; This supresses random garbage that users probably don't want to see.
-;;;
-(defparameter *implementation-properties*
-  '(%loaded-address
-    ;;
-    ;; Documentation properties:
-    %var-documentation %fun-documentation %struct-documentation
-    %type-documentation %setf-documentation %documentation))
-
-
-;;;; DESCRIBE methods.
-
-;;; DESC-DOC prints the specified kind of documentation about the given Symbol.
-;;;
-(defun desc-doc (symbol name string)
-  (let ((doc (documentation symbol name)))
-    (when (and doc (not (member doc *used-documentation*)))
-      (push doc *used-documentation*)
-      (format t "~&~A~&  ~A" string doc))))
-
-	  
-(defun default-describe (x)
-  (format t "~&~S is a ~S." x (type-of x)))
-
-(defun describe-symbol (x)
-  (let ((package (symbol-package x)))
-    (if package
-	(multiple-value-bind (symbol status)
-			     (find-symbol (symbol-name x) package)
-	  (declare (ignore symbol))
-	  (format t "~&~A is an ~A symbol in the ~A package." x
-		  (string-downcase (symbol-name status))
-		  (package-name (symbol-package x))))
-	(format t "~&~A is an uninterned symbol." x)))
-  ;;
-  ;; Describe the value cell.
-  (when (boundp x)
-    (let ((value (symbol-value x))
-	  (constantp (constantp x)))
-      (cond ((get x 'globally-special)
-	     (if constantp
-		 (format t "~&It is a constant; its value is ~S." value)
-		 (format t "~&It is a special variable; ~
-			    its current binding is ~S."
-			 value)))
-	    (t
-	     (fresh-line)
-	     (write-string "Its value is ")
-	     (print-for-describe value nil)))
-      (desc-doc x 'variable
-		(format nil "~:[Variable~;Constant~] Documentation:"
-			constantp))
-      (describe value)))
-  ;;
-  ;; Describe the function cell.
-  (cond ((macro-function x)
-	 (let ((fun (macro-function x)))
-	   (format t "~&Its macroexpansion function is ~A." fun)
-	   (describe-function fun)
-	   (desc-doc x 'function "Macro Documentation:")))
-	((fboundp x)
-	 (describe-function (symbol-function x))))
-  ;;
-  ;; Print other documentation.
-  (desc-doc x 'structure "Documentation on the structure:")
-  (desc-doc x 'type "Documentation on the type:")
-  (desc-doc x 'setf "Documentation on the SETF form:")
-  (dolist (assoc (get x '%documentation))
-    (unless (member (cdr assoc) *used-documentation*)
-      (format t "~&Documentation on the ~(~A~):~%~A" (car assoc) (cdr assoc))))
-  ;;
-  ;; Print out properties, possibly ignoring implementation details.
-  (do ((plist (symbol-plist X) (cddr plist))
-       (properties-to-ignore (if *describe-implementation-details*
-				 nil
-				 *implementation-properties*)))
-      ((null plist) ())
-    (unless (member (car plist) properties-to-ignore)
-      (format t "~&Its ~S property is ~S." (car plist) (cadr plist))
-      (describe (cadr plist)))))
-
-(defun describe-structure (x)
-  (format t "~&~S is a structure of type ~A." x (svref x 0))
-  (dolist (slot (cddr (inspect::describe-parts x)))
-    (format t "~%~A: ~S." (car slot) (cdr slot))))
-
-(defun describe-array (x)
-  (let ((rank (array-rank x)))
-    (cond ((> rank 1)
-	   (format t "~&~S is " x)
-	   (write-string (if (%displacedp x) "a displaced" "an"))
-	   (format t " array of rank ~A." rank)
-	   (format t "~%Its dimensions are ~S." (array-dimensions x)))
-	  (t
-	   (format t "~&~S is a ~:[~;displaced ~]vector of length ~D." x
-		   (%displacedp x) (length x))
-	   (if (array-has-fill-pointer-p x)
-	       (format t "~&It has a fill pointer, currently ~d"
-		       (fill-pointer x))
-	       (format t "~&It has no fill pointer."))))
-  (format t "~&Its element type is ~S." (array-element-type x))))
-
-(defmacro describe-function-arg-list (object test output)
-  `(progn
-     (print-for-describe ,object)
-     (if ,test
-	 (write-string " is called with zero arguments.")
-	 (indenting-further *standard-output* 2
-	   (format t " can be called with these arguments:~%")
-	   ,output))))
-
-(defun describe-function (x)
-  (case (%primitive get-vector-subtype x)
-    (#.%function-entry-subtype
-     (describe-function-compiled x))
-    (#.%function-closure-subtype
-     (describe-function-lex-closure x))
-    (t
-     (format t "~&It is an unknown type of function."))))
-
-(defun describe-function-compiled (x)
-  (let ((args (%primitive header-ref x %function-entry-arglist-slot)))
-    (describe-function-arg-list
-     *current-describe-object* (string= args "()") (write-string args)))
-  (let ((*print-level* nil)
-	(*print-length* nil)
-	(type (%primitive header-ref x %function-entry-type-slot)))
-    (format t "~&Its argument types are:~%  ~S" (second type))
-    (format t "~&Its result type is:~%  ~S" (third type)))
-  
-  (let ((name (%primitive header-ref x %function-name-slot)))
-    (when (symbolp name)
-      (desc-doc 'function name "Function Documention:")))
-  
-  (let ((info (%primitive header-ref
-			  (%primitive header-ref x
-				      %function-entry-constants-slot)
-			  %function-constants-debug-info-slot)))
-    (when info
-      (let ((sources (c::compiled-debug-info-source info)))
-	(format t "~&On ~A it was compiled from:"
-		(format-universal-time nil
-				       (c::debug-source-compiled
-					(first sources))))
-	(dolist (source sources)
-	  (let ((name (c::debug-source-name source)))
-	    (ecase (c::debug-source-from source)
-	      (:file
-	       (format t "~&~A " (namestring name))
-	       (ext:format-universal-time t (c::debug-source-created source)))
-	      (:stream (format t "~&~S" name))
-	      (:lisp (format t "~&~S" name)))))))))
-
-(defun describe-function-lex-closure (x)
-  (print-for-describe x)
-  (format t " is a lexical closure.~%")
-  (format t "~&Its lexical environment is:")
-  (indenting-further *standard-output* 8
-    (do ((i %function-closure-variables-offset (1+ i)))
-	((= i (%primitive header-length x)))
-      (format t "~&~D: ~S"
-	      (- i %function-closure-variables-offset)
-	      (%primitive header-ref x i))))
-  (describe-function-compiled (%primitive header-ref x %function-name-slot)))
-
-
-(defun print-for-describe (x &optional (freshp t))
-  (when freshp (fresh-line))
-  (cond ((symbolp x)
-	 (write-string (symbol-name x)))
-	(t
-	 (princ x))))
-
-(defun describe-fixnum (x)
-  (cond ((not (or *describe-verbose* (zerop *current-describe-level*))))
-	((primep x)
-	 (format t "~&It is a prime number."))
-	(t
-	 (format t "~&It is a composite number."))))
-
-(defun describe-hash-table (x)
-  (format t "~&~S is an ~a hash table." x (hash-table-kind x))
-  (format t "~&Its size is ~d buckets." (hash-table-size x))
-  (format t "~&Its rehash-size is ~d." (hash-table-rehash-size x))
-  (format t "~&Its rehash-threshold is ~d."
-	  (hash-table-rehash-threshold x))
-  (format t "~&It currently holds ~d entries."
-	  (hash-table-number-entries x)))
-
-(defun describe-package (x)
-  (describe-structure x)
-  (let* ((internal (package-internal-symbols x))
-	 (internal-count (- (package-hashtable-size internal)
-			    (package-hashtable-free internal)))
-	 (external (package-external-symbols x))
-	 (external-count (- (package-hashtable-size external)
-			    (package-hashtable-free external))))
-    (format t "~&~d symbols total: ~d internal and ~d external."
-	     (+ internal-count external-count) internal-count external-count)))
-
diff --git a/code/error.lisp b/code/error.lisp
deleted file mode 100644
index 45c0181c4b27b3d3c4002bc3d8982b5b932151b3..0000000000000000000000000000000000000000
--- a/code/error.lisp
+++ /dev/null
@@ -1,1236 +0,0 @@
-;;; -*- Package: conditions; Log: code.log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; This is a condition system for CMU Common Lisp.
-;;; It was originally taken from some prototyping code written by KMP@Symbolics
-;;; and massaged for our uses.
-;;;
-
-(in-package "CONDITIONS")
-
-#-new-compiler
-(eval-when (compile)
-  (setq lisp::*bootstrap-defmacro* t))
-
-(in-package "LISP")
-(export '(break error warn cerror
-	  ;;
-	  ;; The following are found in Macros.Lisp:
-	  check-type assert etypecase ctypecase ecase ccase
-	  ;;
-	  ;; These are all the new things to export from "LISP" now that this
-	  ;; proposal has been accepted.
-	  *break-on-signals* *debugger-hook* signal handler-case handler-bind
-	  ignore-errors define-condition make-condition with-simple-restart
-	  restart-case restart-bind restart-name restart-name find-restart
-	  compute-restarts invoke-restart invoke-restart-interactively abort
-	  continue muffle-warning store-value use-value invoke-debugger restart
-	  condition warning serious-condition simple-condition simple-warning
-	  simple-error simple-condition-format-string
-	  simple-condition-format-arguments storage-condition stack-overflow
-	  storage-exhausted type-error type-error-datum
-	  type-error-expected-type simple-type-error program-error
-	  control-error stream-error stream-error-stream end-of-file file-error
-	  file-error-pathname cell-error unbound-variable undefined-function
-	  arithmetic-error arithmetic-error-operation arithmetic-error-operands
-	  package-error package-error-package division-by-zero
-	  floating-point-overflow floating-point-underflow))
-
-
-(in-package "CONDITIONS")
-
-;;;; Keyword utilities.
-
-(eval-when (eval compile load)
-
-(defun parse-keyword-pairs (list keys)
-  (do ((l list (cddr l))
-       (k '() (list* (cadr l) (car l) k)))
-      ((or (null l) (not (member (car l) keys)))
-       (values (nreverse k) l))))
-
-(defmacro with-keyword-pairs ((names expression &optional keywords-var)
-			      &body forms)
-  (let ((temp (member '&rest names)))
-    (unless (= (length temp) 2)
-      (error "&rest keyword is ~:[missing~;misplaced~]." temp))
-    (let ((key-vars (ldiff names temp))
-          (key-var (or keywords-var (gensym)))
-          (rest-var (cadr temp)))
-      (let ((keywords (mapcar #'(lambda (x)
-				  (intern (string x) ext:*keyword-package*))
-			      key-vars)))
-        `(multiple-value-bind (,key-var ,rest-var)
-             (parse-keyword-pairs ,expression ',keywords)
-           (let ,(mapcar #'(lambda (var keyword)
-			     `(,var (getf ,key-var ,keyword)))
-			 key-vars keywords)
-	     ,@forms))))))
-
-) ;eval-when
-
-
-
-;;;; Restarts.
-
-(defvar *restart-clusters* '())
-
-(defun compute-restarts ()
-  "Return a list of all the currently active restarts ordered from most
-   recently established to less recently established."
-  (copy-list (apply #'append *restart-clusters*)))
-
-(defun restart-print (restart stream depth)
-  (declare (ignore depth))
-  (if *print-escape*
-      (format stream "#<~S.~X>"
-	      (type-of restart) (system:%primitive lisp::make-fixnum restart))
-      (restart-report restart stream)))
-
-(defstruct (restart (:print-function restart-print))
-  name
-  function
-  report-function
-  interactive-function)
-
-(setf (documentation 'restart-name 'function)
-      "Returns the name of the given restart object.")
-
-(defun restart-report (restart stream)
-  (funcall (or (restart-report-function restart)
-               (let ((name (restart-name restart)))
-		 #'(lambda (stream)
-		     (if name (format stream "~S" name)
-			      (format stream "~S" restart)))))
-           stream))
-
-(defmacro restart-bind (bindings &body forms)
-  "Executes forms in a dynamic context where the given restart bindings are
-   in effect.  Users probably want to use RESTART-CASE.  When clauses contain
-   the same restart name, FIND-RESTART will find the first such clause."
-  `(let ((*restart-clusters*
-	  (cons (list
-		 ,@(mapcar #'(lambda (binding)
-			       (unless (or (car binding)
-					   (member :report-function
-						   binding :test #'eq))
-				 (warn "Unnamed restart does not have a ~
-					report function -- ~S"
-				       binding))
-			       `(make-restart
-				 :name ',(car binding)
-				 :function ,(cadr binding)
-				 ,@(cddr binding)))
-			       bindings))
-		*restart-clusters*)))
-     ,@forms))
-
-(defun find-restart (name)
-  "Returns the first restart named name.  If name is a restart, it is returned
-   if it is currently active.  If no such restart is found, nil is returned.
-   It is an error to supply nil as a name."
-  (dolist (restart-cluster *restart-clusters*)
-    (dolist (restart restart-cluster)
-      (when (or (eq restart name) (eq (restart-name restart) name))
-	(return-from find-restart restart)))))
-  
-
-(defun invoke-restart (restart &rest values)
-  "Calls the function associated with the given restart, passing any given
-   arguments.  If the argument restart is not a restart or a currently active
-   non-nil restart name, then a control-error is signalled."
-  (let ((real-restart (find-restart restart)))
-    (unless real-restart
-      (error 'control-error
-	     :format-string "Restart ~S is not active."
-	     :format-arguments (list restart)))
-    (apply (restart-function real-restart) values)))
-
-(defun invoke-restart-interactively (restart)
-  "Calls the function associated with the given restart, prompting for any
-   necessary arguments.  If the argument restart is not a restart or a
-   currently active non-nil restart name, then a control-error is signalled."
-  (let ((real-restart (find-restart restart)))
-    (unless real-restart
-      (error 'control-error
-	     :format-string "Restart ~S is not active."
-	     :format-arguments (list restart)))
-    (apply (restart-function real-restart)
-	   (let ((interactive-function
-		  (restart-interactive-function real-restart)))
-	     (if interactive-function
-		 (funcall interactive-function)
-		 '())))))
-
-
-(defmacro restart-case (expression &body clauses)
-  "(RESTART-CASE form
-   {(case-name arg-list {keyword value}* body)}*)
-   The form is evaluated in a dynamic context where the clauses have special
-   meanings as points to which control may be transferred (see INVOKE-RESTART).
-   When clauses contain the same case-name, FIND-RESTART will find the first
-   such clause."
-  (flet ((transform-keywords (&key report interactive)
-	   (let ((result '()))
-	     (when report
-	       (setq result (list* (if (stringp report)
-				       `#'(lambda (stream)
-					    (write-string ,report stream))
-				       `#',report)
-				   :report-function
-				   result)))
-	     (when interactive
-	       (setq result (list* `#',interactive
-				   :interactive-function
-				   result)))
-	     (nreverse result))))
-    (let ((temp-var (gensym))
-	  (outer-tag (gensym))
-	  (inner-tag (gensym))
-	  (tag-var (gensym))
-	  (data
-	    (mapcar #'(lambda (clause)
-			(with-keyword-pairs ((report interactive &rest forms)
-					     (cddr clause))
-			  (list (car clause)			   ;name=0
-				(gensym)			   ;tag=1
-				(transform-keywords :report report ;keywords=2
-						    :interactive interactive)
-				(cadr clause)			   ;bvl=3
-				forms)))			   ;body=4
-		    clauses)))
-      `(let ((,outer-tag (cons nil nil))
-	     (,inner-tag (cons nil nil))
-	     ,temp-var ,tag-var)
-	 (catch ,outer-tag
-	   (catch ,inner-tag
-	     (throw ,outer-tag
-		    (restart-bind
-			,(mapcar #'(lambda (datum)
-				     (let ((name (nth 0 datum))
-					   (tag  (nth 1 datum))
-					   (keys (nth 2 datum)))
-				       `(,name #'(lambda (&rest temp)
-						   (setf ,temp-var temp)
-						   (setf ,tag-var ',tag)
-						   (throw ,inner-tag nil))
-					       ,@keys)))
-				 data)
-		      ,expression)))
-	   (case ,tag-var
-	     ,@(mapcar #'(lambda (datum)
-			   (let ((tag  (nth 1 datum))
-				 (bvl  (nth 3 datum))
-				 (body (nth 4 datum)))
-			     `(,tag
-			       (apply #'(lambda ,bvl ,@body) ,temp-var))))
-		       data)))))))
-#|
-This macro doesn't work in our system due to lossage in closing over tags.
-The previous version is uglier, but it sets up unique run-time tags.
-
-(defmacro restart-case (expression &body clauses)
-  "(RESTART-CASE form
-   {(case-name arg-list {keyword value}* body)}*)
-   The form is evaluated in a dynamic context where the clauses have special
-   meanings as points to which control may be transferred (see INVOKE-RESTART).
-   When clauses contain the same case-name, FIND-RESTART will find the first
-   such clause."
-  (flet ((transform-keywords (&key report interactive)
-	   (let ((result '()))
-	     (when report
-	       (setq result (list* (if (stringp report)
-				       `#'(lambda (stream)
-					    (write-string ,report stream))
-				       `#',report)
-				   :report-function
-				   result)))
-	     (when interactive
-	       (setq result (list* `#',interactive
-				   :interactive-function
-				   result)))
-	     (nreverse result))))
-    (let ((block-tag (gensym))
-	  (temp-var  (gensym))
-	  (data
-	    (mapcar #'(lambda (clause)
-			(with-keyword-pairs ((report interactive &rest forms)
-					     (cddr clause))
-			  (list (car clause)			   ;name=0
-				(gensym)			   ;tag=1
-				(transform-keywords :report report ;keywords=2
-						    :interactive interactive)
-				(cadr clause)			   ;bvl=3
-				forms)))			   ;body=4
-		    clauses)))
-      `(block ,block-tag
-	 (let ((,temp-var nil))
-	   (tagbody
-	     (restart-bind
-	       ,(mapcar #'(lambda (datum)
-			    (let ((name (nth 0 datum))
-				  (tag  (nth 1 datum))
-				  (keys (nth 2 datum)))
-			      `(,name #'(lambda (&rest temp)
-					  (setq ,temp-var temp)
-					  (go ,tag))
-				,@keys)))
-			data)
-	       (return-from ,block-tag ,expression))
-	     ,@(mapcan #'(lambda (datum)
-			   (let ((tag  (nth 1 datum))
-				 (bvl  (nth 3 datum))
-				 (body (nth 4 datum)))
-			     (list tag
-				   `(return-from ,block-tag
-				      (apply #'(lambda ,bvl ,@body)
-					     ,temp-var)))))
-		       data)))))))
-|#
-
-(defmacro with-simple-restart ((restart-name format-string
-					     &rest format-arguments)
-			       &body forms)
-  "(WITH-SIMPLE-RESTART (restart-name format-string format-arguments)
-   body)
-   If restart-name is not invoked, then all values returned by forms are
-   returned.  If control is transferred to this restart, it immediately
-   returns the values nil and t."
-  `(restart-case (progn ,@forms)
-     (,restart-name ()
-        :report (lambda (stream)
-		  (format stream ,format-string ,@format-arguments))
-      (values nil t))))
-
-
-
-;;;; Conditions.
-
-(defstruct (condition (:constructor |constructor for condition|)
-                      (:predicate nil)
-                      (:print-function condition-print))
-  )
-
-(defun condition-print (condition stream depth)
-  (declare (ignore depth))
-  (if *print-escape*
-      (format stream "#<~S.~X>"
-	      (type-of condition)
-	      (system:%primitive lisp::make-fixnum condition))
-      (condition-report condition stream)))
-
-
-(eval-when (eval compile load)
-
-(defmacro parent-type     (condition-type) `(get ,condition-type 'parent-type))
-(defmacro slots           (condition-type) `(get ,condition-type 'slots))
-(defmacro conc-name       (condition-type) `(get ,condition-type 'conc-name))
-(defmacro report-function (condition-type)
-  `(get ,condition-type 'report-function))
-(defmacro make-function   (condition-type) `(get ,condition-type 'make-function))
-
-) ;eval-when
-
-(defun condition-report (condition stream)
-  (do ((type (type-of condition) (parent-type type)))
-      ((not type)
-       (format stream "The condition ~A occurred." (type-of condition)))
-    (let ((reporter (report-function type)))
-      (when reporter
-        (funcall reporter condition stream)
-        (return nil)))))
-
-(setf (make-function   'condition) '|constructor for condition|)
-
-(defun make-condition (type &rest slot-initializations)
-  "Makes a condition of type type using slot-initializations as initial values
-   for the slots."
-  (let ((fn (make-function type)))
-    (cond ((not fn) (error 'simple-type-error
-			   :datum type
-			   :expected-type '(satisfies make-function)
-			   :format-string "Not a condition type: ~S"
-			   :format-arguments (list type)))
-          (t (apply fn slot-initializations)))))
-
-
-;;; Some utilities used at macro expansion time.
-;;;
-(eval-when (eval compile load)
-
-(defmacro resolve-function (function expression resolver)
-  `(cond ((and ,function ,expression)
-          (cerror "Use only the :~A information."
-                  "Only one of :~A and :~A is allowed."
-                  ',function ',expression))
-         (,expression (setq ,function ,resolver))))
-         
-(defun parse-new-and-used-slots (slots parent-type)
-  (let ((new '()) (used '()))
-    (dolist (slot slots)
-      (if (slot-used-p (car slot) parent-type)
-          (push slot used)
-          (push slot new)))
-    (values new used)))
-
-(defun slot-used-p (slot-name type)
-  (cond ((eq type 'condition) nil)
-        ((not type) (error "The type ~S does not inherit from condition." type))
-        ((assoc slot-name (slots type)))
-        (t (slot-used-p slot-name (parent-type type)))))
-
-) ;eval-when
-
-(defmacro define-condition (name (parent-type) slot-specs &rest options)
-  "(DEFINE-CONDITION name (parent-type)
-   ( {slot-name | (slot-name) | (slot-name default-value)}*)
-   options)"
-  (let ((constructor (let ((*package* (find-package "CONDITIONS")))
-		       ;; Bind for the INTERN and the FORMAT.
-		       (intern (format nil "Constructor for ~S" name)))))
-    (let ((slots (mapcar #'(lambda (slot-spec)
-			     (if (atom slot-spec) (list slot-spec) slot-spec))
-			 slot-specs)))
-      (multiple-value-bind (new-slots used-slots)
-          (parse-new-and-used-slots slots parent-type)
-	(let ((conc-name-p     nil)
-	      (conc-name       nil)
-	      (report-function nil)
-	      (documentation   nil))
-	  (do ((o options (cdr o)))
-	      ((null o))
-	    (let ((option (car o)))
-	      (case (car option) ;should be ecase
-		(:conc-name
-		 (setq conc-name-p t)
-		 (setq conc-name (cadr option)))
-		(:report
-		 (setq report-function
-		       (if (stringp (cadr option))
-			   `(lambda (stream)
-			      (write-string ,(cadr option) stream))
-			   (cadr option))))
-		(:documentation (setq documentation (cadr option)))
-		(otherwise
-		 (cerror "Ignore this DEFINE-CONDITION option."
-			 "Invalid DEFINE-CONDITION option: ~S" option)))))
-	  (unless conc-name-p
-	    (setq conc-name
-		  (intern (concatenate 'simple-string (symbol-name name)
-				       "-")
-			  *package*)))
-	  ;; The following three forms are compile-time side-effects.  For now,
-	  ;; they affect the global environment, but with modified abstractions
-	  ;; for parent-type, slots, and conc-name, the compiler could easily
-	  ;; make them local.
-	  (setf (parent-type name) parent-type)
-          (setf (slots name)       slots)
-          (setf (conc-name name)   conc-name)
-          ;; finally, the expansion ...
-	  `(progn
-	     (defstruct (,name
-			 (:constructor ,constructor)
-			 (:predicate nil)
-			 (:copier nil)
-			 (:print-function condition-print)
-			 (:include ,parent-type ,@used-slots)
-			 (:conc-name ,conc-name))
-	       ,@new-slots)
-	     (setf (documentation ',name 'type) ',documentation)
-	     (setf (parent-type ',name) ',parent-type)
-	     (setf (slots ',name) ',slots)
-	     (setf (conc-name ',name) ',conc-name)
-	     (setf (report-function ',name)
-		   ,(if report-function `#',report-function))
-	     (setf (make-function ',name) ',constructor)
-	     ',name))))))
-
-
-
-;;;; HANDLER-BIND and SIGNAL.
-
-(defvar *handler-clusters* nil)
-
-(defmacro handler-bind (bindings &body forms)
-  "(HANDLER-BIND ( {(type handler)}* )  body)
-   Executes body in a dynamic context where the given handler bindings are
-   in effect.  Each handler must take the condition being signalled as an
-   argument.  The bindings are searched first to last in the event of a
-   signalled condition."
-  (unless (every #'(lambda (x) (and (listp x) (= (length x) 2))) bindings)
-    (error "Ill-formed handler bindings."))
-  `(let ((*handler-clusters*
-	  (cons (list ,@(mapcar #'(lambda (x) `(cons ',(car x) ,(cadr x)))
-				bindings))
-		*handler-clusters*)))
-     ,@forms))
-
-(defvar *break-on-signals* nil
-  "When (typep condition *break-on-signals*) is true, then calls to SIGNAL will
-   enter the debugger prior to signalling that condition.")
-
-(defun signal (datum &rest arguments)
-  "Invokes the signal facility on a condition formed from datum and arguments.
-   If the condition is not handled, nil is returned.  If
-   (TYPEP condition *BREAK-ON-SIGNALS*) is true, the debugger is invoked before
-   any signalling is done."
-  (let ((condition (coerce-to-condition datum arguments
-					'simple-condition 'signal))
-        (*handler-clusters* *handler-clusters*))
-    (when (typep condition *break-on-signals*)
-      (break "~A~%Break entered because of *break-on-signals*."
-	     condition))
-    (loop
-      (unless *handler-clusters* (return))
-      (let ((cluster (pop *handler-clusters*)))
-	(dolist (handler cluster)
-	  (when (typep condition (car handler))
-	    (funcall (cdr handler) condition)))))
-    nil))
-
-;;; COERCE-TO-CONDITION is used in SIGNAL, ERROR, CERROR, WARN, and
-;;; INVOKE-DEBUGGER for parsing the hairy argument conventions into a single
-;;; argument that's directly usable by all the other routines.
-;;;
-(defun coerce-to-condition (datum arguments default-type function-name)
-  (cond ((typep datum 'condition)
-	 (if arguments
-	     (cerror "Ignore the additional arguments."
-		     'simple-type-error
-		     :datum arguments
-		     :expected-type 'null
-		     :format-string "You may not supply additional arguments ~
-				     when giving ~S to ~S."
-		     :format-arguments (list datum function-name)))
-	 datum)
-        ((symbolp datum) ;Roughly, (subtypep datum 'condition).
-         (apply #'make-condition datum arguments))
-        ((stringp datum)
-	 (make-condition default-type
-                         :format-string datum
-                         :format-arguments arguments))
-        (t
-         (error 'simple-type-error
-		:datum datum
-		:expected-type '(or symbol string)
-		:format-string "Bad argument to ~S: ~S"
-		:format-arguments (list function-name datum)))))
-
-
-
-;;;; INFINITE-ERROR-PROTECT.
-
-(defvar *error-system-initialized*)
-(defvar *max-error-depth* 10 "The maximum number of nested errors allowed.")
-(defvar *current-error-depth* 0 "The current number of nested errors.")
-
-;;; INFINITE-ERROR-PROTECT is used by ERROR and friends to keep us out of
-;;; hyperspace.
-;;;
-(defmacro infinite-error-protect (form)
-  `(if (and (boundp '*error-system-initialized*) (numberp *current-error-depth*))
-       (let ((*current-error-depth* (1+ *current-error-depth*)))
-	 (if (> *current-error-depth* *max-error-depth*)
-	     (error-error "Help! " *current-error-depth* " nested errors.")
-	     ,form))
-       (system:%primitive lisp::halt)))
-
-;;; These are used in ERROR-ERROR.
-;;;
-(defvar %error-error-depth% 0)
-(defvar *error-throw-up-count* 0)
-
-(proclaim '(special lisp::*real-terminal-io*))
-
-;;; ERROR-ERROR can be called when the error system is in trouble and needs
-;;; to punt fast.  Prints a message without using format.  If we get into
-;;; this recursively, then halt.
-;;;
-(defun error-error (&rest messages)
-  (let ((%error-error-depth% (1+ %error-error-depth%)))
-    (when (> *error-throw-up-count* 50)
-      (system:%primitive lisp::halt)
-      (throw 'lisp::top-level-catcher nil))
-    (case %error-error-depth%
-      (1)
-      (2
-       (setq *terminal-io* lisp::*real-terminal-io*))
-      (3
-       (incf *error-throw-up-count*)
-       (throw 'lisp::top-level-catcher nil))
-      (t
-       (system:%primitive lisp::halt)
-       (throw 'lisp::top-level-catcher nil)))
-    
-    (dolist (item messages) (princ item *terminal-io*))
-    (debug:internal-debug)))
-
-
-
-;;;; Fetching errorful function name.
-
-#+new-compiler
-;;; FIND-NAME returns the name of a function if it is a subr or named-lambda.
-;;; If the function is a regular lambda, the whole list is returned, and if
-;;; the function can't be recognized, () is returned.
-(defun find-name (function)
-  (declare (ignore function))
-  'hunoz)
-
-;;; GET-CALLER returns a form that returns the function which called the
-;;; currently active function.
-(defmacro get-caller ()
-  'nil)
-
-
-;;;; ERROR, CERROR, BREAK, WARN.
-
-(define-condition serious-condition (condition) ())
-
-(define-condition error (serious-condition)
-  ((function-name nil)))
-
-#+new-compiler
-(defun error (datum &rest arguments)
-  "Invokes the signal facility on a condition formed from datum and arguments.
-   If the condition is not handled, the debugger is invoked."
-  (infinite-error-protect
-   (let ((condition (coerce-to-condition datum arguments 'simple-error 'error)))
-     (unless (error-function-name condition)
-       (setf (error-function-name condition) (find-name (get-caller))))
-     (signal condition)
-     (invoke-debugger condition))))
-
-#+new-compiler
-;;; CERROR must take care to no use arguments when datum is already a condition
-;;; object.  Furthermore, we must set ERROR-FUNCTION-NAME here instead of
-;;; letting ERROR do it, so we get the correct function name.
-;;;
-(defun cerror (continue-string datum &rest arguments)
-  (with-simple-restart
-      (continue "~A" (apply #'format nil continue-string arguments))
-    (let ((condition (if (typep datum 'condition)
-			 datum
-			 (coerce-to-condition datum arguments
-					      'simple-error 'error))))
-      (unless (error-function-name condition)
-	(setf (error-function-name condition) (find-name (get-caller))))
-      (error condition)))
-  nil)
-
-#+new-compiler
-(defun break (&optional (format-string "Break") &rest format-arguments)
-  "Prints a message and invokes the debugger without allowing any possibility
-   of condition handling occurring."
-  (with-simple-restart (continue "Return from BREAK.")
-    (invoke-debugger
-      (make-condition 'simple-condition
-		      :format-string format-string
-		      :format-arguments format-arguments)))
-  nil)
-
-(define-condition warning (condition) ())
-
-(defvar *break-on-warnings* ()
-  "If non-NIL, then WARN will enter a break loop before returning.")
-
-#+new-compiler
-(defun warn (datum &rest arguments)
-  "Warns about a situation by signalling a condition formed by datum and
-   arguments.  Before signalling, if *break-on-warnings* is set, then BREAK
-   is called.  While the condition is being signaled, a muffle-warning restart
-   exists that causes WARN to immediately return nil."
-  (let ((condition (coerce-to-condition datum arguments 'simple-warning 'warn)))
-    (check-type condition warning "a warning condition")
-    (if *break-on-warnings*
-	(break "~A~%Break entered because of *break-on-warnings*."
-	       condition))
-    (restart-case (signal condition)
-      (muffle-warning ()
-	  :report "Skip warning."
-	(return-from warn nil)))
-    (format *error-output* "~&Warning:~%~A~%" condition)
-    nil))
-
-
-
-;;;; Condition definitions.
-
-;;; Serious-condition and error are defined on the previous page, so ERROR and
-;;; CERROR can SETF a slot in the error condition object.
-;;;
-
-
-(defun simple-condition-printer (condition stream)
-  (apply #'format stream (simple-condition-format-string condition)
-	 		 (simple-condition-format-arguments condition)))
-
-;;; The simple-condition type has a conc-name, so SIMPLE-CONDITION-FORMAT-STRING
-;;; and SIMPLE-CONDITION-FORMAT-ARGUMENTS could be written to handle the
-;;; simple-condition, simple-warning, simple-type-error, and simple-error types.
-;;; This seems to create some kind of bogus multiple inheritance that the user
-;;; sees.
-;;;
-(define-condition simple-condition (condition)
-  (format-string
-   (format-arguments '()))
-  (:conc-name internal-simple-condition-)
-  (:report simple-condition-printer))
-
-;;; The simple-warning type has a conc-name, so SIMPLE-CONDITION-FORMAT-STRING
-;;; and SIMPLE-CONDITION-FORMAT-ARGUMENTS could be written to handle the
-;;; simple-condition, simple-warning, simple-type-error, and simple-error types.
-;;; This seems to create some kind of bogus multiple inheritance that the user
-;;; sees.
-;;;
-(define-condition simple-warning (warning)
-  (format-string
-   (format-arguments '()))
-  (:conc-name internal-simple-warning-)
-  (:report simple-condition-printer))
-
-
-(defun print-simple-error (condition stream)
-  (format stream "~&Error in function ~S.~%~?"
-	  (internal-simple-error-function-name condition)
-	  (internal-simple-error-format-string condition)
-	  (internal-simple-error-format-arguments condition)))
-
-;;; The simple-error type has a conc-name, so SIMPLE-CONDITION-FORMAT-STRING
-;;; and SIMPLE-CONDITION-FORMAT-ARGUMENTS could be written to handle the
-;;; simple-condition, simple-warning, simple-type-error, and simple-error types.
-;;; This seems to create some kind of bogus multiple inheritance that the user
-;;; sees.
-;;;
-(define-condition simple-error (error)
-  (format-string
-   (format-arguments '()))
-  (:conc-name internal-simple-error-)
-  (:report print-simple-error))
-
-
-(define-condition storage-condition (serious-condition) ())
-
-(define-condition stack-overflow    (storage-condition) ())
-(define-condition storage-exhausted (storage-condition) ())
-
-(define-condition type-error (error)
-  (datum
-   expected-type))
-
-;;; The simple-type-error type has a conc-name, so
-;;; SIMPLE-CONDITION-FORMAT-STRING and SIMPLE-CONDITION-FORMAT-ARGUMENTS could
-;;; be written to handle the simple-condition, simple-warning,
-;;; simple-type-error, and simple-error types.  This seems to create some kind
-;;; of bogus multiple inheritance that the user sees.
-;;;
-(define-condition simple-type-error (type-error)
-  (format-string
-   (format-arguments '()))
-  (:conc-name internal-simple-type-error-)
-  (:report simple-condition-printer))
-
-(define-condition case-failure (type-error)
-  (name
-   possibilities)
-  (:report
-    (lambda (condition stream)
-      (format stream "~S fell through ~S expression.~%Wanted one of ~:S."
-	      (type-error-datum condition)
-	      (case-failure-name condition)
-	      (case-failure-possibilities condition)))))
-
-
-;;; SIMPLE-CONDITION-FORMAT-STRING and SIMPLE-CONDITION-FORMAT-ARGUMENTS.
-;;; These exist for the obvious types to seemingly give the impression of
-;;; multiple inheritance.  That is, the last three types inherit from warning,
-;;; type-error, and error while inheriting from simple-condition also.
-;;;
-(defun simple-condition-format-string (condition)
-  (etypecase condition
-    (simple-condition  (internal-simple-condition-format-string  condition))
-    (simple-warning    (internal-simple-warning-format-string    condition))
-    (simple-type-error (internal-simple-type-error-format-string condition))
-    (simple-error      (internal-simple-error-format-string      condition))))
-;;;
-(defun simple-condition-format-arguments (condition)
-  (etypecase condition
-    (simple-condition  (internal-simple-condition-format-arguments  condition))
-    (simple-warning    (internal-simple-warning-format-arguments    condition))
-    (simple-type-error (internal-simple-type-error-format-arguments condition))
-    (simple-error      (internal-simple-error-format-arguments      condition))))
-
-
-(define-condition program-error (error) ())
-
-
-(defun print-control-error (condition stream)
-  (format stream "~&Error in function ~S.~%~?"
-	  (control-error-function-name condition)
-	  (control-error-format-string condition)
-	  (control-error-format-arguments condition)))
-
-(define-condition control-error (error)
-  (format-string
-   (format-arguments nil))
-  (:report print-control-error))
-
-
-(define-condition stream-error (error) (stream))
-
-(define-condition end-of-file (stream-error) ())
-
-(define-condition file-error (error) (pathname))
-
-(define-condition package-error (error) (pathname))
-
-(define-condition cell-error (error) (name))
-
-(define-condition unbound-variable (cell-error) ()
-  (:report (lambda (condition stream)
-	     (format stream "The variable ~S is unbound."
-		     (cell-error-name condition)))))
-  
-(define-condition undefined-function (cell-error) ()
-  (:report (lambda (condition stream)
-	     (format stream "The function ~S is undefined."
-		     (cell-error-name condition)))))
-
-(define-condition arithmetic-error (error) (operation operands))
-
-(define-condition division-by-zero         (arithmetic-error) ())
-(define-condition floating-point-overflow  (arithmetic-error) ())
-(define-condition floating-point-underflow (arithmetic-error) ())
-
-
-
-;;;; HANDLER-CASE and IGNORE-ERRORS.
-
-(defmacro handler-case (form &rest cases)
-  "(HANDLER-CASE form
-   { (type ([var]) body) }* )
-   Executes form in a context with handlers established for the condition
-   types.  A peculiar property allows type to be :no-error.  If such a clause
-   occurs, and form returns normally, all its values are passed to this clause
-   as if by MULTIPLE-VALUE-CALL.  The :no-error clause accepts more than one
-   var specification."
-  (let ((no-error-clause (assoc ':no-error cases)))
-    (if no-error-clause
-	(let ((normal-return (make-symbol "normal-return"))
-	      (error-return  (make-symbol "error-return")))
-	  `(block ,error-return
-	     (multiple-value-call #'(lambda ,@(cdr no-error-clause))
-	       (block ,normal-return
-		 (return-from ,error-return
-		   (handler-case (return-from ,normal-return ,form)
-		     ,@(remove no-error-clause cases)))))))
-	(let ((var (gensym))
-	      (outer-tag (gensym))
-	      (inner-tag (gensym))
-	      (tag-var (gensym))
-	      (annotated-cases (mapcar #'(lambda (case) (cons (gensym) case))
-				       cases)))
-	  `(let ((,outer-tag (cons nil nil))
-		 (,inner-tag (cons nil nil))
-		 ,var ,tag-var)
-	     ,var			;ignoreable
-	     (catch ,outer-tag
-	       (catch ,inner-tag
-		 (throw ,outer-tag
-			(handler-bind
-			    ,(mapcar #'(lambda (annotated-case)
-					 `(,(cadr annotated-case)
-					   #'(lambda (temp)
-					       ,(if (caddr annotated-case)
-						    `(setq ,var temp)
-						    '(declare (ignore temp)))
-					       (setf ,tag-var
-						     ',(car annotated-case))
-					       (throw ,inner-tag nil))))
-				     annotated-cases)
-			  ,form)))
-	       (case ,tag-var
-		 ,@(mapcar #'(lambda (annotated-case)
-			       (let ((body (cdddr annotated-case))
-				     (varp (caddr annotated-case)))
-				 `(,(car annotated-case)
-				   ,@(if varp
-					 `((let ((,(car varp) ,var))
-					     ,@body))
-					 body))))
-			   annotated-cases))))))))
-#|
-This macro doesn't work in our system due to lossage in closing over tags.
-The previous version sets up unique run-time tags.
-
-(defmacro handler-case (form &rest cases)
-  "(HANDLER-CASE form
-   { (type ([var]) body) }* )
-   Executes form in a context with handlers established for the condition
-   types.  A peculiar property allows type to be :no-error.  If such a clause
-   occurs, and form returns normally, all its values are passed to this clause
-   as if by MULTIPLE-VALUE-CALL.  The :no-error clause accepts more than one
-   var specification."
-  (let ((no-error-clause (assoc ':no-error cases)))
-    (if no-error-clause
-	(let ((normal-return (make-symbol "normal-return"))
-	      (error-return  (make-symbol "error-return")))
-	  `(block ,error-return
-	     (multiple-value-call #'(lambda ,@(cdr no-error-clause))
-	       (block ,normal-return
-		 (return-from ,error-return
-		   (handler-case (return-from ,normal-return ,form)
-		     ,@(remove no-error-clause cases)))))))
-	(let ((tag (gensym))
-	      (var (gensym))
-	      (annotated-cases (mapcar #'(lambda (case) (cons (gensym) case))
-				       cases)))
-	  `(block ,tag
-	     (let ((,var nil))
-	       ,var				;ignorable
-	       (tagbody
-		 (handler-bind
-		  ,(mapcar #'(lambda (annotated-case)
-			       (list (cadr annotated-case)
-				     `#'(lambda (temp)
-					  ,(if (caddr annotated-case)
-					       `(setq ,var temp)
-					       '(declare (ignore temp)))
-					  (go ,(car annotated-case)))))
-			   annotated-cases)
-			       (return-from ,tag ,form))
-		 ,@(mapcan
-		    #'(lambda (annotated-case)
-			(list (car annotated-case)
-			      (let ((body (cdddr annotated-case)))
-				`(return-from
-				  ,tag
-				  ,(cond ((caddr annotated-case)
-					  `(let ((,(caaddr annotated-case)
-						  ,var))
-					     ,@body))
-					 ((not (cdr body))
-					  (car body))
-					 (t
-					  `(progn ,@body)))))))
-			   annotated-cases))))))))
-|#
-
-(defmacro ignore-errors (&rest forms)
-  "Executes forms after establishing a handler for all error conditions that
-   returns from this form nil and the condition signalled."
-  `(handler-case (progn ,@forms)
-     (error (condition) (values nil condition))))
-
-
-
-;;;; Restart definitions.
-
-(define-condition abort-failure (control-error) ()
-  (:report
-   "Found an \"abort\" restart that failed to transfer control dynamically."))
-
-;;; ABORT signals an error in case there was a restart named abort that did
-;;; not tranfer control dynamically.  This could happen with RESTART-BIND.
-;;;
-(defun abort ()
-  "Transfers control to a restart named abort, signalling a control-error if
-   none exists."
-  (invoke-restart 'abort)
-  (error 'abort-failure))
-
-
-(defun muffle-warning ()
-  "Transfers control to a restart named muffle-warning, signalling a
-   control-error if none exists."
-  (invoke-restart 'muffle-warning))
-
-
-;;; DEFINE-NIL-RETURNING-RESTART finds the restart before invoking it to keep
-;;; INVOKE-RESTART from signalling a control-error condition.
-;;;
-(defmacro define-nil-returning-restart (name args doc)
-  `(defun ,name ,args
-     ,doc
-     (if (find-restart ',name) (invoke-restart ',name ,@args))))
-
-(define-nil-returning-restart continue ()
-  "Transfer control to a restart named continue, returning nil if none exists.")
-
-(define-nil-returning-restart store-value (value)
-  "Transfer control and value to a restart named store-value, returning nil if
-   none exists.")
-
-(define-nil-returning-restart use-value (value)
-  "Transfer control and value to a restart named use-value, returning nil if
-   none exists.")
-
-
-
-
-;;;; Internal Error Codes.
-
-;;; *Internal-error-table* contains a vector, by error code, of functions.
-;;; This is used in %SP-INTERNAL-ERROR, and initialized MAKE-ERROR-TABLE.
-;;;
-(defvar *internal-error-table*)
-
-#+new-compiler
-;;; %SP-INTERNAL-ERROR is called by the microcode when an internal error
-;;; occurrs.  It is simply a dispatch routine which looks up a specialized
-;;; function to call in the special variable, *internal-error-table*.
-;;;
-;;; ERR-CODE -- a fixnum which identifies the specific error.
-;;; PC -- the relative offset of the NEXT macro instruction to be
-;;;        executed in the code vector of the errorful function.
-;;; ARG3 & ARG4 -- arbitrary meaning determined by ERR-CODE.
-;;;
-(defun lisp::%sp-internal-error (err-code arg3 arg4)
-  (infinite-error-protect
-   (funcall (svref *internal-error-table* err-code)
-	    (find-name (get-caller))
-	    0
-	    arg3
-	    arg4)))
-
-;;; DEF-INTERNAL-ERROR defines a form which can be put into the system init
-;;; file (spinit, or vaxinit) to define the errors which the microcode may
-;;; signal.  The form looks like
-;;;
-;;; (def-internal-error err-code condition flag control-string &rest args)
-;;;  ERR-CODE -- the internal code for this error. less than or equal to
-;;;               max-internal-error which is declared in the init file.
-;;;  CONDITION -- the name of the error to signal
-;;;  FLAG -- one of CORRECTABLE, FATAL or SYSTEM-ERROR.  (not evaluated)
-;;;           if CORRECTABLE, %sp-internal-error may return correction values
-;;;           if SYSTEM-ERROR, the CONDITION arg is ignored.
-;;;  CONTROL-STRING -- the error message as a format control string.
-;;;  ARGS -- The args to the control string.  The 3rd & 4th args to
-;;;           %sp-internal-error are available as the variables ARG3 & ARG4.
-;;;
-;;; NOTE: system-error is never supplied, and condition is never used.  Maybe
-;;;       it will be when we signal appropriate conditions for certain
-;;;       situations.
-;;;
-
-;example
-;  (def-internal-error 6 :unbound-symbol correctable
-;    "Unbound symbol: ~s." arg3)
-
-
-(defmacro def-internal-error (number condition flag control-string &rest args)
-  (declare (ignore condition))
-  `(setf (svref *internal-error-table* ,number)
-	 #'(lambda (callers-name PC arg3 arg4)
-	     (declare (ignore ,@(unless (eq flag 'system-error) '(PC))
-			      ,@(unless (member 'arg3 args) '(arg3))
-			      ,@(unless (member 'arg4 args) '(arg4))))
-	     ,(case flag
-		((fatal) `(error 'simple-error
-				 :function-name callers-name
-				 :format-string ,control-string
-				 :format-arguments (list ,@args)))
-		((correctable) `(cerror 'simple-error
-					:function-name callers-name
-					:format-string ,control-string
-					:format-arguments (list ,@args)))))))
-
-
-(defconstant max-internal-error 100
-  "The largest internal error number for Spice Lisp.")
-
-(proclaim '(special allocation-space))
-
-
-(defun make-error-table ()
-  (setq *internal-error-table*
-	(make-array (1+ max-internal-error)
-		    :initial-element
-		    #'(lambda (&rest ignore)
-			(declare (ignore ignore))
-			(break "Undefined Error."))))
-
-  (def-internal-error 1 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s." arg3 'List)
-  (def-internal-error 2 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s." arg3 'Symbol)
-  (def-internal-error 3 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s." arg3 'Number)
-  (def-internal-error 4 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s." arg3 'Integer)
-  (def-internal-error 5 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s." arg3 'Ratio)
-  (def-internal-error 6 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s." arg3 'Complex)
-  (def-internal-error 7 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s." arg3 'Vector-like)
-  (def-internal-error 8 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s." arg3 'simple-vector)
-  (def-internal-error 9 :invalid-function fatal
-    "Invalid function: ~s." arg3)
-  (def-internal-error 10 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been a function or an array." arg3)
-  (def-internal-error 11 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s." arg3 'U-vector-like)
-  (def-internal-error 12 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s."
-    arg3 'simple-bit-vector)
-  (def-internal-error 13 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s." arg3
-    'simple-string)
-  (def-internal-error 14 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s." arg3 'character)
-  (def-internal-error 15 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s."
-    arg3 'Control-Stack-Pointer)
-  (def-internal-error 16 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s."
-    arg3 'Binding-Stack-Pointer)
-  (def-internal-error 17 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s." arg3 'Array)
-  (def-internal-error 18 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s."
-    arg3 'Positive-Fixnum)
-  (def-internal-error 19 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s." arg3 'SAP-pointer)
-  (def-internal-error 20 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of tyep ~s." arg3 'system-pointer)
-  (def-internal-error 21 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s." arg3 'float)
-  (def-internal-error 22 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s." arg3 'rational)
-  (def-internal-error 23 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been a non-complex number." arg3)
-
-  (def-internal-error 25 :unbound-variable fatal
-    "Unbound variable: ~s." arg3)
-  (def-internal-error 26 :undefined-function fatal
-    "Undefined function: ~s." arg3)
-  (def-internal-error 27 :error fatal
-    "Attempt to alter NIL.")
-  (def-internal-error 28 :error fatal
-    "Attempt to alter NIL.")
-  (def-internal-error 29 :error fatal
-    "Circularity detected in chain of symbols from definition cell of symbol ~S."
-    arg3)
-
-  ;;Special because handlers won't work while allocation-space is wrong.
-  (setf (svref *internal-error-table* 24)
-	#'(lambda (callers-name ignore0 ignore1 ignore2)
-	    (declare (ignore ignore0 ignore1 ignore2))
-	    (let ((bazfaz allocation-space))
-	      (setq allocation-space 0)
-	      (error 'simple-error
-		     :function-name callers-name
-		     :format-string "Illegal allocation-space value: ~S."
-		     :format-arguments (list bazfaz)))))
-
-  (def-internal-error 30 :error fatal
-    "Illegal u-vector access type: ~s." arg3)
-  (def-internal-error 31 :error fatal
-    "Illegal vector length: ~s." arg3)
-  (def-internal-error 32 :error fatal
-    "Vector index, ~s, out of bounds." arg3)
-  (def-internal-error 33 :error fatal
-    "Illegal index: ~s." arg3)
-  (def-internal-error 34 :error fatal
-    "Illegal shrink value: ~s." arg3)
-  (def-internal-error 35 :error fatal
-    "Shrink value, ~s, is greater than current length of ~s." arg3 arg4)
-  (def-internal-error 36 :error fatal
-    "Illegal data vector, ~S, in an array." arg3)
-  (def-internal-error 37 :error fatal
-    "Too few arguments passed to two or three dimension array access miscop.")
-  (def-internal-error 38 :error fatal
-    "Too many arguments passed to two or three dimension array access miscop.")
-  (def-internal-error 39 :error fatal
-    "Illegal to allocate vector of size: ~s." arg3)
-
-  (def-internal-error 40 :error fatal
-    "Illegal byte pointer: (byte ~s ~s)." arg3 arg4)
-  (def-internal-error 41 :error fatal
-    "Illegal position, ~s, in byte spec." arg3)
-  (def-internal-error 42 :error fatal
-    "Illegal size, ~s, in byte spec." arg3)
-  (def-internal-error 43 :error fatal
-    "Illegal shift count: ~s." arg3)
-  (def-internal-error 44 :error fatal
-    "Illegal boole operation: ~s." arg3)
-
-  (def-internal-error 50 :error fatal "Wrong number of arguments: ~D." arg3)
-
-  (def-internal-error 55 :error fatal
-    "~s is not <= to ~s (Alien index out of bounds.)" arg3 arg4)
-
-  (def-internal-error 60 :error fatal
-    "Attempt to divide ~s by ~s." arg3 arg4)
-  (def-internal-error 61 :unseen-throw-tag fatal
-    "No catcher for throw tag ~s." arg3)
-  (def-internal-error 62 :error fatal
-    "Something using ~S and ~S lead to a short-float underflow." arg3 arg4)
-  (def-internal-error 63 :error fatal
-    "Something using ~S and ~S lead to a short-float overflow." arg3 arg4)
-#|
-  (def-internal-error 64 :error fatal
-    "Something using ~S and ~S lead to a single-float underflow." arg3 arg4)
-  (def-internal-error 65 :error fatal
-    "Something using ~S and ~S lead to a single-float overflow." arg3 arg4)
-|#
-  (def-internal-error 66 :error fatal
-    "Something using ~S and ~S lead to a long-float underflow." arg3 arg4)
-  (def-internal-error 67 :error fatal
-    "Something using ~S and ~S lead to a long-float overflow." arg3 arg4)
-  (def-internal-error 68 :error fatal
-    "Something using ~S caused a short-float underflow." arg3)
-  (def-internal-error 69 :error fatal
-    "Something using ~S caused a short-float overflow." arg3)
-  (def-internal-error 70 :error fatal
-    "Something using ~S caused a long-float underflow." arg3)
-  (def-internal-error 71 :error fatal
-    "Something using ~S caused a long-float overflow." arg3)
-  (def-internal-error 72 :error fatal
-    "~S is not a legal argument to log, it should be non-zero." arg3)
-  (def-internal-error 73 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s." arg3 'string-char)
-  (def-internal-error 74 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s." arg3 'short-float)
-  (def-internal-error 75 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s." arg3 'long-float)
-  (def-internal-error 76 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s." arg3 'fixnum)
-  (def-internal-error 77 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s." arg3 'cons)
-  (def-internal-error 78 :error fatal
-    "Invalid exit.")
-  (def-internal-error 79 :error fatal
-    "Odd number of arguments in keyword part of argument list.")
-  (def-internal-error 80 :error fatal
-    "~S is not a known keyword argument specifier." arg3)
-  (def-internal-error 81 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s." arg3 arg4)
-  (def-internal-error 82 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s." arg3
-    '(or function symbol))
-  (def-internal-error 83 :error fatal
-    "~S is not = to ~S (Alien index out of bounds.)" arg3 arg4)
-  
-  )
-
-
-
-;;; ERROR-INIT is called at init time to initialize the error system.
-;;; It initializes the internal error table, and sets a variable.
-;;;
-(defun error-init ()
-  (make-error-table)
-  (setq *error-system-initialized* t))
-
-#-new-compiler
-(eval-when (compile)
-  (setq lisp::*bootstrap-defmacro* nil))
diff --git a/code/eval.lisp b/code/eval.lisp
deleted file mode 100644
index 2ef7d869173072eed0d46877405929a3ba311cab..0000000000000000000000000000000000000000
--- a/code/eval.lisp
+++ /dev/null
@@ -1,356 +0,0 @@
-;;; -*- Log: code.log; Package: Lisp -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    
-(in-package "LISP")
-(export '(eval constantp quote proclaim
-	  eval-when progn prog1 prog2 let let*
-	  do do* dotimes dolist progv and or cond if the
-	  macro-function special-form-p *macroexpand-hook*
-	  macroexpand-1 macroexpand block return-from
-	  return function setq psetq apply funcall
-	  compiler-let progv flet labels macrolet
-	  mapcar maplist mapc mapl mapcan mapcon
-	  tagbody prog prog* go 
-	  values multiple-values-limit
-	  values-list multiple-value-list multiple-value-call
-	  multiple-value-prog1 multiple-value-bind multiple-value-setq
-	  catch unwind-protect throw defun
-	  lambda-list-keywords call-arguments-limit lambda-parameters-limit
-	  function-lambda-expression
-          ;;
-          ;; Declaration symbols referenced in the cold load.
-          declare special 
-	  ;;
-	  ;; Magical markers...
-	  lambda &optional &rest &key &aux &body &whole
-	  &allow-other-keys &environment))
-
-#| Not implemented:
-*evalhook* *applyhook* evalhook applyhook 
-|#
-
-(export '(eval::interpreted-function-p
-	  eval::interpreted-function-lambda-expression)
-	"EVAL")
-(import '(eval::*eval-stack-top*))
-
-(in-package 'system)
-(export '(parse-body find-if-in-closure))
-
-(in-package "LISP")
-
-
-(defconstant lambda-list-keywords
-  '(&optional &rest &key &aux &body &whole &allow-other-keys &environment)
-  "Keywords that you can put in a lambda-list, supposing you should want
-  to do such a thing.")
-
-(defconstant call-arguments-limit most-positive-fixnum
-  "The exclusive upper bound on the number of arguments which may be passed
-  to a function, including rest args.")
-
-(defconstant lambda-parameters-limit most-positive-fixnum
-  "The exclusive upper bound on the number of parameters which may be specifed
-  in a given lambda list.  This is actually the limit on required and optional
-  parameters.  With &key and &aux you can get more.")
-
-(defconstant multiple-values-limit most-positive-fixnum
-  "The exclusive upper bound on the number of multiple-values that you can
-  have.")
-
-
-
-;;;; EVAL and friends.
-
-;;;
-;;; This flag is used by EVAL-WHEN to keep track of when code has already been
-;;; evaluated so that it can avoid multiple evaluation of nested EVAL-WHEN
-;;; (COMPILE)s.
-(defvar *already-evaled-this* nil)
-
-;;;
-;;; This needs to be initialized in the cold load, since the top-level catcher
-;;; will always restore the initial value.
-(defvar *eval-stack-top* 0)
-
-;;; EVAL  --  Public
-;;;
-;;;    Pick off a few easy cases, and call INTERNAL-EVAL for the rest.  If
-;;; *ALREADY-EVALED-THIS* is true, then we bind it to NIL before doing a call
-;;; so that the effect is confined to the lexical scope of the EVAL-WHEN.
-;;;
-(defun eval (exp)
-  "Evaluates its single arg in a null lexical environment, returns the
-  result or results."
-  (let ((exp (macroexpand exp)))
-    (typecase exp
-      (symbol (symbol-value exp))
-      (list
-       (let ((name (first exp))
-	     (args (1- (length exp))))
-	 (case name
-	   (function
-	    (unless (= args 1)
-	      (error "Wrong number of args to FUNCTION:~% ~S." exp))
-	    (let ((name (second exp)))
-	      (if (or (atom name)
-		      (and (consp name)
-			   (eq (car name) 'setf)))
-		  (fdefinition name)
-		  (eval:make-interpreted-function name))))
-	   (quote
-	    (unless (= args 1)
-	      (error "Wrong number of args to QUOTE:~% ~S." exp))
-	    (second exp))
-	   (setq
-	    (unless (evenp args)
-	      (error "Odd number of args to SETQ:~% ~S." exp))
-	    (unless (zerop args)
-	      (do ((name (cdr exp) (cddr name)))
-		  ((null name)
-		   (do ((args (cdr exp) (cddr args)))
-		       ((null (cddr args))
-			(set (first args) (eval (second args))))
-		     (set (first args) (eval (second args)))))
-		(unless (eq (info variable kind (first name)) :special)
-		  (return (eval:internal-eval exp))))))
-	   ((progn)
-	    (when (> args 0)
-	      (dolist (x (butlast (rest exp)) (eval (car (last exp))))
-		(eval x))))
-	   (t
-	    (if (and (symbolp name)
-		     (eq (info function kind name) :function))
-		(collect ((args))
-		  (dolist (arg (rest exp))
-		    (args (eval arg)))
-		  (if *already-evaled-this*
-		      (let ((*already-evaled-this* nil))
-			(apply (symbol-function name) (args)))
-		      (apply (symbol-function name) (args))))
-		(eval:internal-eval exp))))))
-      (t
-       exp))))
-
-
-;;; INTERPRETED-FUNCTION-P  --  Interface
-;;;
-;;;    This is defined here so that the printer &c can call it before the full
-;;; interpreter is loaded.
-;;;
-(defun eval:interpreted-function-p (x)
-  (and (functionp x)
-       (= (%primitive get-vector-subtype x) %function-closure-subtype)
-       (fboundp 'eval::leaf-value)
-       (let ((const (%primitive header-ref
-				(%primitive header-ref x %function-name-slot)
-				%function-entry-constants-slot)))
-	 (or (eq (%primitive header-ref #'eval::leaf-value
-			     %function-entry-constants-slot)
-		 const)
-	     (eq (%primitive header-ref #'eval:make-interpreted-function
-			     %function-entry-constants-slot)
-		 const)))))
-
-
-;;; FUNCTION-LAMBDA-EXPRESSION  --  Public
-;;;
-;;;    If interpreted, use the interpreter interface.  Otherwise, see if it was
-;;; compiled with COMPILE.  If that fails, check for an inline expansion.
-;;;
-(defun function-lambda-expression (fun)
-  "Given a function, return three values:
-   1] A lambda expression that could be used to define the function, or NIL if
-      the definition isn't available.
-   2] NIL if the function was definitely defined in a null lexical environment,
-      and T otherwise.
-   3] Some object that \"names\" the function.  Although this is allowed to be
-      any object, CMU CL always returns a valid function name or a string."
-  (declare (type function fun))
-  (if (eval:interpreted-function-p fun)
-      (eval:interpreted-function-lambda-expression fun)
-      (case (%primitive get-vector-subtype fun)
-	(#.%function-closure-subtype
-	 (function-lambda-expression
-	  (%primitive header-ref fun %function-name-slot)))
-	((#.%function-entry-subtype #.%function-closure-entry-subtype)
-	 (let ((name (%primitive header-ref fun %function-name-slot))
-	       (info (%primitive header-ref
-				 (%primitive header-ref fun
-					     %function-entry-constants-slot)
-				 %function-constants-debug-info-slot)))
-	   (if info
-	       (let ((source (first (c::compiled-debug-info-source info))))
-		 (cond ((eq (c::debug-source-from source) :lisp)
-			(values (c::debug-source-name source)
-				nil name))
-		       ((stringp name)
-			(values nil t name))
-		       (t
-			(let ((exp (info function inline-expansion name)))
-			  (if exp
-			      (values exp nil name)
-			      (values nil t name))))))
-	       (values nil t name)))))))
-
-
-;;; FIND-IF-IN-CLOSURE  --  Interface
-;;;
-;;;    Like FIND-IF, only we do it on a compiled closure's environment.
-;;;
-(defun find-if-in-closure (test fun)
-  (do ((i %function-closure-variables-offset (1+ i))
-       (len (%primitive header-length fun)))
-      ((= i len) nil)
-    (let ((elt (%primitive header-ref fun i)))
-      (when (funcall test elt)
-	(return elt)))))
-
-
-;;;; Syntactic environment access:
-
-(defun special-form-p (symbol)
-  "If the symbol globally names a special form, returns the definition in a
-  mysterious internal format (a FEXPR), else returns NIL."
-  (declare (symbol symbol))
-  (eq (info function kind symbol) :special-form))
-
-(defvar *macroexpand-hook* 'funcall
-  "The value of this variable must be a function that can take three
-  arguments, a macro expander function, the macro form to be expanded,
-  and the lexical environment to expand in.  The function should
-  return the expanded form.  This function is called by MACROEXPAND-1
-  whenever a runtime expansion is needed.  Initially this is set to
-  FUNCALL.")
-
-
-;;; Macroexpand-1  --  Public
-;;;
-;;;    The Env arg may actually be the compiler *fenv* alist.
-;;;
-(defun macroexpand-1 (form &optional env)
-  "If form is a macro, expands it once.  Returns two values, the
-  expanded form and a T-or-NIL flag indicating whether the form was,
-  in fact, a macro.  Env is the lexical environment to expand in,
-  which defaults to the null environment."
-  (let ((fenv #|(if (listp env) env
-		  (lexical-environment-fenv env))|#
-	      env))
-    (if (and (consp form) (symbolp (car form)))
-	(let ((local-def (cdr (assoc (car form) fenv))))
-	  (if local-def
-	      (if (and (consp local-def) (eq (car local-def) 'MACRO))
-		  (values (funcall *macroexpand-hook* (cdr local-def)
-				   form fenv)
-			  t)
-		  (values form nil))
-	      (let ((global-def (macro-function (car form))))
-		(if global-def
-		    (values (funcall *macroexpand-hook* global-def form fenv)
-			    t)
-		    (values form nil)))))
-	(values form nil))))
-
-
-(defun macroexpand (form &optional env)
-  "If Form is a macro call, then the form is expanded until the result is not
-  a macro.  Returns as multiple values, the form after any expansion has
-  been done and T if expansion was done, or NIL otherwise.  Env is the
-  lexical environment to expand in, which defaults to the null environment."
-  (prog (flag)
-    (multiple-value-setq (form flag) (macroexpand-1 form env))
-    (unless flag (return (values form nil)))
-    loop
-    (multiple-value-setq (form flag) (macroexpand-1 form env))
-    (if flag (go loop) (return (values form t)))))
-
-
-(defun macro-function (symbol)
-  "If the symbol globally names a macro, returns the expansion function,
-  else returns NIL."
-  (declare (symbol symbol))
-  (if (eq (info function kind symbol) :macro)
-      (info function macro-function symbol)
-      nil))
-
-
-(defun (setf macro-function) (symbol function)
-  (declare (symbol symbol) (type function function))
-
-  (when (eq (info function kind symbol) :special-form)
-    (error "~S names a special form." symbol))
-
-  (setf (info function kind symbol) :macro)
-  (setf (info function macro-function symbol) function)
-  (fmakunbound symbol)
-  function)
-
-
-(defun constantp (object)
-  "True of any Lisp object that has a constant value: types that eval to
-  themselves, keywords, constants, and list whose car is QUOTE."
-  (typecase object
-    (number t)
-    (character t)
-    (array t)
-    (symbol
-     (eq (info variable kind object) :constant))
-    (list (eq (car object) 'quote))))
-
-
-;;; Type-Expand  --  Interface
-;;;
-;;;    Similar to Macroexpand, but expands deftypes.  We don't bother returning
-;;; a second value.
-;;;
-(defun type-expand (form)
-  (let ((def (cond ((symbolp form)
-		    (info type expander form))
-		   ((and (consp form) (symbolp (car form)))
-		    (info type expander (car form)))
-		   (t nil))))
-    (if def
-	(type-expand (funcall def (if (consp form) form (list form))))
-	form)))
-
-
-;;; Function invocation:
-
-(defun apply (function arg &rest args)
-  "Applies FUNCTION to a list of arguments produced by evaluating ARGS in
-  the manner of LIST*.  That is, a list is made of the values of all but the
-  last argument, appended to the value of the last argument, which must be a
-  list."
-  (cond ((atom args)
-	 (apply function arg))
-	((atom (cdr args))
-	 (apply function (cons arg (car args))))
-	(t (do* ((a1 args a2)
-		 (a2 (cdr args) (cdr a2)))
-		((atom (cdr a2))
-		 (rplacd a1 (car a2))
-		 (apply function (cons arg args)))))))
-
-
-(defun funcall (function &rest arguments)
-  "Calls Function with the given Arguments."
-  (apply function arguments))
-
-
-
-;;; Multiple-Value forms:
-
-(defun values (&rest values)
-  "Returns all of its arguments, in order, as values."
-  (values-list values))
-
-(defun values-list (list)
-  "Returns all of the elements of List, in order, as values."
-  (values-list list))
diff --git a/code/extensions.lisp b/code/extensions.lisp
deleted file mode 100644
index 8e7ea31c05dd1ba23d49cfaea3bfec80f09bdede..0000000000000000000000000000000000000000
--- a/code/extensions.lisp
+++ /dev/null
@@ -1,349 +0,0 @@
-;;; -*- Log: code.log; Package: Extensions -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; Spice Lisp extensions to the language.
-;;;
-;;; Letf written by Steven Handerson.
-;;;
-;;; **********************************************************************
-(in-package "EXTENSIONS")
-
-(export '(letf* letf dovector deletef indenting-further
-		read-char-no-edit listen-skip-whitespace concat-pnames
-		iterate once-only collect do-anonymous undefined-value))
-
-(import 'lisp::whitespace-char-p)
-
-
-;;; Undefined-Value  --  Public
-;;;
-;;;    This is here until we figure out what to do with it.
-;;;
-(proclaim '(inline undefined-value))
-(defun undefined-value ()
-  '%undefined%)
-
-
-(defun skip-whitespace (&optional (stream *standard-input*))
-  (loop (let ((char (read-char stream)))
-	  (if (not (lisp::whitespacep char))
-	      (return (unread-char char stream))))))
-
-  
-(defun listen-skip-whitespace (&optional (stream *standard-input*))
-  "See listen.  Any whitespace in the input stream will be flushed."
-  (do ((char (read-char-no-hang stream nil nil nil)
-	     (read-char-no-hang stream nil nil nil)))
-      ((null char) nil)
-    (cond ((not (whitespace-char-p char))
-	   (unread-char char stream)
-	   (return T)))))
-
-;;; These macros waste time as opposed to space.
-
-(defmacro letf* (bindings &body body &environment env)
-  "Does what one might expect, saving the old values and setting the generalized
-  variables to the new values in sequence.  Unwind-protects and get-setf-method
-  are used to preserve the semantics one might expect in analogy to let*,
-  and the once-only evaluation of subforms."
-  (labels ((do-bindings
-	    (bindings)
-	    (cond ((null bindings) body)
-		  (t (multiple-value-bind (dummies vals newval setter getter)
-					  (lisp::foo-get-setf-method (caar bindings) env)
-		       (let ((save (gensym)))
-			 `((let* (,@(mapcar #'list dummies vals)
-				  (,(car newval) ,(cadar bindings))
-				  (,save ,getter))
-			     (unwind-protect
-			       (progn ,setter
-				      ,@(do-bindings (cdr bindings)))
-			       (setq ,(car newval) ,save)
-			       ,setter)))))))))
-    (car (do-bindings bindings))))
-
-
-(defmacro letf (bindings &body body &environment env)
-  "Like letf*, but evaluates all the implicit subforms and new values of all
-  the implied setfs before altering any values.  However, the store forms
-  (see get-setf-method) must still be evaluated in sequence.  Uses unwind-
-  protects to protect the environment."
-  (let (temps)
-    (labels
-      ((do-bindings
-	(bindings)
-	(cond ((null bindings) body)
-	      (t (let ((binding (car bindings)))
-		   (multiple-value-bind (dummies vals newval setter getter)
-					(lisp::foo-get-setf-method (car binding) env)
-		     (let ((save (gensym)))
-		       (mapcar #'(lambda (a b) (push (list a b) temps))
-			       dummies vals) 
-		       (push (list save getter) temps)
-		       (push (list (car newval) (cadr binding)) temps)
-		       `((unwind-protect
-			   (progn ,setter
-				  ,@(do-bindings (cdr bindings)))
-			   (setq ,(car newval) ,save)
-			   ,setter)))))))))
-      (let ((form (car (do-bindings bindings))))
-	`(let* ,(nreverse temps)
-	   ,form)))))
-
-
-(define-setf-method logbitp (index int &environment env)
-  (multiple-value-bind (temps vals stores store-form access-form)
-		       (lisp::foo-get-setf-method int env)
-    (let ((ind (gensym))
-	  (store (gensym))
-	  (stemp (first stores)))
-      (values `(,ind ,@temps)
-	      `(,index
-		,@vals)
-	      (list store)
-	      `(let ((,stemp
-		      (dpb (if ,store 1 0) (byte 1 ,ind) ,access-form)))
-		 ,store-form
-		 ,store)
-	      `(logbitp ,ind ,access-form)))))
-
-
-;;; Indenting-Further is a user-level macro which may be used to locally increment
-;;; the indentation of a stream.
-
-(defmacro indenting-further (stream more &rest body)
-  "Causes the output of the indenting Stream to indent More spaces.  More is
-  evaluated twice."
-  `(unwind-protect
-     (progn
-      (incf (lisp::indenting-stream-indentation ,stream) ,more)
-      ,@body)
-     (decf (lisp::indenting-stream-indentation ,stream) ,more)))
-
-
-;;; Deletef
-
-(defmacro deletef (elt list &rest keys &environment env)
-  (multiple-value-bind (dummies vals newval setter getter)
-		       (lisp::foo-get-setf-method list env)
-    (let ((eltsym (gensym))
-	  (listsym (gensym)))
-      `(let* ((,eltsym ,elt)
-	      ,@(mapcar #'list dummies vals)
-	      (,listsym ,getter)
-	      (,(car newval) (delete ,eltsym ,listsym ,@keys)))
-	 ,setter))))
-
-
-(defmacro dovector ((elt vector) &rest forms)
-  "Just like dolist, but with one-dimensional arrays."
-  (let ((index (gensym))
-	(length (gensym))
-	(vec (gensym)))
-    `(let ((,vec ,vector))
-       (do ((,index 0 (1+ ,index))
-	    (,length (length ,vec)))
-	   ((>= ,index ,length) nil)
-	 (let ((,elt (aref ,vec ,index)))
-	   ,@forms)))))
-
-
-(eval-when (compile load eval)
-  (defun concat-pnames (name1 name2)
-    (if name1
-	(intern (concatenate 'simple-string (symbol-name name1)
-			     (symbol-name name2)))
-	name2)))
-
-
-;;; Iterate  --  Public
-;;;
-;;;    The ultimate iteration macro...
-;;;
-(defmacro iterate (name binds &body body)
-  "Iterate Name ({(Var Initial-Value)}*) Declaration* Form*
-  This is syntactic sugar for Labels.  It creates a local function Name with
-  the specified Vars as its arguments and the Declarations and Forms as its
-  body.  This function is then called with the Initial-Values, and the result
-  of the call is return from the macro."
-  (dolist (x binds)
-    (unless (and (listp x)
-		 (= (length x) 2))
-      (error "Malformed iterate variable spec: ~S." x)))
-  
-  `(labels ((,name ,(mapcar #'first binds) ,@body))
-     (,name ,@(mapcar #'second binds))))
-
-
-;;;; The Collect macro:
-
-;;; Collect-Normal-Expander  --  Internal
-;;;
-;;;    This function does the real work of macroexpansion for normal collection
-;;; macros.  N-Value is the name of the variable which holds the current
-;;; value.  Fun is the function which does collection.  Forms is the list of
-;;; forms whose values we are supposed to collect.
-;;;
-(defun collect-normal-expander (n-value fun forms)
-  `(progn
-    ,@(mapcar #'(lambda (form) `(setq ,n-value (,fun ,form ,n-value))) forms)
-    ,n-value))
-
-;;; Collect-List-Expander  --  Internal
-;;;
-;;;    This function deals with the list collection case.  N-Tail is the pointer
-;;; to the current tail of the list, which is NIL if the list is empty.
-;;;
-(defun collect-list-expander (n-value n-tail forms)
-  (let ((n-res (gensym)))
-    `(progn
-      ,@(mapcar #'(lambda (form)
-		    `(let ((,n-res (cons ,form nil)))
-		       (cond (,n-tail
-			      (setf (cdr ,n-tail) ,n-res)
-			      (setq ,n-tail ,n-res))
-			     (t
-			      (setq ,n-tail ,n-res  ,n-value ,n-res)))))
-		forms)
-      ,n-value)))
-
-
-;;; Collect  --  Public
-;;;
-;;;    The ultimate collection macro...
-;;;
-(defmacro collect (collections &body body)
-  "Collect ({(Name [Initial-Value] [Function])}*) {Form}*
-  Collect some values somehow.  Each of the collections specifies a bunch of
-  things which collected during the evaluation of the body of the form.  The
-  name of the collection is used to define a local macro, a la MACROLET.
-  Within the body, this macro will evaluate each of its arguments and collect
-  the result, returning the current value after the collection is done.  The
-  body is evaluated as a PROGN; to get the final values when you are done, just
-  call the collection macro with no arguments.
-
-  Initial-Value is the value that the collection starts out with, which
-  defaults to NIL.  Function is the function which does the collection.  It is
-  a function which will accept two arguments: the value to be collected and the
-  current collection.  The result of the function is made the new value for the
-  collection.  As a totally magical special-case, the Function may be Collect,
-  which tells us to build a list in forward order; this is the default.  If an
-  Initial-Value is supplied for Collect, the stuff will be rplacd'd onto the
-  end.  Note that Function may be anything that can appear in the functional
-  position, including macros and lambdas."
-
-  (let ((macros ())
-	(binds ()))
-    (dolist (spec collections)
-      (unless (<= 1 (length spec) 3)
-	(error "Malformed collection specifier: ~S." spec))
-      (let ((n-value (gensym))
-	    (name (first spec))
-	    (default (second spec))
-	    (kind (or (third spec) 'collect)))
-	(push `(,n-value ,default) binds)
-	(if (eq kind 'collect)
-	    (let ((n-tail (gensym)))
-	      (if default
-		  (push `(,n-tail (last ,n-value)) binds)
-		  (push n-tail binds))
-	      (push `(,name (&rest args)
-			    (collect-list-expander ',n-value ',n-tail args))
-		    macros))
-	    (push `(,name (&rest args)
-			  (collect-normal-expander ',n-value ',kind args))
-		  macros))))
-    `(macrolet ,macros (let* ,(nreverse binds) ,@body))))
-
-
-;;;; The Once-Only macro:
-
-;;; Once-Only  --  Interface
-;;;
-;;;    Once-Only is a utility useful in writing source transforms and macros.
-;;; It provides an easy way to wrap a let around some code to ensure that some
-;;; forms are only evaluated once.
-;;;
-(defmacro once-only (specs &body body)
-  "Once-Only ({(Var Value-Expression)}*) Form*
-  Create Let which evaluates each Value-Expression, binding a temporary
-  variable to the result, and wrapping the Let around the result of the
-  evaluation of Body.  Within the body, each Var is bound to the corresponding
-  temporary variable.  If the Value-Expression is a constant, then we just pass
-  it through."
-  (let ((n-binds (gensym))
-	(n-temp (gensym)))
-    (collect ((names)
-	      (temp-binds))
-      (dolist (spec specs)
-	(when (/= (length spec) 2)
-	  (error "Malformed Once-Only binding spec: ~S." spec))
-	(let ((name (first spec))
-	      (exp (second spec)))
-	  (names `(,name ,exp))
-	  (temp-binds
-	   `(let ((,n-temp (gensym)))
-	      (,n-binds `(,,n-temp ,,name))
-	      (setq ,name ,n-temp)))))
-      `(let ,(names)
-	 (collect ((,n-binds))
-	   ,@(temp-binds)
-	   (list 'let (,n-binds) (progn ,@body)))))))
-
-
-;;;; DO-ANONYMOUS:
-
-;;; ### Bootstrap hack...  Renamed to avoid clobbering function in bootstrap
-;;; environment.
-;;;
-(defun lisp::do-do-body (varlist endlist code decl bind step name block)
-  (let* ((inits ())
-	 (steps ())
-	 (l1 (gensym))
-	 (l2 (gensym)))
-    ;; Check for illegal old-style do.
-    (when (or (not (listp varlist)) (atom endlist))
-      (error "Ill-formed ~S -- possibly illegal old style DO?" name))
-    ;; Parse the varlist to get inits and steps.
-    (dolist (v varlist)
-      (cond ((symbolp v) (push v inits))
-	    ((listp v)
-	     (unless (symbolp (first v))
-	       (error "~S step variable is not a symbol: ~S" name (first v)))
-	     (case (length v)
-	       (1 (push (first v) inits))
-	       (2 (push v inits))
-	       (3 (push (list (first v) (second v)) inits)
-		  (setq steps (list* (third v) (first v) steps)))
-	       (t (error "~S is an illegal form for a ~S varlist." v name))))
-	    (t (error "~S is an illegal form for a ~S varlist." v name))))
-    ;; And finally construct the new form.
-    `(block ,BLOCK
-       (,bind ,(nreverse inits)
-	,@decl
-	(tagbody
-	 (go ,L2)
-	 ,L1
-	 ,@code
-	 (,step ,@(nreverse steps))
-  	 ,L2 
-	 (unless ,(car endlist) (go ,L1))
-	 (return-from ,BLOCK (progn ,@(cdr endlist))))))))
-
-
-(defmacro do-anonymous (varlist endlist &body (body decls))
-  "DO-ANONYMOUS ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form*
-  Like DO, but has no implicit NIL block.  Each Var is initialized in parallel
-  to the value of the specified Init form.  On subsequent iterations, the Vars
-  are assigned the value of the Step form (if any) in paralell.  The Test is
-  evaluated before each evaluation of the body Forms.  When the Test is true,
-  the the Exit-Forms are evaluated as a PROGN, with the result being the value
-  of the DO."
-  (lisp::do-do-body varlist endlist body decls 'let 'psetq
-		    'do-anonymous (gensym)))
diff --git a/code/fd-stream.lisp b/code/fd-stream.lisp
deleted file mode 100644
index 703ff0d33ec7fdb26d0b939c48809a53a85ee53f..0000000000000000000000000000000000000000
--- a/code/fd-stream.lisp
+++ /dev/null
@@ -1,1291 +0,0 @@
-;;; -*- Log: code.log; Package: LISP -*-
-
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; Streams for UNIX file descriptors.
-;;;
-;;; Written by William Lott, July 1989 - January 1990.
-;;; 
-;;; **********************************************************************
-
-
-(in-package "SYSTEM")
-
-(export '(fd-stream fd-stream-p fd-stream-fd make-fd-stream
-	  beep *beep-function* 
-	  output-raw-bytes
-	  *tty* *stdin* *stdout* *stderr*))
-
-
-(in-package "EXTENSIONS")
-
-(export '(*backup-extension*))
-
-
-(in-package "LISP")
-
-(defmacro byte-blt (src-string src-start dst-string dst-start dst-end)
-  "Move the bytes from src-string to dst-string."
-  `(system:%primitive byte-blt
-		      ,src-string
-		      ,src-start
-		      ,dst-string
-		      ,dst-start
-		      ,dst-end))
-
-
-;;;; Buffer manipulation routines.
-
-(defvar *available-buffers* ()
-  "List of available buffers. Each buffer is an dynamic alien.")
-
-(defconstant bytes-per-buffer (* 4 1024)
-  "Number of bytes per buffer.")
-
-;;; NEXT-AVAILABLE-BUFFER -- Internal.
-;;;
-;;; Returns the next available alien buffer, creating one if necessary.
-;;;
-(proclaim '(inline next-available-buffer))
-;;;
-(defun next-available-buffer ()
-  (if *available-buffers*
-      (pop *available-buffers*)
-      (system:make-alien 'alien (* bytes-per-buffer 8))))
-
-
-
-;;;; The FD-STREAM structure.
-
-(defstruct (fd-stream
-	    (:print-function %print-fd-stream)
-	    (:constructor %make-fd-stream)
-	    (:include stream
-		      (misc #'fd-stream-misc-routine)))
-
-  (name nil)		      ; The name of this stream
-  (file nil)		      ; The file this stream is for
-  (original nil)	      ; The original file (for :if-exists :rename)
-  (delete-original nil)	      ; for :if-exists :rename-and-delete
-  (element-size 1)	      ; Number of bytes per element.
-  (element-type 'string-char) ; The type of element being transfered.
-  (fd -1 :type fixnum)	      ; The file descriptor
-  (buffering :full)	      ; One of :none, :line, or :full
-  (char-pos nil)	      ; Character position if known.
-  (listen nil)		      ; T if we don't need to listen
-
-  ;; The input buffer.
-  (unread nil)
-  (ibuf nil)
-  (ibuf-sap nil)
-  (ibuf-length nil)
-  (ibuf-head 0 :type fixnum)
-  (ibuf-tail 0 :type fixnum)
-
-  ;; The output buffer.
-  (obuf nil)
-  (obuf-sap nil)
-  (obuf-length nil)
-  (obuf-tail 0 :type fixnum)
-
-  ;; Output flushed, but not written due to non-blocking io.
-  (output-later nil)
-  (handler nil))
-
-(defun %print-fd-stream (fd-stream stream depth)
-  (declare (ignore depth))
-  (format stream "#<Stream for ~A>"
-	  (fd-stream-name fd-stream)))
-
-
-
-;;;; Output routines and related noise.
-
-(defvar *output-routines* ()
-  "List of all available output routines. Each element is a list of the
-  element-type output, the kind of buffering, the function name, and the number
-  of bytes per element.")
-
-;;; DO-OUTPUT-LATER -- internal
-;;;
-;;;   Called by the server when we can write to the given file descriptor.
-;;; Attemt to write the data again. If it worked, remove the data from the
-;;; output-later list. If it didn't work, something is wrong.
-;;;
-(defun do-output-later (stream)
-  (let* ((stuff (pop (fd-stream-output-later stream)))
-	 (base (car stuff))
-	 (start (cadr stuff))
-	 (end (caddr stuff))
-	 (buffer (cadddr stuff))
-	 (length (- end start)))
-    (multiple-value-bind
-	(count errno)
-	(mach:unix-write (fd-stream-fd stream)
-			 base
-			 start
-			 length)
-      (cond ((eql count length) ; Hot damn, it workded.
-	     (when buffer
-	       (push buffer *available-buffers*)))
-	    ((not (null count)) ; Sorta worked.
-	     (push (list base
-			 (+ start count)
-			 end
-			 buffer)
-		   (fd-stream-output-later stream)))
-	    ((= errno mach:ewouldblock)
-	     (error "Write would have blocked, but SERVER told us to go."))
-	    (t
-	     (error "While writing ~S: ~A"
-		    stream
-		    (mach:get-unix-error-msg errno))))))
-  (unless (fd-stream-output-later stream)
-    (system:remove-fd-handler (fd-stream-handler stream))
-    (setf (fd-stream-handler stream) nil)))
-
-;;; OUTPUT-LATER -- internal
-;;;
-;;;   Arange to output the string when we can write on the file descriptor.
-;;;
-(defun output-later (stream base start end buffer)
-  (cond ((null (fd-stream-output-later stream))
-	 (setf (fd-stream-output-later stream)
-	       (list (list base start end buffer)))
-	 (setf (fd-stream-handler stream)
-	       (system:add-fd-handler (fd-stream-fd stream)
-				      :output
-				      #'(lambda (fd)
-					  (declare (ignore fd))
-					  (do-output-later stream)))))
-	(t
-	 (nconc (fd-stream-output-later stream)
-		(list (list base start end buffer)))))
-  (when buffer
-    (let ((new-buffer (next-available-buffer)))
-      (setf (fd-stream-obuf stream) new-buffer)
-      (setf (fd-stream-obuf-sap stream)
-	    (system:alien-sap new-buffer))
-      (setf (fd-stream-obuf-length stream)
-	    (/ (system:alien-size new-buffer) 8)))))
-
-;;; DO-OUTPUT -- internal
-;;;
-;;;   Output the given noise. Check to see if there are any pending writes. If
-;;; so, just queue this one. Otherwise, try to write it. If this would block,
-;;; queue it.
-;;;
-(defun do-output (stream base start end buffer)
-  (if (not (null (fd-stream-output-later stream))) ; something buffered.
-    (progn
-      (output-later stream base start end buffer)
-      ;; XXX check to see if any of this noise can be output
-      )
-    (let ((length (- end start)))
-      (multiple-value-bind
-	  (count errno)
-	  (mach:unix-write (fd-stream-fd stream) base start length)
-	(cond ((eql count length)) ; Hot damn, it worked.
-	      ((not (null count))
-	       (output-later stream base (+ start count) end buffer))
-	      ((= errno mach:ewouldblock)
-	       (output-later stream base start end buffer))
-	      (t
-	       (error "While writing ~S: ~A"
-		      stream
-		      (mach:get-unix-error-msg errno))))))))
-
-;;; FLUSH-OUTPUT-BUFFER -- internal
-;;;
-;;;   Flush any data in the output buffer.
-;;;
-(defun flush-output-buffer (stream)
-  (let ((length (fd-stream-obuf-tail stream)))
-    (unless (= length 0)
-      (do-output stream
-		 (fd-stream-obuf-sap stream)
-		 0
-		 length
-		 (fd-stream-obuf stream))
-      (setf (fd-stream-obuf-tail stream) 0))))
-
-;;; DEF-OUTPUT-ROUTINES -- internal
-;;;
-;;;   Define output routines that output numbers size bytes long for the
-;;; given bufferings. Use body to do the actual output.
-;;;
-(defmacro def-output-routines ((name size &rest bufferings) &body body)
-  (cons 'progn
-	(mapcar
-	    #'(lambda (buffering)
-		(let ((function
-		       (intern (let ((*print-case* :upcase))
-				 (format nil name (car buffering))))))
-		  `(progn
-		     (defun ,function (stream byte)
-		       ,(unless (eq (car buffering) :none)
-			  `(when (< (fd-stream-obuf-length stream)
-				    (+ (fd-stream-obuf-tail stream)
-				       ,size))
-			     (flush-output-buffer stream)))
-		       ,@body
-		       (incf (fd-stream-obuf-tail stream) ,size)
-		       ,(ecase (car buffering)
-			  (:none
-			   `(flush-output-buffer stream))
-			  (:line
-			   `(when (eq (char-code byte) (char-code #\Newline))
-			      (flush-output-buffer stream)))
-			  (:full
-			   ))
-		       (values))
-		     (setf *output-routines*
-			   (nconc *output-routines*
-				  ',(mapcar
-					#'(lambda (type)
-					    (list type
-						  (car buffering)
-						  function
-						  size))
-				      (cdr buffering)))))))
-	  bufferings)))
-
-(def-output-routines ("OUTPUT-BYTE-~A-BUFFERED"
-		      1
-		      (:none (signed-byte 8) (unsigned-byte 8) string-char)
-		      (:line string-char)
-		      (:full (signed-byte 8) (unsigned-byte 8) string-char))
-  (when (characterp byte)
-    (if (eq (char-code byte)
-	    (char-code #\Newline))
-      (setf (fd-stream-char-pos stream) 0)
-      (incf (fd-stream-char-pos stream))))
-  (system:%primitive 8bit-system-set
-		     (fd-stream-obuf-sap stream)
-		     (fd-stream-obuf-tail stream)
-		     byte))
-
-(def-output-routines ("OUTPUT-SHORT-~A-BUFFERED"
-		      2
-		      (:none (signed-byte 16) (unsigned-byte 16))
-		      (:full (signed-byte 16) (unsigned-byte 16)))
-  (system:%primitive 16bit-system-set
-		     (fd-stream-obuf-sap stream)
-		     (/ (fd-stream-obuf-tail stream) 2)
-		     byte))
-(def-output-routines ("OUTPUT-SIGNED-LONG-~A-BUFFERED"
-		      4
-		      (:none (signed-byte 32))
-		      (:full (signed-byte 32)))
-  (system:%primitive signed-32bit-system-set
-		     (fd-stream-obuf-sap stream)
-		     (/ (fd-stream-obuf-tail stream) 2)
-		     byte))
-; XXX What? no unsigned-32bit-system-set?
-(def-output-routines ("OUTPUT-UNSIGNED-LONG-~A-BUFFERED"
-		      4
-		      (:none (unsigned-byte 31))
-		      (:full (unsigned-byte 31)))
-  (system:%primitive signed-32bit-system-set
-		     (fd-stream-obuf-sap stream)
-		     (/ (fd-stream-obuf-tail stream) 2)
-		     byte))
-
-;;; OUTPUT-RAW-BYTES -- public
-;;;
-;;;   Does the actual output. If there is space to buffer the string, buffer
-;;; it. If the string would normally fit in the buffer, but doesn't because
-;;; of other stuff in the buffer, flush the old noise out of the buffer and
-;;; put the string in it. Otherwise we have a very long string, so just
-;;; send it directly (after flushing the buffer, of course).
-;;;
-(defun output-raw-bytes (stream thing &optional start end)
-  "Output THING to stream.  THING can be any kind of vector or a sap.  If THING
-  is a SAP, END must be supplied (as length won't work)."
-  (let ((start (or start 0))
-	(end (or end (length thing))))
-    (declare (fixnum start end))
-    (let* ((len (fd-stream-obuf-length stream))
-	   (tail (fd-stream-obuf-tail stream))
-	   (space (- len tail))
-	   (bytes (- end start))
-	   (newtail (+ tail bytes)))
-      (cond ((minusp bytes) ; Error case
-	     (cerror "Just go on as if nothing happened..."
-		     "~S called with :END before :START!"
-		     'output-raw-bytes))
-	    ((zerop bytes)) ; Easy case
-	    ((<= bytes space)
-	     (byte-blt thing start (fd-stream-obuf-sap stream) tail newtail)
-	     (setf (fd-stream-obuf-tail stream) newtail))
-	    ((<= bytes len)
-	     (flush-output-buffer stream)
-	     (byte-blt thing start (fd-stream-obuf-sap stream) 0 bytes)
-	     (setf (fd-stream-obuf-tail stream) bytes))
-	    (t
-	     (flush-output-buffer stream)
-	     (do-output stream thing start end nil))))))
-
-;;; FD-SOUT -- internal
-;;;
-;;;   Routine to use to output a string. If the stream is unbuffered, slam
-;;; the string down the file descriptor, otherwise use OUTPUT-RAW-BYTES to
-;;; buffer the string. Update charpos by checking to see where the last newline
-;;; was.
-;;;
-;;;   Note: some bozos (the FASL dumper) call write-string with things other
-;;; than strings. Therefore, we must make sure we have a string before calling
-;;; position on it.
-;;; 
-(defun fd-sout (stream thing start end)
-  (let ((start (or start 0))
-	(end (or end (length thing))))
-    (declare (fixnum start end))
-    (if (stringp thing)
-      (let ((last-newline (and (find #\newline (the simple-string thing)
-				     :start start :end end)
-			       (position #\newline (the simple-string thing)
-					    :from-end t
-					    :start start
-					    :end end))))
-	(ecase (fd-stream-buffering stream)
-	  (:full
-	   (output-raw-bytes stream thing start end))
-	  (:line
-	   (output-raw-bytes stream thing start end)
-	   (when last-newline
-	     (flush-output-buffer stream)))
-	  (:none
-	   (do-output stream thing start end nil)))
-	(if last-newline
-	  (setf (fd-stream-char-pos stream)
-		(- end last-newline 1))
-	  (incf (fd-stream-char-pos stream)
-		(- end start))))
-      (ecase (fd-stream-buffering stream)
-	((:line :full)
-	 (output-raw-bytes stream thing start end))
-	(:none
-	 (do-output stream thing start end nil))))))
-
-;;; PICK-OUTPUT-ROUTINE -- internal
-;;;
-;;;   Find an output routine to use given the type and buffering. Return as
-;;; multiple values the routine, the real type transfered, and the number of
-;;; bytes per element.
-;;;
-(defun pick-output-routine (type buffering)
-  (dolist (entry *output-routines*)
-    (when (and (subtypep type (car entry))
-	       (eq buffering (cadr entry)))
-      (return (values (symbol-function (caddr entry))
-		      (car entry)
-		      (cadddr entry))))))
-
-
-;;;; Input routines and related noise.
-
-(defvar *input-routines* ()
-  "List of all available input routines. Each element is a list of the
-  element-type input, the function name, and the number of bytes per element.")
-
-;;; DO-INPUT -- internal
-;;;
-;;;   Fills the input buffer, and returns the first character. Throws to
-;;; eof-input-catcher if the eof was reached. Drops into system:server if
-;;; necessary.
-;;;
-(defun do-input (stream)
-  (let ((fd (fd-stream-fd stream))
-	(ibuf-sap (fd-stream-ibuf-sap stream))
-	(buflen (fd-stream-ibuf-length stream))
-	(head (fd-stream-ibuf-head stream))
-	(tail (fd-stream-ibuf-tail stream)))
-    (unless (zerop head)
-      (cond ((eq head tail)
-	     (setf head 0)
-	     (setf tail 0)
-	     (setf (fd-stream-ibuf-head stream) 0)
-	     (setf (fd-stream-ibuf-tail stream) 0))
-	    (t
-	     (decf tail head)
-	     (byte-blt ibuf-sap head ibuf-sap 0 tail)
-	     (setf head 0)
-	     (setf (fd-stream-ibuf-head stream) 0)
-	     (setf (fd-stream-ibuf-tail stream) tail))))
-    (setf (fd-stream-listen stream) nil)
-    (multiple-value-bind
-	(count errno)
-	(mach:unix-select (1+ fd) (ash 1 fd) 0 0 0)
-      (case count
-	(1)
-	(0
-	 (system:wait-until-fd-usable fd :input))
-	(t
-	 (error "Problem checking to see if ~S is readable: ~A"
-		stream
-		(mach:get-unix-error-msg errno)))))
-    (multiple-value-bind
-	(count errno)
-	(mach:unix-read fd
-			(system:int-sap (+ (system:sap-int ibuf-sap) tail))
-			(- buflen tail))
-      (cond ((null count)
-	     (if (eql errno mach:ewouldblock)
-	       (progn
-		 (system:wait-until-fd-usable fd :input)
-		 (do-input stream))
-	       (error "Error reading ~S: ~A"
-		      stream
-		      (mach:get-unix-error-msg errno))))
-	    ((zerop count)
-	     (throw 'eof-input-catcher nil))
-	    (t
-	     (incf (fd-stream-ibuf-tail stream) count))))))
-			
-;;; INPUT-AT-LEAST -- internal
-;;;
-;;;   Makes sure there are at least ``bytes'' number of bytes in the input
-;;; buffer. Keeps calling do-input until that condition is met.
-;;;
-(defmacro input-at-least (stream bytes)
-  (let ((stream-var (gensym))
-	(bytes-var (gensym)))
-    `(let ((,stream-var ,stream)
-	   (,bytes-var ,bytes))
-       (loop
-	 (when (>= (- (fd-stream-ibuf-tail ,stream-var)
-		      (fd-stream-ibuf-head ,stream-var))
-		   ,bytes-var)
-	   (return))
-	 (do-input ,stream-var)))))
-
-;;; INPUT-WRAPPER -- intenal
-;;;
-;;;   Macro to wrap around all input routines to handle eof-error noise. This
-;;; should make provisions for filling stream-in-buffer.
-;;;
-(defmacro input-wrapper ((stream bytes eof-error eof-value) &body read-forms)
-  (let ((stream-var (gensym))
-	(element-var (gensym)))
-    `(let ((,stream-var ,stream))
-       (if (fd-stream-unread ,stream)
-	 (prog1
-	     (fd-stream-unread ,stream)
-	   (setf (fd-stream-unread ,stream) nil))
-	 (let ((,element-var
-		(catch 'eof-input-catcher
-		  (input-at-least ,stream-var ,bytes)
-		  ,@read-forms)))
-	   (cond (,element-var
-		  (incf (fd-stream-ibuf-head ,stream-var) ,bytes)
-		  ,element-var)
-		 (,eof-error
-		  (error "EOF while reading ~S" stream))
-		 (t
-		  ,eof-value)))))))
-
-;;; DEF-INPUT-ROUTINE -- internal
-;;;
-;;;   Defines an input routine.
-;;;
-(defmacro def-input-routine (name
-			     (type size sap head)
-			     &rest body)
-  `(progn
-     (defun ,name (stream eof-error eof-value)
-       (input-wrapper (stream ,size eof-error eof-value)
-	 (let ((,sap (fd-stream-ibuf-sap stream))
-	       (,head (fd-stream-ibuf-head stream)))
-	   ,@body)))
-     (setf *input-routines*
-	   (nconc *input-routines*
-		  (list (list ',type ',name ',size))))))
-
-;;; INPUT-STRING-CHAR -- internal
-;;;
-;;;   Routine to use in stream-in slot for reading string chars.
-;;;
-(def-input-routine input-string-char
-		   (string-char 1 sap head)
-  (system:%primitive make-immediate-type
-		     (system:%primitive 8bit-system-ref sap head)
-		     ; XXX character-type, should be a constant.
-		     27))
-
-;;; INPUT-UNSIGNED-8BIT-BYTE -- internal
-;;;
-;;;   Routine to read in an unsigned 8 bit number.
-;;;
-(def-input-routine input-unsigned-8bit-byte
-		   ((unsigned-byte 8) 1 sap head)
-  (system:%primitive 8bit-system-ref sap head))
-
-;;; INPUT-SIGNED-8BIT-BYTE -- internal
-;;;
-;;;   Routine to read in a signed 8 bit number.
-;;;
-(def-input-routine input-signed-8bit-number
-		   ((signed-byte 8) 1 sap head)
-  (let ((byte (system:%primitive 8bit-system-ref sap head)))
-    (if (logand byte #x80)
-      (- byte #x100)
-      byte)))
-
-;;; INPUT-UNSIGNED-16BIT-BYTE -- internal
-;;;
-;;;   Routine to read in an unsigned 16 bit number.
-;;;
-(def-input-routine input-unsigned-16bit-byte
-		   ((unsigned-byte 16) 2 sap head)
-  (system:%primitive 16bit-system-ref
-		     sap
-		     (/ head 2)))
-
-;;; INPUT-SIGNED-16BIT-BYTE -- internal
-;;;
-;;;   Routine to read in a signed 16 bit number.
-;;;
-(def-input-routine input-signed-16bit-byte
-		   ((signed-byte 16) 2 sap head)
-  (system:%primitive signed-16bit-system-ref
-		     sap
-		     (/ head 2)))
-
-;;; INPUT-UNSIGNED-32BIT-BYTE -- internal
-;;;
-;;;   Routine to read in a unsigned 32 bit number.
-;;;
-(def-input-routine input-unsigned-32bit-byte
-		   ((unsigned-byte 32) 4 sap head)
-  (system:%primitive unsigned-32bit-system-ref
-		     sap
-		     (/ head 2)))
-
-;;; INPUT-SIGNED-32BIT-BYTE -- internal
-;;;
-;;;   Routine to read in a signed 32 bit number.
-;;;
-(def-input-routine input-signed-32bit-byte
-		   ((signed-byte 32) 4 sap head)
-  (system:%primitive signed-32bit-system-ref
-		     sap
-		     (/ head 2)))
-
-;;; PICK-INPUT-ROUTINE -- internal
-;;;
-;;;   Find an input routine to use given the type. Return as multiple values
-;;; the routine, the real type transfered, and the number of bytes per element.
-;;;
-(defun pick-input-routine (type)
-  (dolist (entry *input-routines*)
-    (when (subtypep type (car entry))
-      (return (values (symbol-function (cadr entry))
-		      (car entry)
-		      (caddr entry))))))
-
-;;; STRING-FROM-SAP -- internal
-;;;
-;;;   Returns a string constructed from the sap, start, and end.
-;;;
-(defun string-from-sap (sap start end)
-  (let* ((length (- end start))
-	 (string (make-string length)))
-    (byte-blt sap start string 0 length)
-    string))
-
-;;; FD-STREAM-READ-LINE -- internal
-;;;
-;;;   Reads a line, returning a simple string. Note: this relies on the fact
-;;; that the input buffer does not change during do-input.
-;;;
-(defun fd-stream-read-line (stream eof-error-p eof-value)
-  (let ((eof t))
-    (values
-     (or (let ((sap (fd-stream-ibuf-sap stream))
-	       (results (if (fd-stream-unread stream)
-			  (prog1
-			      (string (fd-stream-unread stream))
-			    (setf (fd-stream-unread stream) nil)))))
-	   (catch 'eof-input-catcher
-	     (loop
-	       (input-at-least stream 1)
-	       (let* ((head (fd-stream-ibuf-head stream))
-		      (tail (fd-stream-ibuf-tail stream))
-		      (newline (system:%primitive find-character
-						  sap
-						  head
-						  tail
-						  #\Newline))
-		      (end (or newline tail)))
-		 (push (string-from-sap sap head end)
-		       results)
-
-		 (when newline
-		   (setf eof nil)
-		   (setf (fd-stream-ibuf-head stream)
-			 (1+ newline))
-		   (return))
-		 (setf (fd-stream-ibuf-head stream) end))))
-	   (cond ((null results)
-		  nil)
-		 ((null (cdr results))
-		  (car results))
-		 (t
-		  (apply #'concatenate 'simple-string (nreverse results)))))
-	 (if eof-error-p
-	   (error "EOF while reading ~S" stream)
-	   eof-value))
-     eof)))
-
-
-;;; FD-STREAM-READ-N-BYTES -- internal
-;;;
-;;; The n-bin routine.
-;;; 
-(defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p)
-  (let* ((sap (fd-stream-ibuf-sap stream))
-	 (elsize (fd-stream-element-size stream))
-	 (offset (* elsize start))
-	 (bytes (* elsize requested))
-	 (result (catch 'eof-input-catcher
-		   (loop
-		     (input-at-least stream 1)
-		     (let* ((head (fd-stream-ibuf-head stream))
-			    (tail (fd-stream-ibuf-tail stream))
-			    (available (- tail head))
-			    (copy (min available bytes)))
-		       (byte-blt sap head buffer offset (+ offset copy))
-		       (incf (fd-stream-ibuf-head stream) copy)
-		       (incf offset copy)
-		       (decf bytes copy))
-		     (when (zerop bytes)
-		       (return requested))))))
-    (cond (result)
-	  ((not eof-error-p)
-	   (- requested (/ bytes elsize)))
-	  (t
-	   (error "Hit eof on ~S after reading ~D ~D~2:*-bit byte~P~*, ~
-		   but ~D~2:* ~D-bit byte~P~:* ~[were~;was~:;were~] requested."
-		  stream
-		  (- requested (/ bytes elsize))
-		  (* elsize 8)
-		  requested)))))
-
-
-;;;; Utility functions (misc routines, etc)
-
-;;; SET-ROUTINES -- internal
-;;;
-;;;   Fill in the various routine slots for the given type. Input-p and output-p
-;;; indicate what slots to fill. The buffering slot must be set prior to
-;;; calling this routine.
-;;;
-(defun set-routines (stream type input-p output-p)
-  (let ((target-type (case type
-		       ((:default unsigned-byte)
-			'(unsigned-byte 8))
-		       (signed-byte
-			'(signed-byte 8))
-		       (t
-			type)))
-	(input-type nil)
-	(output-type nil)
-	(input-size nil)
-	(output-size nil))
-    
-    (when (fd-stream-obuf stream)
-      (push (fd-stream-obuf stream) *available-buffers*)
-      (setf (fd-stream-obuf stream) nil))
-    (when (fd-stream-ibuf stream)
-      (push (fd-stream-ibuf stream) *available-buffers*)
-      (setf (fd-stream-ibuf stream) nil))
-    
-    (when input-p
-      (multiple-value-bind
-	  (routine type size)
-	  (pick-input-routine target-type)
-	(unless routine
-	  (error "Could not find any input routine for ~S" target-type))
-	(setf (fd-stream-ibuf stream)
-	      (next-available-buffer))
-	(setf (fd-stream-ibuf-sap stream)
-	      (system:alien-sap (fd-stream-ibuf stream)))
-	(setf (fd-stream-ibuf-length stream)
-	      (/ (system:alien-size (fd-stream-ibuf stream)) 8))
-	(setf (fd-stream-ibuf-tail stream)
-	      0)
-	(if (subtypep type 'character)
-	  (setf (fd-stream-in stream) routine
-		(fd-stream-bin stream) #'ill-bin
-		(fd-stream-n-bin stream) #'ill-bin)
-	  (setf (fd-stream-in stream) #'ill-in
-		(fd-stream-bin stream) routine
-		(fd-stream-n-bin stream) #'fd-stream-read-n-bytes))
-	(setf input-size size)
-	(setf input-type type)))
-
-    (when output-p
-      (multiple-value-bind
-	  (routine type size)
-	  (pick-output-routine target-type (fd-stream-buffering stream))
-	(unless routine
-	  (error "Could not find any output routine for ~S buffered ~S."
-		 (fd-stream-buffering stream)
-		 target-type))
-	(setf (fd-stream-obuf stream) (next-available-buffer))
-	(setf (fd-stream-obuf-sap stream)
-	      (system:alien-sap (fd-stream-obuf stream)))
-	(setf (fd-stream-obuf-length stream)
-	      (/ (system:alien-size (fd-stream-obuf stream)) 8))
-	(setf (fd-stream-obuf-tail stream) 0)
-	(if (subtypep type 'character)
-	  (setf (fd-stream-out stream) routine
-		(fd-stream-bout stream) #'ill-bout)
-	  (setf (fd-stream-out stream)
-		(or (if (eql size 1)
-		      (pick-output-routine 'string-char
-					   (fd-stream-buffering stream)))
-		    #'ill-out)
-		(fd-stream-bout stream) routine))
-	(setf (fd-stream-sout stream)
-	      (if (eql size 1) #'fd-sout #'ill-out))
-	(setf (fd-stream-char-pos stream) 0)
-	(setf output-size size)
-	(setf output-type type)))
-
-    (when (and input-size output-size
-	       (not (eq input-size output-size)))
-      (error "Element sizes for input (~S:~S) and output (~S:~S) differ?"
-	     input-type input-size
-	     output-type output-size))
-    (setf (fd-stream-element-size stream)
-	  (or input-size output-size))
-
-    (setf (fd-stream-element-type stream)
-	  (cond ((equal input-type output-type)
-		 input-type)
-		((subtypep input-type output-type)
-		 input-type)
-		((subtypep output-type input-type)
-		 output-type)
-		(t
-		 (error "Input type (~S) and output type (~S) are unrelated?"
-			input-type
-			output-type))))))
-
-;;; FD-STREAM-MISC-ROUTINE -- input
-;;;
-;;;   Handle the various misc operations on fd-stream.
-;;;
-(defun fd-stream-misc-routine (stream operation &optional arg1 arg2)
-  (case operation
-    (:read-line
-     (fd-stream-read-line stream arg1 arg2))
-    (:listen
-     (or (not (eql (fd-stream-ibuf-head stream)
-		   (fd-stream-ibuf-tail stream)))
-	 (fd-stream-listen stream)
-	 (setf (fd-stream-listen stream)
-	       (not (zerop (mach:unix-select (1+ (fd-stream-fd stream))
-					     (ash 1 (fd-stream-fd stream))
-					     0
-					     0
-					     0))))))
-    (:unread
-     (setf (fd-stream-unread stream) arg1))
-    (:close
-     (cond (arg1
-	    ;; We got us an abort on our hands.
-	    (when (and (fd-stream-file stream)
-		       (fd-stream-obuf stream))
-	      ;; Can't do anything unless we know what file were dealing with,
-	      ;; and we don't want to do anything strange unless we were
-	      ;; writing to the file.
-	      (if (fd-stream-original stream)
-		  ;; Have an handle on the original, just revert.
-		  (multiple-value-bind
-		      (okay err)
-		      (mach:unix-rename (fd-stream-original stream)
-					(fd-stream-file stream))
-		    (unless okay
-		      (cerror "Go on as if nothing bad happened."
-		        "Could not restore ~S to it's original contents: ~A"
-			      (fd-stream-file stream)
-			      (mach:get-unix-error-msg err))))
-		  ;; Can't restore the orignal, so nuke that puppy.
-		  (multiple-value-bind
-		      (okay err)
-		      (mach:unix-unlink (fd-stream-file stream))
-		    (unless okay
-		      (cerror "Go on as if nothing bad happened."
-			      "Could not remove ~S: ~A"
-			      (fd-stream-file stream)
-			      (mach:get-unix-error-msg err)))))))
-	   (t
-	    (fd-stream-misc-routine stream :finish-output)
-	    (when (and (fd-stream-original stream)
-		       (fd-stream-delete-original stream))
-	      (multiple-value-bind
-		  (okay err)
-		  (mach:unix-unlink (fd-stream-original stream))
-		(unless okay
-		  (cerror "Go on as if nothing bad happened."
-			  "Could not delete ~S during close of ~S: ~A"
-			  (fd-stream-original stream)
-			  stream
-			  (mach:get-unix-error-msg err)))))))
-     (mach:unix-close (fd-stream-fd stream))
-     (when (fd-stream-obuf stream)
-       (push (fd-stream-obuf stream) *available-buffers*)
-       (setf (fd-stream-obuf stream) nil))
-     (when (fd-stream-ibuf stream)
-       (push (fd-stream-ibuf stream) *available-buffers*)
-       (setf (fd-stream-ibuf stream) nil))
-     (lisp::set-closed-flame stream))
-    (:clear-input)
-    (:force-output
-     (flush-output-buffer stream))
-    (:finish-output
-     (flush-output-buffer stream)
-     (do ()
-	 ((null (fd-stream-output-later stream)))
-       (system:serve-all-events)))
-    (:element-type
-     (fd-stream-element-type stream))
-    (:line-length
-     80)
-    (:charpos
-     (fd-stream-char-pos stream))
-    (:file-length
-     (multiple-value-bind
-	 (okay dev ino mode nlink uid gid rdev size
-	       atime mtime ctime blksize blocks)
-	 (mach:unix-fstat (fd-stream-fd stream))
-       (declare (ignore ino nlink uid gid rdev
-			atime mtime ctime blksize blocks))
-       (unless okay
-	 (error "Error fstating ~S: ~A"
-		stream
-		(mach:get-unix-error-msg dev)))
-       (if (zerop mode)
-	 nil
-	 (/ size (fd-stream-element-size stream)))))
-    (:file-position
-     (fd-stream-file-position stream arg1))
-    (:file-name
-     (fd-stream-file stream))))
-
-;;; FD-STREAM-FILE-POSITION -- internal.
-;;;
-(defun fd-stream-file-position (stream &optional newpos)
-  (if (null newpos)
-      (system:without-interrupts
-	;; First, find the position of the UNIX file descriptor in the
-	;; file.
-	(multiple-value-bind
-	    (posn errno)
-	    (mach:unix-lseek (fd-stream-fd stream) 0 mach:l_incr)
-	  (cond ((numberp posn)
-		 ;; Adjust for buffered output:
-		 ;;  If there is any output buffered, the *real* file position
-		 ;; will be larger than reported by lseek because lseek
-		 ;; obviously cannot take into account output we have not
-		 ;; sent yet.
-		 (dolist (later (fd-stream-output-later stream))
-		   (incf posn (- (caddr later) (cadr later))))
-		 (incf posn (fd-stream-obuf-tail stream))
-		 ;; Adjust for unread input:
-		 ;;  If there is any input read from UNIX but not supplied to
-		 ;; the user of the stream, the *real* file position will
-		 ;; smaller than reported, because we want to look like the
-		 ;; unread stuff is still available.
-		 (decf posn (- (fd-stream-ibuf-tail stream)
-			       (fd-stream-ibuf-head stream)))
-		 (when (fd-stream-unread stream)
-		   (decf posn))
-		 ;; Divide bytes by element size.
-		 (/ posn (fd-stream-element-size stream)))
-		((eq errno mach:espipe)
-		 nil)
-		(t
-		 (system:with-interrupts
-		   (error "Error lseek'ing ~S: ~A"
-			  stream
-			  (mach:get-unix-error-msg errno)))))))
-      (let (offset origin)
-	;; Make sure we don't have any output pending, because if we move the
-	;; file pointer before writing this stuff, it will be written in the
-	;; wrong location.
-	(flush-output-buffer stream)
-	(do ()
-	    ((null (fd-stream-output-later stream)))
-	  (system:serve-all-events))
-	(cond ((eq newpos :start)
-	       (setf offset 0 origin mach:l_set))
-	      ((eq newpos :end)
-	       (setf offset 0 origin mach:l_xtnd))
-	      ((numberp newpos)
-	       (setf offset (* newpos (fd-stream-element-size stream))
-		     origin mach:l_set))
-	      (t
-	       (error "Invalid position given to file-position: ~S" newpos)))
-	(multiple-value-bind
-	    (posn errno)
-	    (mach:unix-lseek (fd-stream-fd stream) offset origin)
-	  (cond ((numberp posn)
-		 t)
-		((eq errno mach:espipe)
-		 nil)
-		(t
-		 (error "Error lseek'ing ~S: ~A"
-			stream
-			(mach:get-unix-error-msg errno))))))))
-
-
-
-;;;; Creation routines (MAKE-FD-STREAM and OPEN)
-
-;;; MAKE-FD-STREAM -- Public.
-;;;
-;;; Returns a FD-STREAM on the given file.
-;;;
-(defun make-fd-stream (fd
-		       &key
-		       (input nil input-p)
-		       (output nil output-p)
-		       (element-type 'string-char)
-		       (buffering :full)
-		       file
-		       original
-		       delete-original
-		       (name (if file
-				 (format nil "file ~S" file)
-				 (format nil "descriptor ~D" fd))))
-  "Create a stream for the given unix file descriptor.  If input is non-nil,
-   allow input operations.  If output is non-nil, allow output operations. If
-   neither input nor output are specified, default to allowing input.
-   element-type indicates the element type to use (as for open).  Buffering
-   indicates the kind of buffering to use (one of :none, :line, or :full). If
-   file is spesified, it should be the name of the file.  Name is used to
-   identify the stream when printed."
-  (cond ((not (or input-p output-p))
-	 (setf input t))
-	((not (or input output))
-	 (error "File descriptor must be opened either for input or output.")))
-  (let ((stream (%make-fd-stream :fd fd
-				 :name name
-				 :file file
-				 :original original
-				 :delete-original delete-original
-				 :buffering buffering)))
-    (set-routines stream element-type input output)
-    stream))
-
-;;; PICK-PACKUP-NAME -- internal
-;;;
-;;; Pick a name to use for the backup file.
-;;;
-(defvar *backup-extension* ".BAK"
-  "This is a string that OPEN tacks on the end of a file namestring to produce
-   a name for the :if-exists :rename-and-delete and :rename options.  Also,
-   this can be a function that takes a namestring and returns a complete
-   namestring.")
-;;;
-(defun pick-backup-name (name)
-  (etypecase *backup-extension*
-    (string (concatenate 'simple-string name *backup-extension*))
-    (function (funcall *backup-extension* name))))
-
-;;; ASSURE-ONE-OF -- internal
-;;;
-;;; Assure that the given arg is one of the given list of valid things.
-;;; Allow the user to fix any problems.
-;;; 
-(defun assure-one-of (item list what)
-  (unless (member item list)
-    (loop
-      (cerror "Enter new value for ~*~S"
-	      "~S is invalid for ~S. Must be one of~{ ~S~}"
-	      item
-	      what
-	      list)
-      (format *query-io* "Enter new value for ~S: " what)
-      (force-output *query-io*)
-      (setf item (read *query-io*))
-      (when (member item list)
-	(return))))
-  item)
-
-;;; OPEN -- public
-;;;
-;;;   Open the given file.
-;;;
-(defun open (filename
-	     &key
-	     (direction :input)
-	     (element-type 'string-char)
-	     (if-exists nil if-exists-given)
-	     (if-does-not-exist nil if-does-not-exist-given))
-  "Return a stream which reads from or writes to Filename.
-  Defined keywords:
-   :direction - one of :input, :output, :io, or :probe
-   :element-type - Type of object to read or write, default STRING-CHAR
-   :if-exists - one of :error, :new-version, :rename, :rename-and-delete,
-                       :overwrite, :append, :supersede or nil
-   :if-does-not-exist - one of :error, :create or nil
-  See the manual for details."
-  ;; First, make sure that DIRECTION is valid. Allow it to be changed if not.
-  (setf direction
-	(assure-one-of direction
-		       '(:input :output :io :probe)
-		       :direction))
-
-  ;; Calculate useful stuff.
-  (multiple-value-bind
-      (input output mask)
-      (case direction
-	(:input (values t nil mach:o_rdonly))
-	(:output (values nil t mach:o_wronly))
-	(:io (values t t mach:o_rdwr))
-	(:probe (values nil nil mach:o_rdonly)))
-    (let* ((pathname (pathname filename))
-	   (namestring (predict-name pathname input)))
-      
-      ;; Process if-exists argument if we are doing any output.
-      (cond (output
-	     (unless if-exists-given
-	       (setf if-exists
-		     (if (eq (pathname-version pathname) :newest)
-		       :new-version
-		       :error)))
-	     (setf if-exists
-		   (assure-one-of if-exists
-				  '(:error :new-version :rename
-				    :rename-and-delete :overwrite
-				    :append :supersede nil)
-				  :if-exists))
-	     (case if-exists
-	       ((:error nil)
-		(setf mask (logior mask mach:o_excl)))
-	       ((:rename :rename-and-delete)
-		(setf mask (logior mask mach:o_creat)))
-	       ((:new-version :supersede)
-		(setf mask (logior mask mach:o_trunc)))
-	       (:append
-		(setf mask (logior mask mach:o_append)))))
-	    (t
-	     (setf if-exists :ignore-this-arg)))
-      
-      (unless if-does-not-exist-given
-	(setf if-does-not-exist
-	      (cond ((eq direction :input) :error)
-		    ((and output
-			  (member if-exists '(:overwrite :append)))
-		     :error)
-		    ((eq direction :probe)
-		     nil)
-		    (t
-		     :create))))
-      (setf if-does-not-exist
-	    (assure-one-of if-does-not-exist
-			   '(:error :create nil)
-			   :if-does-not-exist))
-      (if (eq if-does-not-exist :create)
-	(setf mask (logior mask mach:o_creat)))
-       
-      (let ((original (if (member if-exists
-				  '(:rename :rename-and-delete))
-			(pick-backup-name namestring)))
-	    (delete-original (eq if-exists :rename-and-delete))
-	    (mode #o666))
-	(when original
-	  ;; We are doing a :rename or :rename-and-delete.
-	  ;; Determine if the file already exists, make sure the original
-	  ;; file is not a directory and keep the mode
-	  (let ((exists
-		 (multiple-value-bind
-		     (okay err/dev inode orig-mode)
-		     (mach:unix-stat namestring)
-		   (declare (ignore inode))
-		   (cond (okay
-			  (when (and output (= (logand orig-mode #o170000)
-					       #o40000))
-			    (error "Cannot open ~S for output: Is a directory."
-				   namestring))
-			  (setf mode (logand orig-mode #o777))
-			  t)
-			 ((eql err/dev mach:enoent)
-			  nil)
-			 (t
-			  (error "Cannot find ~S: ~A"
-				 namestring
-				 (mach:get-unix-error-msg err/dev)))))))
-	    (when (or (not exists)
-		      ;; Do the rename.
-		      (multiple-value-bind
-			  (okay err)
-			  (mach:unix-rename namestring original)
-			(unless okay
-			  (cerror "Use :SUPERSEDE instead."
-				  "Could not rename ~S to ~S: ~A."
-				  namestring
-				  original
-				  (mach:get-unix-error-msg err))
-			  t)))
-	      (setf original nil)
-	      (setf delete-original nil)
-	      ;; In order to use SUPERSEDE instead, we have
-	      ;; to make sure mach:o_creat corresponds to
-	      ;; if-does-not-exist.  mach:o_creat was set
-	      ;; before because of if-exists being :rename.
-	      (unless (eq if-does-not-exist :create)
-		(setf mask (logior (logandc2 mask mach:o_creat) mach:o_trunc)))
-	      (setf if-exists :supersede))))
-	
-	;; Okay, now we can try the actual open.
-	(multiple-value-bind
-	    (fd errno)
-	    (mach:unix-open namestring mask mode)
-	  (cond ((numberp fd)
-		 (case direction
-		   ((:input :output :io)
-		    (make-fd-stream fd
-				    :input input
-				    :output output
-				    :element-type element-type
-				    :file namestring
-				    :original original
-				    :delete-original delete-original))
-		   (:probe
-		    (let ((stream (%make-fd-stream :name namestring
-						   :fd fd
-						   :element-type element-type)))
-		      (close stream)
-		      stream))))
-		((eql errno mach:enoent)
-		 (case if-does-not-exist
-		   (:error
-		    (cerror "Return NIL."
-			    "Error opening ~S, ~A."
-			    pathname
-			    (mach:get-unix-error-msg errno)))
-		   (:create
-		    (cerror "Return NIL."
-			    "Error creating ~S, path does not exist."
-			    pathname)))
-		 nil)
-		((eql errno mach:eexist)
-		 (unless (eq nil if-exists)
-		   (cerror "Return NIL."
-			   "Error opening ~S, ~A."
-			   pathname
-			   (mach:get-unix-error-msg errno)))
-		 nil)
-		(t
-		 (cerror "Return NIL."
-			 "Error opening ~S, ~A."
-			 pathname
-			 (mach:get-unix-error-msg errno))
-		 nil)))))))
-
-;;;; Initialization.
-
-(defvar *tty* nil
-  "The stream connected to the controlling terminal or NIL if there is none.")
-(defvar *stdin* nil
-  "The stream connected to the standard input (file descriptor 0).")
-(defvar *stdout* nil
-  "The stream connected to the standard output (file descriptor 1).")
-(defvar *stderr* nil
-  "The stream connected to the standard error output (file descriptor 2).")
-
-;;; STREAM-INIT -- internal interface
-;;;
-;;; Called when the cold load is first started up.
-;;; 
-(defun stream-init ()
-  (stream-reinit)
-  (setf *terminal-io* (make-synonym-stream '*tty*))
-  (setf *standard-input* (make-synonym-stream '*stdin*))
-  (setf *standard-output* (make-synonym-stream '*stdout*))
-  (setf *error-output* (make-synonym-stream '*stderr*))
-  (setf *query-io* (make-synonym-stream '*terminal-io*))
-  (setf *debug-io* *query-io*)
-  (setf *trace-output* *standard-output*)
-  nil)
-
-;;; STREAM-REINIT -- internal interface
-;;;
-;;; Called whenever a saved core is restarted.
-;;; 
-(defun stream-reinit ()
-  (setf *available-buffers* nil)
-  (setf *stdin*
-	(make-fd-stream 0 :name "Standard Input" :input t :buffering :line))
-  (setf *stdout*
-	(make-fd-stream 1 :name "Standard Output" :output t :buffering :line))
-  (setf *stderr*
-	(make-fd-stream 2 :name "Standard Error" :output t :buffering :line))
-  (let ((tty (mach:unix-open "/dev/tty" mach:o_rdwr #o666)))
-    (if tty
-	(setf *tty*
-	      (make-fd-stream tty :name "the Terminal" :input t :output t
-			      :buffering :line))
-	(setf *tty* (make-two-way-stream *stdin* *stdout*))))
-  nil)
-
-
-;;;; Beeping.
-
-(defun default-beep-function (stream)
-  (write-char #\bell stream)
-  (finish-output stream))
-
-(defvar *beep-function* #'default-beep-function
-  "This is called in BEEP to feep the user.  It takes a stream.")
-
-(defun beep (&optional (stream *terminal-io*))
-  (funcall *beep-function* stream))
-
-
-;;;; File position and file length.
-
-;;; File-Position  --  Public
-;;;
-;;;    Call the misc method with the :file-position operation.
-;;;
-(defun file-position (stream &optional position)
-  "With one argument returns the current position within the file
-  File-Stream is open to.  If the second argument is supplied, then
-  this becomes the new file position.  The second argument may also
-  be :start or :end for the start and end of the file, respectively."
-  (unless (streamp stream)
-    (error "Argument ~S is not a stream." stream))
-  (funcall (stream-misc stream) stream :file-position position))
-
-;;; File-Length  --  Public
-;;;
-;;;    Like File-Position, only use :file-length.
-;;;
-(defun file-length (stream)
-  "This function returns the length of the file that File-Stream is open to."
-  (unless (streamp stream)
-    (error "Argument ~S is not a stream." stream))
-  (funcall (stream-misc stream) stream :file-length))
-
-;;; File-Name  --  internal interface
-;;;
-;;;    Kind of like File-Position, but is an internal hack used by the filesys
-;;; stuff to get and set the file name.
-;;;
-(defun file-name (stream &optional new-name)
-  (when (fd-stream-p stream)
-    (if new-name
-	(setf (fd-stream-file stream) new-name)
-	(fd-stream-file stream))))
diff --git a/code/fdefinition.lisp b/code/fdefinition.lisp
deleted file mode 100644
index f7c0634afe02f40202063bf8c24d1cf9ec8e624c..0000000000000000000000000000000000000000
--- a/code/fdefinition.lisp
+++ /dev/null
@@ -1,68 +0,0 @@
-;;; -*- Package: Lisp; Log: code.log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    Functions that hack on the global function namespace (primarily
-;;; concerned with SETF functions here.)
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'lisp)
-(export '(fdefinition fboundp fmakunbound))
-
-(defvar *setf-functions* (make-hash-table :test #'equal))
-
-(eval-when (compile eval)
-
-;;; With-Function-Name  --  Internal
-;;;
-(defmacro with-function-name (name symbol-form setf-form)
-  `(typecase ,name
-     (symbol ,symbol-form)
-     (cons
-      (unless (and (eq (car ,name) 'setf)
-		   (consp (cdr ,name))
-		   (symbolp (cadr ,name)))
-	(error "Malformed function name: ~S." ,name))
-      ,setf-form)
-     (t
-      (error "Malformed function name: ~S." ,name))))
-
-); Eval-When (Compile Eval)
-
-(defun fdefinition (name)
-  "Return Name's global function definition."
-  (with-function-name name
-    (careful-symbol-function name)
-    (or (gethash (cadr name) *setf-functions*)
-	(error "Undefined function: ~S." name))))
-
-(defsetf fdefinition %set-fdefinition)
-
-(defun %set-fdefinition (name new-value)
-  "Set Name's global function definition."
-  (declare (type function new-value))
-  (with-function-name name
-    (set-symbol-function-carefully name new-value)
-    (setf (gethash (cadr name) *setf-functions*) new-value)))
-
-#+new-compiler
-(defun fboundp (name)
-  "Return true if Name has a global function definition."
-  (with-function-name name
-    (functionp (%primitive fast-symbol-function name))
-    (functionp (gethash (cadr name) *setf-functions*))))
-
-#+new-compiler
-(defun fmakunbound (name)
-  "Make Name have no global function definition."
-  (with-function-name name
-    (%primitive set-symbol-function name
-		(%primitive make-immediate-type 0 %trap-type))
-    (remhash (cadr name) *setf-functions*))
-  t)
diff --git a/code/filesys.lisp b/code/filesys.lisp
deleted file mode 100644
index 49e97c122ec125e9c250d415bb74d6189465897e..0000000000000000000000000000000000000000
--- a/code/filesys.lisp
+++ /dev/null
@@ -1,1113 +0,0 @@
-;;; -*- Log: code.log; Package: Lisp -*-
-;;; ### Some day fix to accept :wild in any pathname component.
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; Ugly pathname functions for Spice Lisp.
-;;;    these functions are part of the standard Spice Lisp environment.
-;;;
-;;; Written by Jim Large and Rob MacLachlan
-;;;
-;;; **********************************************************************
-
-(in-package "LISP")
-
-(export '(pathname pathnamep *default-pathname-defaults* truename
-	  parse-namestring merge-pathnames make-pathname
-	  pathname-host pathname-device pathname-directory
-	  pathname-name pathname-type pathname-version
-	  namestring file-namestring directory-namestring
-	  host-namestring enough-namestring user-homedir-pathname
-          probe-file rename-file delete-file file-write-date
-	  file-author directory))
-
-(use-package "EXTENSIONS")
-
-(in-package "EXTENSIONS")
-(export '(print-directory complete-file ambiguous-files default-directory
-			  file-writable))
-(in-package "LISP")
-
-
-;;; Pathname structure
-
-
-;;; *Default-Pathname-defaults* has all values unspecified except for the
-;;;  host.  All pathnames must have a host.
-(defvar *default-pathname-defaults* ()
-  "Set to the default pathname-defaults pathname (Got that?)")
-
-(defun filesys-init ()
-  (setq *default-pathname-defaults* 
-	(%make-pathname "Mach" nil nil nil nil nil)))
-
-
-;;; The pathname type is defined with a defstruct.
-;;; This declaration implicitly defines the common lisp function Pathnamep
-(defstruct (pathname
-	    (:conc-name %pathname-)
-	    (:print-function %print-pathname)
-	    (:constructor
-	     %make-pathname (host device directory name type version))
-	    (:predicate pathnamep))
-  "Pathname is the structure of the file pathname.  It consists of a
-   host, a device, a directory, a name, and a type."
-  (host nil :type (or simple-string null))
-  (device nil :type (or simple-string (member nil :absolute)))
-  (directory nil :type (or simple-vector null))
-  (name nil :type (or simple-string null))
-  (type nil :type (or simple-string null))
-  (version nil :type (or integer (member nil :newest))))
-
-(defun %print-pathname (s stream d)
-  (declare (ignore d))
-  (format stream "#.(pathname ~S)" (namestring s)))
-
-(defun make-pathname (&key defaults (host nil hostp) (device nil devicep)
-			   (directory nil directoryp) (name nil namep)
-			   (type nil typep) (version nil versionp))
-  "Create a pathname from :host, :device, :directory, :name, :type and :version.
-  If any field is ommitted, it is obtained from :defaults as though by 
-  merge-pathnames."
-  (if defaults
-      (let ((defaults (pathname defaults)))
-	(unless hostp
-	  (setq host (%pathname-host defaults)))
-	(unless devicep
-	  (setq device (%pathname-device defaults)))
-	(unless directoryp
-	  (setq directory (%pathname-directory defaults)))
-	(unless namep
-	  (setq name (%pathname-name defaults)))
-	(unless typep
-	  (setq type (%pathname-type defaults)))
-	(unless versionp
-	  (setq version (%pathname-version defaults))))
-      (unless hostp
-	(setq host (%pathname-host *default-pathname-defaults*))))
-
-  (when (stringp directory)
-    (setq directory (%pathname-directory (parse-namestring directory))))
-  (%make-pathname
-   (if (stringp host) (coerce host 'simple-string) host)
-   (if (stringp device) (coerce device 'simple-string) device)
-   directory
-   (if (stringp name) (coerce name 'simple-string) name)
-   (if (stringp type) (coerce type 'simple-string) type)
-   version))
-
-
-;;; These can not be done by the accessors because the pathname arg may be
-;;;  a string or a symbol or etc.
-
-(defun pathname-host (pathname)
-  "Returns the host slot of pathname.  Pathname may be a string, symbol,
-  or stream."
-  (%pathname-host (if (pathnamep pathname) pathname (pathname pathname))))
-
-(defun pathname-device (pathname)
-  "Returns the device slot of pathname.  Pathname may be a string, symbol,
-  or stream."
-  (%pathname-device (if (pathnamep pathname) pathname (pathname pathname))))
-
-(defun pathname-directory (pathname)
-  "Returns the directory slot of pathname.  Pathname may be a string,
-  symbol, or stream."
-  (%pathname-directory (if (pathnamep pathname) pathname (pathname pathname))))
-
-(defun pathname-name (pathname)
-  "Returns the name slot of pathname.  Pathname may be a string,
-  symbol, or stream."
-  (%pathname-name (if (pathnamep pathname) pathname (pathname pathname))))
-
-(defun pathname-type (pathname)
-  "Returns the type slot of pathname.  Pathname may be a string,
-  symbol, or stream."
-  (%pathname-type (if (pathnamep pathname) pathname (pathname pathname))))
-
-(defun pathname-version (pathname)
-  "Returns the version slot of pathname.  Pathname may be a string,
-  symbol, or stream."
-  (%pathname-version (if (pathnamep pathname) pathname (pathname pathname))))
-
-
-
-;;;; PARSE-NAMESTRING and PATHNAME.
-
-;;; SPLIT-FILENAME -- internal
-;;;
-;;; Splits the filename into the name and type.  If someone wants to change
-;;; this yet again, just change this.
-;;; 
-(defun split-filename (filename)
-  (declare (simple-string filename))
-  (let ((posn (position #\. filename :from-end t)))
-    (cond ((null posn)
-	   (values filename nil))
-	  ((or (zerop posn) (= posn (1- (length filename))))
-	   (values filename ""))
-	  (t
-	   (values (subseq filename 0 posn)
-		   (subseq filename (1+ posn)))))))
-
-;;; DO-FILENAME-PARSE -- internal
-;;;
-;;; Split string into a logical name, a vector of directories, a file name and
-;;; a file type.
-;;;
-(defun do-filename-parse (string &optional (start 0) end)
-  (declare (simple-string string))
-  (let ((end (or end (length string))))
-    (let* ((directories nil)
-	   (filename nil)
-	   (absolutep (and (> end start) (eql (schar string start) #\/)))
-	   (logical-name
-	    (cond (absolutep
-		   (setf start (position #\/ string :start start :end end
-					 :test-not #'char=))
-		   :absolute)
-		  ((find #\: string
-			 :start start
-			 :end (or (position #\/ string :start start :end end)
-				  end))
-		   (let ((posn (position #\: string :start start)))
-		     (prog1
-			 (subseq string start posn)
-		       (setf start (1+ posn))))))))
-      (loop
-	(unless (and start (> end start))
-	  (return))
-	(let ((next-slash (position #\/ string :start start :end end)))
-	  (cond (next-slash
-		 (push (subseq string start next-slash) directories)
-		 (setf start
-		       (position #\/ string :start next-slash :end end
-				 :test-not #'char=)))
-		(t
-		 (setf filename (subseq string start end))
-		 (return)))))
-      (multiple-value-bind (name type)
-			   (if filename (split-filename filename))
-	(values (cond (logical-name logical-name)
-		      (directories "Default"))
-		(if (or logical-name directories)
-		  (coerce (nreverse directories) 'vector))
-		name
-		type)))))
-
-(defun parse-namestring (thing &optional host
-			 (defaults *default-pathname-defaults*)
-			 &key (start 0) end junk-allowed)
-  "Convert THING (string, symbol, pathname, or stream) into a pathname."
-  (declare (ignore junk-allowed))
-  (let* ((host (or host (pathname-host defaults)))
-	 (pathname
-	  (etypecase thing
-	    ((or string symbol)
-	     (let ((string (coerce (string thing) 'simple-string)))
-	       (multiple-value-bind (device directories name type)
-				    (do-filename-parse string start end)
-		 (unless end (setf end (length string)))
-		 (make-pathname :host host
-				:device device
-				:directory directories
-				:name name
-				:type type))))
-	    (pathname
-	     (setf end start)
-	     thing)
-	    (stream
-	     (setf end start)
-	     (pathname (file-name thing))))))
-    (unless (or (null host)
-		(null (pathname-host pathname))
-		(string-equal host (pathname-host pathname)))
-      (cerror "Ignore it."
-	      "Host mismatch in ~S: ~S isn't ~S"
-	      'parse-namestring
-	      (pathname-host pathname)
-	      host))
-    (values pathname end)))
-
-
-(defun pathname (thing)
-  "Turns thing into a pathname.  Thing may be a string, symbol, stream, or
-   pathname."
-  (values (parse-namestring thing)))
-
-
-
-;;; Merge-Pathnames  --  Public
-;;;
-;;; Returns a new pathname whose fields are the same as the fields in PATHNAME
-;;;  except that () fields are filled in from defaults.  Type and Version field
-;;;  are only done if name field has to be done (see manual for explanation).
-;;;
-(defun merge-pathnames (pathname &optional
-				 (defaults *default-pathname-defaults*)
-				 default-version)
-  "Fills in unspecified slots of Pathname from Defaults (defaults to
-  *default-pathname-defaults*).  If the version remains unspecified,
-  gets it from Default-Version."
-  ;;
-  ;; finish hairy argument defaulting
-  (setq pathname (pathname pathname))
-  (setq defaults (pathname defaults))
-  ;;
-  ;; make a new pathname
-  (let ((name (%pathname-name pathname))
-	(device (%pathname-device pathname)))
-    (%make-pathname
-     (or (%pathname-host pathname) (%pathname-host defaults))
-     (or device (%pathname-device defaults))
-     (or (%pathname-directory pathname) (%pathname-directory defaults))
-     (or name (%pathname-name defaults))
-     (or (%pathname-type pathname) (%pathname-type defaults))
-     (or (%pathname-version pathname)
-	 (if name
-	     default-version
-	     (or (%pathname-version defaults) default-version))))))
-
-
-;;;; NAMESTRING and other stringification stuff.
-
-;;; %Dirstring  --  Internal
-;;;
-;;; %Dirstring converts a vector of the form #("foo" "bar" ... "baz") into a
-;;;  string of the form "foo/bar/ ... /baz/"
-
-(defun %dirstring (dirlist)
-  (declare (simple-vector dirlist))
-  (let* ((numdirs (length dirlist))
-	 (length numdirs))
-    (declare (fixnum numdirs length))
-    (dotimes (i numdirs)
-      (incf length (the fixnum (length (svref dirlist i)))))
-    (do ((result (make-string length))
-	 (index 0 (1+ index))
-	 (position 0))
-	((= index numdirs) result)
-      (declare (simple-string result))
-      (let* ((string (svref dirlist index))
-	     (len (length string))
-	     (end (+ position len)))
-	(declare (simple-string string)
-		 (fixnum len end))
-	(replace result string :start1 position  :end1 end  :end2 len)
-	(setf (schar result end) #\/)
-	(setq position (+ end 1))))))
-
-(defun quick-integer-to-string (n)
-  (cond ((zerop n) "0")
-	((eql n 1) "1")
-	((minusp n)
-	 (concatenate 'simple-string "-"
-		      (the simple-string (quick-integer-to-string (- n)))))
-	(t
-	 (do* ((len (1+ (truncate (integer-length n) 3)))
-	       (res (make-string len))
-	       (i (1- len) (1- i))
-	       (q n)
-	       (r 0))
-	      ((zerop q)
-	       (incf i)
-	       (replace res res :start2 i :end2 len)
-	       (%primitive shrink-vector res (- len i)))
-	   (declare (simple-string res)
-		    (fixnum len i r))
-	   (multiple-value-setq (q r) (truncate q 10))
-	   (setf (schar res i) (schar "0123456789" r))))))
-	   
-(defun %device-string (device)
-  (cond ((eq device :absolute) "/")
-	(device
-	 (if (string-equal device "Default")
-	     ""
-	     (concatenate 'simple-string (the simple-string device) ":")))
-	(T "")))
-
-(defun namestring (pathname)
-  "Returns the full form of PATHNAME as a string."
-  (setq pathname (pathname pathname))
-  (let* ((directory (%pathname-directory pathname))
-	 (name (%pathname-name pathname))
-	 (type (%pathname-type pathname))
-	 (result (%device-string (%pathname-device pathname))))
-    (declare (simple-string result))
-    (when directory
-      (setq result (concatenate 'simple-string result
-				(the simple-string (%dirstring directory)))))
-    (when name
-      (setq result (concatenate 'simple-string result 
-				(the simple-string name))))
-    (when (and type (not (zerop (length type))))
-      (setq result (concatenate 'simple-string result "."
-				(the simple-string type))))
-    result))
-
-(defun %ses-get-useful-name (pathname)
-  "NAMESTRING of pathname ignoring the device slot."
-  (setq pathname (pathname pathname))
-  (let* ((directory (%pathname-directory pathname))
-	 (name (%pathname-name pathname))
-	 (type (%pathname-type pathname))
-	 (result ""))
-    (declare (simple-string result))
-    (when directory
-      (setq result (concatenate 'simple-string result
-				(the simple-string (%dirstring directory)))))
-    (when name
-      (setq result (concatenate 'simple-string result 
-				(the simple-string name))))
-    (when (and type (not (zerop (length type))))
-      (setq result (concatenate 'simple-string result "."
-				(the simple-string type))))
-    result))
-
-;;; This function is somewhat bummed to make the Hemlock directory command
-;;; is fast.
-;;;
-(defun file-namestring (pathname)
-  "Returns the name, type, and version of PATHNAME as a string."
-  (unless (pathnamep pathname) (setq pathname (pathname pathname)))
-  (let* ((name (%pathname-name pathname))
-	 (type (%pathname-type pathname))
-	 (result (or name "")))
-    (declare (simple-string result))
-    (if (and type (not (zerop (length type))))
-	(concatenate 'simple-string result "." type)
-	result)))
-
-(defun directory-namestring (pathname)
-  "Returns the device & directory parts of PATHNAME as a string."
-  (setq pathname (pathname pathname))
-  (let* ((directory (%pathname-directory pathname))
- 	 (result (%device-string (%pathname-device pathname))))
-    (declare (simple-string result))
-    (when directory
-      (setq result (concatenate 'simple-string result
-				(the simple-string (%dirstring directory)))))
-    result))
-
-(defun host-namestring (pathname)
-  "Returns the host part of PATHNAME as a string."
-  (setq pathname (pathname pathname))
-  (%pathname-host pathname))
-
-
-
-;;;; ENOUGH-NAMESTRING
-
-(defun enough-namestring (pathname &optional
-				   (defaults *default-pathname-defaults*))
-  "Returns a string which uniquely identifies PATHNAME w.r.t. DEFAULTS." 
-  (setq pathname (pathname pathname))
-  (setq defaults (pathname defaults))
-  (let* ((device (%pathname-device pathname))
-	 (directory (%pathname-directory pathname))
-	 (name (%pathname-name pathname))
-	 (type (%pathname-type pathname))
-	 (result "")
-	 (need-name nil))
-    (declare (simple-string result))
-    (when (and device (string-not-equal device (%pathname-device defaults)))
-      (setq result (%device-string device)))
-    (when (and directory
-	       (not (equalp directory (%pathname-directory defaults))))
-      (setq result (concatenate 'simple-string result
-				(the simple-string (%dirstring directory)))))
-    (when (and name (string-not-equal name (%pathname-name defaults)))
-      (setq result (concatenate 'simple-string result 
-				(the simple-string name))
-	    need-name t))
-    (when (and type (or need-name
-			(string-not-equal type (%pathname-type defaults))))
-      (setq result (concatenate 'simple-string result "."
-				(the simple-string type))))
-    result))
-
-
-
-;;;; TRUENAME and other stuff probing stuff.
-
-;;; Truename  --  Public
-;;;
-;;;    Another silly file function trivially different from another function.
-;;;
-(defun truename (pathname)
-  "Return the pathname for the actual file described by the pathname
-  An error is signalled if no such file exists."
-  (let ((result (probe-file pathname)))
-    (unless result
-      (error "The file ~S does not exist." (namestring pathname)))
-    result))
-
-;;; Do-Search-List  --  Internal
-;;;
-;;;    Bind var in turn to each element of search list with the specifed
-;;; name.
-;;;
-(defmacro do-search-list ((var name &optional exit-form) . body)
-  "Do-Search-List (Var Name [Exit-Form]) {Form}*"
-  `(dolist (,var (resolve-search-list ,name nil) ,exit-form)
-     (declare (simple-string ,var))
-     ,@body))
-
-
-;;; Sub-Probe-File  --  Internal
-;;;
-;;;    Does the work of Probe-File, returning an additional value which
-;;; indicates whether the name is really a file.
-;;;
-(defun sub-probe-file (pathname)
-  (setq pathname (pathname pathname))
-  (flet ((pathnamify (ns etype)
-	   (declare (simple-string ns))
-	   (case etype
-	     (:entry_remote
-	      (values (parse-namestring (concatenate 'simple-string ns "/"))
-		      :entry_directory))
-	     (t
-	      (values (parse-namestring ns) etype)))))
-    (let ((log-name (or (%pathname-device pathname) "default")))
-      (if (eq log-name :absolute)
-	  (let ((namestring (namestring pathname)))
-	    (multiple-value-bind (name etype)
-				 (mach:unix-subtestname namestring)
-	      (if (null name) NIL
-		  (pathnamify name etype))))
-	  (if (null (%pathname-device pathname))
-	      (multiple-value-bind (name etype)
-				   (mach:unix-subtestname
-				    (%ses-get-useful-name pathname))
-		(if (null name) NIL (pathnamify name etype)))
-	      (let ((namestring (%ses-get-useful-name pathname)))
-		(do-search-list (entry log-name)
-		  (let ((str (concatenate 'simple-string entry namestring)))
-		    (declare (simple-string str))
-		    (multiple-value-bind (name etype)
-					 (mach:unix-subtestname str)
-		      (when name
-			(return (pathnamify name etype))))))))))))
-
-
-;;; Probe-File  --  Public
-;;;
-;;;    Just call Sub-Probe-File and return nil when it isn't a file.
-;;;
-(defun probe-file (pathname)
-  "Return a pathname which is the truename of the file if it exists, NIL
-  otherwise.  Returns NIL for directories and other non-file entries."
-  (multiple-value-bind (pn f)
-		       (sub-probe-file pathname)
-    (if (eq f :entry_file) pn)))
-
-
-
-;;; Predict-Name  --  Internal
-;;;
-;;;    Predict-Name is a function used by Open to get an absolute pathname 
-;;; for a file being opened.  Returns the truename of the file and
-;;; whether it really exists or not.
-;;;
-(defun predict-name (file-name for-input)
-  (let* ((pathname (pathname file-name))
-	 (device (%pathname-device pathname))
-	 (truename (probe-file pathname)))
-    (cond ((eq device :absolute)
-	   (if truename
-	       (values (namestring truename) t)
-	       ;; Try again in case file-name is a directory.
-	       (predict-name-with-subtest (namestring pathname))))
-	  ((and for-input truename)
-	   (values (namestring truename) t))
-	  (t
-	   (let ((expansion (resolve-search-list (or device "default") t)))
-	     (let ((name (concatenate 'simple-string (car expansion)
-				      (%ses-get-useful-name pathname))))
-	       (declare (simple-string name))
-	       (predict-name-with-subtest name)))))))
-
-(defun predict-name-with-subtest (name)
-  (let ((gr (mach:unix-subtestname name)))
-    (if gr
-	(values gr t)
-	(values (mach::simplify-file-name name) nil))))
-
-
-
-;;; Rename-File  --  Public
-;;;
-;;;    If File is a File-Stream, then rename the associated file if it exists,
-;;; otherwise just change the name in the stream.  If not a file stream, then
-;;; just rename the file.
-;;;
-(defun rename-file (file new-name)
-  "Rename File to have the specified New-Name.  If file is a stream open to a
-  file, then the associated file is renamed.  If the file does not yet exist
-  then the file is created with the New-Name when the stream is closed."
-  (if (streamp file)
-      (let* ((name (file-name file))
-	     (pn (parse-namestring name))
-	     (npn (merge-pathnames new-name pn))
-	     (new (predict-name npn nil)))
-	(when (mach:quick-subtestname name)
-	  (multiple-value-bind (res err) (mach:Unix-rename name new)
-	    (if (null res) (error "Failed to rename ~A to ~A, unix error: ~A."
-				  name new (mach:get-unix-error-msg err)))))
-	(file-name file new)
-	(values npn pn (parse-namestring new)))
-      (let* ((pn (or (sub-probe-file file)
-		     (error "File to rename does not exist: ~S" file)))
-	     (npn (merge-pathnames new-name pn))
-	     (new (predict-name npn nil)))
-	(multiple-value-bind (res err) (mach:unix-rename (namestring pn) new)
-	  (if res (values npn pn (parse-namestring new))
-	      (error "Failed to rename ~A to ~A, unix error: ~A."
-		     (namestring pn) new (mach:get-unix-error-msg err)))))))
-
-;;; Delete-File  --  Public
-;;;
-;;;    Delete the file, Man.
-;;;
-(defun delete-file (file)
-  "Delete the specified file."
-  (let ((tn (sub-probe-file file)))
-    (when (streamp file)
-      (close file :abort t))
-    (if tn
-	(let ((ns (namestring tn)))
-	  (multiple-value-bind (res err) (mach:unix-unlink ns)
-	    (if (null res)
-		(error "Failed to delete ~A, unix error: ~A."
-		       ns (mach:get-unix-error-msg err)))))
-	(unless (streamp file)
-	  (error "File to be deleted does not exist: ~S" file)))) 
-  t)
-
-;;; User-Homedir-Pathname  --  Public
-;;;
-;;;    If the user wants a meaningful homedir, she has to define Home:.
-;;; Someday, login may do this for us.  Since we must always return something,
-;;; we just return Default: if it isn't defined.
-;;;
-(defun user-homedir-pathname (&optional host)
-  "Returns the home directory of the logged in user as a pathname.
-  This is obtained from the logical name \"home:\".  If this is not defined,
-  then we return \"default:\""
-  (declare (ignore host))
-  (let ((home (cdr (assoc :home *environment-list* :test #'eq))))
-    (if home
-	(pathname (if (string-equal home "/") "/"
-		      (concatenate 'simple-string home "/")))
-	(let ((expansion (if (search-list "home:")
-			     (resolve-search-list "home" t))))
-	  (if expansion
-	      (car expansion)
-	      (make-pathname :device "default"))))))
-
-;;; File-Write-Date  --  Public
-;;;
-(defun file-write-date (file)
-  "Return file's creation date, or NIL if it doesn't exist."
-  (let ((tn (sub-probe-file file)))
-    (when tn
-      (multiple-value-bind (res dev ino mode nlink uid gid
-				rdev size atime mtime)
-			   (mach:unix-stat (namestring tn))
-	(declare (ignore dev ino mode nlink uid gid rdev size atime))
-	(if (null res) 0
-	    (+ unix-to-universal-time mtime))))))
-
-;;; File-Author  --  Public
-;;;
-(defun file-author (file)
-  "Returns the file author as a string, or nil if the author cannot be
-   determined.  Signals an error if file doesn't exist."
-  (let ((filename (truename file)))
-    (multiple-value-bind (winp dev ino mode nlink uid)
-			 (mach:unix-stat (namestring filename))
-      (declare (ignore dev ino mode nlink))
-      (if winp (lookup-login-name uid)))))
-
-
-
-;;;; DIRECTORY.
-
-;;; DO-DIRECTORY searches a directory, binding the vars to the name and entry
-;;; type.  Pattern and All are used in MACH:UNIX-SEARCH-DIRECTORY.
-;;;
-(defmacro do-directory ((name-var etype-var pattern &optional (all t) result)
-			. body)
-  "Do-Directory (Name Entry-Type Pattern [All] [Result]) {Form}*.
-   If All is non-nil (the default), then Unix dot files to be processed.
-   Unix dot and dot-dot are never processed."
-  (let ((file (gensym))
-	(res (gensym))
-	(type (gensym))
-	(p (gensym)))
-    `(dolist (,file (mach:unix-search-directory ,pattern ,all)
-		    ,result)
-       (declare (simple-string ,file))
-       (let* ((,p (position #\/ ,file :from-end t))
-	      (,name-var
-	       (if ,p
-		   (subseq ,file (the fixnum (1+ (the fixnum ,p))))
-		   ,file)))
-	 (declare (simple-string ,name-var))
-	 (unless (or (string= "." ,name-var) (string= ".." ,name-var))
-	   (let ((,etype-var (multiple-value-bind (,res ,type)
-						  (mach:quick-subtestname ,file)
-			       (declare (ignore ,res))
-			       ,type)))
-	     ,@body))))))
-
-(defun directory (pathname &key (all t))
-  "Returns a list of pathnames, one for each file that matches the given
-   pathname.  Supplying :all as nil causes this to ignore Unix dot files.  This
-   never includes Unix dot and dot-dot in the result."
-  (setq pathname (pathname pathname))
-  (multiple-value-bind (dir pattern) (find-directory pathname)
-    (let ((res ()))
-      (do-directory (name etype pattern all)
-	(if (eq etype :entry_file)
-	    (let ((last-dot (position #\. name :from-end t)))
-	      (push
-	       (%make-pathname
-		"Mach" :absolute dir
-		(if last-dot (subseq name 0 last-dot) name)
-		(if last-dot (subseq name (1+ last-dot)))
-		nil)
-	       res))
-	    (push
-	     (%make-pathname
-	      "Mach" :absolute
-	      (concatenate 'simple-vector dir (vector name))
-	      nil nil nil)
-	     res)))
-      (nreverse res))))
-
-;;; FIND-DIRECTORY returns an absolute directory vector for pathname as a
-;;; first argument and an absolute namestring.  The namestring includes a
-;;; trailing asterisk, wildcard, when the given pathname is immediately
-;;; probe-able as a directory.
-;;;
-(defun find-directory (pathname)
-  (multiple-value-bind (pn type)
-		       (sub-probe-file pathname)
-    (if pn
-	(let ((ns (namestring pn)))
-	  (declare (simple-string ns))
-	  (case type
-	    (:entry_directory
-	     (when (char/= (schar ns (the fixnum (1- (length ns)))) #\/)
-	       (setq ns (concatenate 'simple-string ns "/")))
-	     (values (%pathname-directory (pathname ns))
-		     (concatenate 'simple-string ns "*")))
-	    (t (values (%pathname-directory pn) ns))))
-	(multiple-value-bind (pn type)
-			     (sub-probe-file
-			      (make-pathname
-			       :directory (%pathname-directory pathname)
-			       :device (%pathname-device pathname)))
-	  (unless pn
-	    (error "Directory does not exist: ~S" pathname))
-	  (let ((ns (namestring pn)))
-	    (case type
-	      (:entry_directory
-	       (values
-		(%pathname-directory pn)
-		(concatenate 'simple-string ns (file-namestring pathname))))
-	      (t
-	       (error "~S is not a directory." pathname))))))))
-
-
-
-;;;; Printing directories and determining file owner names.
-
-;;; PRINT-DIRECTORY is exported from the EXTENSIONS package.
-;;; 
-(defun print-directory (pathname &optional stream &key all verbose return-list)
-  "Like Directory, but prints a terse, multi-coloumn directory listing
-   instead of returning a list of pathnames.  When :all is supplied and
-   non-nil, then Unix dot files are included too (as ls -a).  When :vervose
-   is supplied and non-nil, then a long listing of miscellaneous
-   information is output one file per line."
-  (setf pathname (pathname pathname))
-  (let ((*standard-output* (out-synonym-of stream)))
-    (if verbose
-	(print-directory-verbose pathname all return-list)
-	(print-directory-formatted pathname all return-list))))
-
-(defun print-directory-verbose (pathname all return-list)
-  (multiple-value-bind (dir pattern) (find-directory pathname)
-    (declare (ignore dir))
-    (format t "Directory of ~A :~%" pattern)
-    (let ((dir-name (directory-namestring pattern))
-	  (result ()))
-      (do-directory (name etype pattern all (nreverse result))
-	(let ((slash-name (if (eq etype :entry_file)
-			      name
-			      (concatenate 'simple-string name "/"))))
-	  (declare (simple-string slash-name))
-	  (when return-list
-	    (push (pathname (concatenate 'simple-string dir-name slash-name))
-		  result))
-	  (multiple-value-bind 
-	      (reslt dev-or-err ino mode nlink uid gid rdev size atime mtime)
-	      (mach:unix-stat (concatenate 'simple-string dir-name name))
-	    (declare (ignore ino gid rdev atime)
-		     (fixnum uid mode))
-	    (cond (reslt
-		   ;;
-		   ;; Print characters for file modes.
-		   (macrolet ((frob (bit name &optional sbit sname negate)
-				`(if ,(if negate
-					  `(not (logbitp ,bit mode))
-					  `(logbitp ,bit mode))
-				     ,(if sbit
-					  `(if (logbitp ,sbit mode)
-					       (write-char ,sname)
-					       (write-char ,name))
-					  `(write-char ,name))
-				     (write-char #\-))))
-		     (frob 15 #\d nil nil t)
-		     (frob 8 #\r)
-		     (frob 7 #\w)
-		     (frob 6 #\x 11 #\s)
-		     (frob 5 #\r)
-		     (frob 4 #\w)
-		     (frob 3 #\x 10 #\s)
-		     (frob 2 #\r)
-		     (frob 1 #\w)
-		     (frob 0 #\x))
-		   ;;
-		   ;; Print the rest.
-		   (multiple-value-bind (sec min hour date month year)
-					(get-decoded-time)
-		     (declare (ignore sec min hour date month))
-		     (format t "~2D ~8A ~8D ~12A ~A~%"
-			     nlink
-			     (or (lookup-login-name uid) uid)
-			     size
-			     (decode-universal-time-for-files mtime year)
-			     slash-name)))
-		  (t (format t "Couldn't stat ~A -- ~A.~%"
-			     slash-name
-			     (mach:get-unix-error-msg dev-or-err))))))))))
-
-(defun decode-universal-time-for-files (time current-year)
-  (multiple-value-bind (sec min hour day month year)
-		       (decode-universal-time (+ time unix-to-universal-time))
-    (declare (ignore sec))
-    (format nil "~A ~2,' D ~:[ ~D~;~*~2,'0D:~2,'0D~]"
-	    (svref '#("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug"
-		      "Sep" "Oct" "Nov" "Dec")
-		   (1- month))
-	    day (= current-year year) year hour min)))
-
-(defun print-directory-formatted (pathname all return-list)
-  (let ((width (or (line-length *standard-output*) 80))
-	(names ())
-	(cnt 0)
-	(max-len 0)
-	(result ()))
-    (declare (list names) (fixnum max-len cnt))
-    ;;
-    ;; Get the data.
-    (multiple-value-bind (dir pattern) (find-directory pathname)
-      (declare (ignore dir))
-      (do-directory (name etype pattern all)
-	(let* ((slash-name (if (eql etype :entry_file)
-			       name
-			       (concatenate 'simple-string name "/")))
-	       (len (length slash-name)))
-	  (declare (simple-string slash-name)
-		   (fixnum len))
-	  (when return-list
-	    (push (pathname (concatenate 'simple-string
-					 (directory-namestring pattern)
-					 slash-name))
-		  result))
-	  
-	  (if (> len max-len) (setq max-len len))
-	  (incf cnt)
-	  (push slash-name names)))
-      (setq names (nreverse names))
-      ;;
-      ;; Do the output.
-      (let* ((col-width (1+ max-len))
-	     (cols (max (truncate width col-width) 1))
-	     (lines (ceiling cnt cols)))
-	(declare (fixnum cols lines))
-	(format t "Directory of ~A :~%" pattern)
-	(dotimes (i lines)
-	  (declare (fixnum i))
-	  (dotimes (j cols)
-	    (declare (fixnum j))
-	    (let ((name (nth (+ i (the fixnum (* j lines))) names)))
-	      (when name
-		(write-string name)
-		(unless (eql j (1- cols))
-		  (tab-over 
-		   (- col-width (length (the simple-string name))))))))
-	  (terpri))))
-    (when return-list (nreverse result))))
-
-
-
-;;;; Translating uid's and gid's.
-
-(defvar *uid-hash-table* (make-hash-table)
-  "Hash table for keeping track of uid's and login names.")
-
-;;; LOOKUP-LOGIN-NAME translates a user id into a login name.  Previous
-;;; lookups are cached in a hash table since groveling the passwd(s) files
-;;; is somewhat expensive.  The table may hold nil for id's that cannot
-;;; be looked up since this means the files are searched in their entirety
-;;; each time this id is translated.
-;;; 
-(defun lookup-login-name (uid)
-  (multiple-value-bind (login-name foundp) (gethash uid *uid-hash-table*)
-    (if foundp
-	login-name
-	(setf (gethash uid *uid-hash-table*)
-	      (get-group-or-user-name :user uid)))))
-
-(defvar *gid-hash-table* (make-hash-table)
-  "Hash table for keeping track of gid's and group names.")
-
-;;; LOOKUP-GROUP-NAME translates a group id into a group name.  Previous
-;;; lookups are cached in a hash table since groveling the group(s) files
-;;; is somewhat expensive.  The table may hold nil for id's that cannot
-;;; be looked up since this means the files are searched in their entirety
-;;; each time this id is translated.
-;;; 
-(defun lookup-group-name (gid)
-  (multiple-value-bind (group-name foundp) (gethash gid *gid-hash-table*)
-    (if foundp
-	group-name
-	(setf (gethash gid *gid-hash-table*)
-	      (get-group-or-user-name :group gid)))))
-
-
-;;; GET-GROUP-OR-USER-NAME first tries "/etc/passwd" ("/etc/group") since it is
-;;; a much smaller file, contains all the local id's, and most uses probably
-;;; involve id's on machines one would login into.  Then if necessary, we look
-;;; in "/etc/passwds" ("/etc/groups") which is really long and has to be
-;;; fetched over the net.
-;;;
-(defun get-group-or-user-name (group-or-user id)
-  "Returns the simple-string user or group name of the user whose uid or gid
-   is id, or NIL if no such user or group exists.  Group-or-user is either
-   :group or :user."
-  (let ((id-string (let ((*print-base* 10)) (prin1-to-string id))))
-    (declare (simple-string id-string))
-    (multiple-value-bind (file1 file2)
-			 (ecase group-or-user
-			   (:group (values "/etc/group" "/etc/groups"))
-			   (:user (values "/etc/passwd" "/etc/passwd")))
-      (or (get-group-or-user-name-aux id-string file1)
-	  (get-group-or-user-name-aux id-string file2)))))
-
-(defun get-group-or-user-name-aux (id-string passwd-file)
-  (with-open-file (stream passwd-file)
-    (loop
-      (let ((entry (read-line stream nil)))
-	(unless entry (return nil))
-	(let ((name-end (position #\: (the simple-string entry)
-				  :test #'char=)))
-	  (when name-end
-	    (let ((id-start (position #\: (the simple-string entry)
-				      :start (1+ name-end) :test #'char=)))
-	      (when id-start
-		(incf id-start)
-		(let ((id-end (position #\: (the simple-string entry)
-					:start id-start :test #'char=)))
-		  (when (and id-end
-			     (string= id-string entry
-				      :start2 id-start :end2 id-end))
-		    (return (subseq entry 0 name-end))))))))))))
-
-
-
-;;; Complete-One-File  --  Internal
-;;;
-;;;    Return as values a string and the greatest common prefix of all
-;;; the files corresponding to pattern.
-;;;
-(defun complete-one-file (pattern default-type ignore-types)
-  (let ((first nil)
-	(length nil))
-    (do-directory (name etype pattern nil)
-      (declare (ignore etype))
-      (let* ((last-dot (position #\. name :from-end t))
-	     (type (if last-dot (subseq name (1+ last-dot)))))
-	(cond ((and (not (string= type default-type))
-		    (member type ignore-types :test #'string=)))
-	      (first
-	       (let ((msm (string-not-equal name first :end2 length)))
-		 (when (and msm (< msm length))
-		   (setq length msm))))
-	      (t
-	       (setq first name)
-	       (setq length (length name))))))
-    (values first length)))
-
-
-;;; Complete-File  --  Public
-;;;
-;;;    If the pathname is absolute, just call Complete-One-File on and test
-;;; whether the result is a file.  If a relative pathname, do it on each
-;;; directory, accumulating the result.
-;;;
-(defun complete-file (pathname &key defaults ignore-types)
-  "Attempt to complete Pathname as the name of a file.  If the resulting
-  completion is unique, return T as the second value.  If there is no
-  possible completion, return both values NIL."
-  (setq pathname (pathname pathname))
-  (setq defaults (if defaults (pathname defaults) *default-pathname-defaults*))
-  (flet ((pathnamify (res len ambiguous pathname)
-		     (values 
-		      (make-pathname :device (%pathname-device pathname)
-				     :directory (%pathname-directory pathname)
-				     :defaults (parse-namestring (subseq res 0 len)))
-		      (not ambiguous))))
-    (let ((dev (or (%pathname-device pathname) "default"))
-	  (default-type (%pathname-type defaults)))
-      (if (eq dev :absolute)
-	  (multiple-value-bind
-	      (res len)
-	      (complete-one-file (concatenate 'simple-string
-					      (namestring pathname)
-					      "*")
-				 default-type ignore-types)
-	    (declare (fixnum len))
-	    (if res
-		(pathnamify res len
-			    (/= (the fixnum (length res)) len)
-			    pathname)
-		(values nil nil)))
-	  (let ((namestring (%ses-get-useful-name pathname))		 
-		(dirs (if (and (%pathname-directory defaults)
-			       (string-equal dev "default"))
-			  (list (directory-namestring defaults))
-			  ()))
-		(max most-positive-fixnum)
-		(max-str nil)
-		(ambiguous nil))
-	    (declare (simple-string namestring))
-	    (do-search-list (entry dev)
-			    (pushnew entry dirs :test #'string-equal))
-	    (dolist (entry dirs)
-	      (let ((str (concatenate 'simple-string entry namestring "*")))
-		(declare (simple-string str))
-		(multiple-value-bind
-		    (res len)
-		    (complete-one-file str default-type ignore-types)
-		  (when res
-		    (unless ambiguous
-		      (setq ambiguous (or max-str (/= (length res) len))))
-		    (if max-str
-			(setq max (or (string-not-equal res max-str :end1 len
-							:end2 max)
-				      max))
-			(setq max len  max-str res))))))
-	    (if max-str
-		(pathnamify max-str max ambiguous pathname)
-		(values nil nil)))))))
-
-;;; File-writable -- exported from extensions.
-;;;
-;;;   Determines whether the single argument (which should be a pathname)
-;;;   can be written by the the current task.
-
-(defun file-writable (name)
-  "File-writable accepts a pathname and returns T if the current
-  process can write it, and NIL otherwise."
-  (multiple-value-bind (tn exists) (predict-name name nil)
-    (if exists
-	(values (mach:unix-access tn mach:w_ok))
-	(values (mach:unix-access (directory-namestring tn)
-				  (logior mach:w_ok mach:x_ok))))))
-
-
-;;; Pathname-Order  --  Internal
-;;;
-;;;    Predicate to order pathnames by.  Goes by name.
-;;;
-(defun pathname-order (x y)
-  (let ((xn (%pathname-name x))
-	(yn (%pathname-name y)))
-    (if (and xn yn)
-	(let ((res (string-lessp xn yn)))
-	  (cond ((not res) nil)
-		((= res (length (the simple-string xn))) t)
-		((= res (length (the simple-string yn))) nil)
-		(t t)))
-	xn)))
-
-;;; Ambiguous-Files  --  Public
-;;;
-;;;    If the pathname is absolute, just do a directory.  If it is relative,
-;;; do a directory on each directory in the search-list and merge the results.
-;;;
-(defun ambiguous-files (pathname &optional defaults)
-  "Return a list of all files which are possible completions of Pathname.
-  We look in the directory specified by Defaults as well as looking down
-  the search list."
-  (setq pathname (pathname pathname)
-	defaults (if defaults (pathname defaults) *default-pathname-defaults*))
-  (let ((dev (or (%pathname-device pathname) "default")))
-    (if (eq dev :absolute)
-	(directory (concatenate 'simple-string (namestring pathname) "*"))
-	(let ((namestring (%ses-get-useful-name pathname))		 
-	      (dirs (if (and (%pathname-directory defaults)
-			     (string-equal dev "default"))
-			(list (directory-namestring defaults))
-			()))
-	      (res ()))
-	  (declare (simple-string namestring))
-	  (do-search-list (entry dev) (pushnew entry dirs :test #'string-equal))
-	  (dolist (entry dirs)
-	    (let ((str (concatenate 'simple-string entry namestring "*")))
-	      (declare (simple-string str))
-	      (setq res (merge 'list res (directory str)
-			       #'pathname-order))))
-	  res))))
-
-;;; Default-Directory  --  Public
-;;;
-;;;    This fills in a hole in Common Lisp.  We return the first thing we
-;;; find by doing a ResolveSearchList on Default.
-;;; 
-(defun default-directory ()
-  "Returns the pathname for the default directory.  This is the place where
-  a file will be written if no directory is specified.  This may be changed
-  with setf."
-  (multiple-value-bind (gr dir-or-error)
-		       (mach:unix-current-directory)
-    (if gr
-	dir-or-error
-	(error (mach:get-unix-error-msg dir-or-error)))))
-
-;;;
-;;; Maybe this shouldn't go here...
-(defsetf default-directory %set-default-directory)
-
-;;; %Set-Default-Directory  --  Internal
-;;;
-;;;    The setf method for Default-Directory.  We actually set the environment
-;;; variable Current which is by convention the head of the search list.
-;;; 
-(defun %set-default-directory (new-val)
-  (multiple-value-bind (gr error)
-		       (mach:unix-chdir (predict-name new-val nil))
-    (if gr
-	(car (setf (search-list "default:")
-		   (cdr (multiple-value-list (mach:unix-current-directory)))))
-	(error (mach:get-unix-error-msg error)))))
diff --git a/code/foreign.lisp b/code/foreign.lisp
deleted file mode 100644
index da62b5a32ca81b6b479783a2da7bb7102862e301..0000000000000000000000000000000000000000
--- a/code/foreign.lisp
+++ /dev/null
@@ -1,281 +0,0 @@
-;;; -*- Log: code.log; Package: Extensions -*-
-
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-
-;;; Functions for dealing with foreign function calls in Common Lisp.
-
-;;; Written by David B. McDonald, January 1987.
-
-;;; *******************************************************************
-(in-package "EXTENSIONS" :nicknames '("EXT") :use '("LISP" "SYSTEM"))
-
-(export '(load-foreign get-code-pointer get-data-pointer))
-
-(defconstant Unix-OMagic #x107)
-(defconstant Unix-NMagic #x108)
-(defconstant Unix-ZMagic #x10b)
-
-(defconstant Unix-header-size 32)
-(defconstant Symbol-Table-Entry-Size 12)
-
-(defconstant n_undf #x0)
-(defconstant n_abs #x2)
-(defconstant n_text #x4)
-(defconstant n_data #x6)
-(defconstant n_bss #x8)
-(defconstant n_comm #x12)
-(defconstant n_fn #x1f)
-(defconstant n_ext #x1)
-
-(defvar file-count 0
-  "Number of foreign function files loaded into the current Lisp.")
-
-(defvar temporary-foreign-files NIL
-  "List of dotted pairs containing location and size of object code
-   loaded so that foreign functions can be called.")
-
-(proclaim '(fixnum file-count))
-
-(defstruct unix-ste
-  (type 0 :type fixnum)
-  (location 0))
-
-
-(defvar foreign-symbols (make-hash-table :size 1000 :test #'equal))
-
-(defmacro read-cword (sap offset)
-  `(let ((rsap ,sap)
-	 (roff ,offset))
-     (declare (fixnum roff))
-     (setq roff (the fixnum (ash roff 1)))
-     (logior (ash (%primitive 16bit-system-ref rsap roff) 16)
-	     (%primitive 16bit-system-ref rsap (the fixnum (1+ roff))))))
-
-(defun read-miscop-free-pointer ()
-  (let ((aa lisp::alloctable-address)
-	(in (ash lisp::%assembler-code-type lisp::%alloc-ref-type-shift)))
-    (declare (fixnum in))
-    (logand (+ (logior (%primitive 16bit-system-ref aa (the fixnum (1+ in)))
-		       (ash (%primitive 16bit-system-ref aa in) 16)) 3)
-	    (lognot 3))))
-
-(defun write-miscop-free-pointer (value)
-  (let ((aa lisp::alloctable-address)
-	(in (ash lisp::%assembler-code-type lisp::%alloc-ref-type-shift))
-	(vl (logand value #xFFFF))
-	(vh (logand (ash value -16) #xFFFF)))
-    (declare (fixnum in))
-    (%primitive 16bit-system-set aa (the fixnum (1+ in)) vl)
-    (%primitive 16bit-system-set aa in vh)))
-
-;;; Load-foreign accepts a file or a list of files to be loaded into the
-;;; currently running Lisp core.  These files should be standard object
-;;; files created by you favourite compiler (e.g., cc).  It accepts two
-;;; optional parameters: libraries is a list of libraries to search
-;;; for unresolved references (default is the standard C library), and
-;;; env which is a list of Unix environment strings (default is what
-;;; lisp started with).  Load-foreign runs ld creating an object file
-;;; that has been linked so that it can be loaded into a predetermined
-;;; location in memory.
-
-(defun load-foreign (files &optional
-			   (libraries '("-lc"))
-			   (linker "/usr/cs/bin/ld")
-			   (base-file "/usr/misc/.lisp/bin/lisp")
-			   (env lisp::original-lisp-environment))
-  "Load-foreign loads a list of C object files into a running Lisp.  The
-  files argument should be a single file or a list of files.  The files
-  may be specified as namestrings or as pathnames.  The libraries
-  argument should be a list of library files as would be specified to
-  ld.  They will be searched in the order given.  The default is just
-  \"-lc\", i.e., the C library.  The linker argument is used to specifier
-  the Unix linker to use to link the object files (the default is
-  /usr/cs/bin/ld).  The base-file argument is used to specify a file to
-  use as the starting place for defined symbols.  The default is the C
-  start up code for Lisp.  The env argument is the Unix environment
-  variable definitions for the invocation of the linker.  The default is
-  the environment passed to Lisp."
-  (if (null (listp files)) (setq files (list files)))
-  (format t "[Loading foreign files ~A ...~%" files)
-  (let ((tfl (if files (format nil "/tmp/L~d.~d"
-			       (mach:unix-getuid)
-			       (the fixnum (+ (the fixnum (mach:unix-getpid))
-					      file-count)))
-		 base-file))
-	(ofl (get-last-loaded-file file-count base-file))
-	(addr (read-miscop-free-pointer)))
-    (when files
-      (setq file-count (the fixnum (1+ file-count)))
-      (format t "  [Running ld ...")
-      (force-output t)
-      (let ((nfiles ()))
-	(dolist (f files)
-	  (let* ((pn (merge-pathnames f *default-pathname-defaults*))
-		 (tn (probe-file pn)))
-	    (push (if tn (namestring tn) f) nfiles)))
-	(setf files (nreverse nfiles)))
-      (run-program linker `("-N" "-A" ,ofl "-T"
-			    ,(format nil "~X" (+ addr unix-header-size))
-			    "-o" ,tfl ,@files ,@libraries)
-		   :env env :wait t :output t :error t)
-      (push tfl temporary-foreign-files)
-      (format t " done.]~%"))
-    (multiple-value-bind (res dev ino mode nlnk uid gid rdev len)
-			 (mach:unix-stat tfl)
-      (declare (ignore ino mode nlnk uid gid rdev))
-      (when (null res)
-	(error "Could not stat intermediate file ~a, unix error: ~A."
-	       tfl (mach:get-unix-error-msg dev)))
-      (format t "  [Reading Unix object file ...")
-      (force-output t)
-      (multiple-value-bind (fd err) (mach:unix-open tfl mach:o_rdonly 0)
-	(when (null fd)
-	  (error "Failed to open intermediate file ~A, unix error: ~A."
-		 (mach:get-unix-error-msg err)))
-	(multiple-value-bind (bytes err2)
-			     (mach:unix-read fd (int-sap addr)
-					     len)
-	  (when (or (null bytes) (not (eq bytes len)))
-	    (if (null bytes)
-		(error "Read of intermediate file ~A failed, unix error: ~A"
-		       tfl (mach:get-unix-error-msg err2))
-		(error "Read of intermediate file ~A only read ~d of ~d bytes."
-		       tfl bytes len))))
-	(mach:unix-close fd)))
-    (format t " done.]~%")
-    (let ((fsize (logand (+ (load-object-file tfl addr files) 4) (lognot 3))))
-      (when files (write-miscop-free-pointer (+ addr fsize)))))
-  (format t "done.]~%"))
-
-;;; Get-last-loaded-file attempts to find the file that was last loaded into
-;;; Lisp.  If one is found, load-foreign uses it as the bases for the initial
-;;; symbol table.  Otherwise, it uses the lisp startup code.
-
-(defun get-last-loaded-file (fc base-file)
-  (declare (fixnum fc))
-  (do ((i (the fixnum (1- fc)) (1- i)))
-      ((< i 0) base-file)
-    (declare (fixnum i))
-    (let ((tfl (format nil "/tmp/L~d.~d" (mach:unix-getuid)
-		       (the fixnum (+ (the fixnum (mach:unix-getpid)) i)))))
-      (if (probe-file tfl) (return tfl)))))
-
-;;; Load-object-file, actually loads the object file created by ld.
-;;; It makes sure that it is a legal object file.
-
-(defun load-object-file (file addr flag)
-  (format t "  [Loading symbol table information ...")
-  (force-output t)
-  (let* ((sap (int-sap addr))
-	 (magic (read-cword sap 0))
-	 (text-size (read-cword sap 1))
-	 (idata-size (read-cword sap 2))
-	 (udata-size (read-cword sap 3))
-	 (symtab-size (read-cword sap 4))
-	 (epoint (read-cword sap 5))
-	 (treloc-size (read-cword sap 6))
-	 (dreloc-size (read-cword sap 7))
-	 (load-size (+ text-size idata-size udata-size unix-header-size))
-	 (symstart (+ text-size idata-size (if flag unix-header-size 2048)))
-	 (strstart (+ symstart (the fixnum symtab-size))))
-    (declare (fixnum magic text-size idata-size udata-size
-		     symtab-size symstart strstart treloc-size
-		     dreloc-size)
-	     (ignore epoint))
-    (unless (or (null flag)
-		(and (= magic unix-OMagic) (= treloc-size 0) (= dreloc-size 0)))
-      (error "File ~A is not a legal Unix object file." file))
-    (read-symbol-table (the fixnum (+ (the fixnum sap) symstart))
-		       symtab-size (the fixnum (+ (the fixnum sap) strstart)))
-    (setq load-size (logand (the fixnum (+ load-size 8192)) (lognot 8191)))
-    (do ((ind (truncate (+ text-size idata-size unix-header-size) 2)
-	      (1+ ind))
-	 (end (truncate udata-size 2)))
-	((>= ind end))
-      (%primitive 16bit-system-set sap ind 0))
-    (format t " done.]~%")
-    load-size))
-
-;;; Read-symbol-table reads the symbol table out of the object, making
-;;; external symbols available to Lisp, so that they can be used to
-;;; link to the C routines.
-
-(defun read-symbol-table (symstart symtab-size strstart)
-  (let ((end (the fixnum (+ (the fixnum symstart) (the fixnum symtab-size)))))
-    (do* ((se symstart (the fixnum (+ (the fixnum se) symbol-table-entry-size)))
-	  (si (logior (ash (%primitive 16bit-system-ref se 0) 16)
-		      (%primitive 16bit-system-ref se 1))
-	      (logior (ash (%primitive 16bit-system-ref se 0) 16)
-		      (%primitive 16bit-system-ref se 1)))
-	  (st (%primitive 8bit-system-ref se 4)
-	      (%primitive 8bit-system-ref se 4))
-	  (sv (logior (ash (%primitive 16bit-system-ref se 4) 16)
-		      (%primitive 16bit-system-ref se 5))
-	      (logior (ash (%primitive 16bit-system-ref se 4) 16)
-		      (%primitive 16bit-system-ref se 5))))
-	 ((>= (the fixnum se) (the fixnum end)))
-      (declare (fixnum st))
-      (when (or (= st (logior n_text n_ext))
-		(= st (logior n_data n_ext))
-		(= st (logior n_bss n_ext)))
-	(let* ((strend (%primitive find-character strstart si (+ si 512) 0)))
-	  (when (null strend)
-	    (error "Symbol table string didn't terminate."))
-	  (let ((strlen (the fixnum (- (the fixnum strend) (the fixnum si))))
-		(offset 0)
-		(code NIL)
-		(str NIL))
-	    (declare (fixnum strlen offset))
-	    (when (eq (%primitive 8bit-system-ref strstart si) (char-code #\_))
-	      (setq offset (the fixnum (1+ offset)))
-	      (when (eq (%primitive 8bit-system-ref strstart
-				    (the fixnum (1+ (the fixnum si))))
-			(char-code #\.))
-		(setq code T)
- 		(setq offset (the fixnum (1+ offset)))))
-	    (setq str (make-string (the fixnum (- strlen offset))))
-	    (%primitive byte-blt strstart
-			(the fixnum (+ (the fixnum si) offset)) str 0 strlen)
-	    (if (let ((x (ash sv (- (+ clc::type-shift-16 16)))))
-		  (not (<= clc::first-pointer-type x clc::last-pointer-type)))
-		(let ((ste (gethash str foreign-symbols))
-		      (loc (int-sap sv)))
-		  (cond ((null ste)
-			 (setf (gethash str foreign-symbols)
-			       (make-unix-ste :type (if code
-							(logior n_text
-								n_ext) st)
-					      :location (if code nil loc))))
-			(code
-			 (setf (unix-ste-type ste) (logior n_text n_ext)))
-			(T
-			 (setf (unix-ste-location ste) loc)))))))))))
-
-;;; Get-code-pointer accepts a simple string which should be the name
-;;; of a C routine that has already been loaded into the Lisp core image.
-;;; This name should use the correct capitalization of the C name without
-;;; the default underscore.
-(defun get-code-pointer (name)
-  (let ((ste (gethash name foreign-symbols)))
-    (when (null ste)
-      (error "There is no foreign function named ~A loaded." name))
-    (when (not (eq (unix-ste-type ste) (logior n_text n_ext)))
-      (error "~A is a foreign external variable, not a foreign function." name))
-    (unix-ste-location ste)))
-
-
-;;; Get-data-pointer is similar to get-code-pointer, except it returns the
-;;; address of a foreign global variable.
-
-(defun get-data-pointer (name)
-  (let ((ste (gethash name foreign-symbols)))
-    (when (null ste)
-      (error "There is no foreign variable named ~A loaded." name))
-    (when (eq (unix-ste-type ste) (logior n_text n_ext))
-      (error "~A is a foreign function, not a foreign variable." name))
-    (unix-ste-location ste)))
diff --git a/code/format-time.lisp b/code/format-time.lisp
deleted file mode 100644
index e57d2b3716a8bd55269bd949b15dbc79342bf556..0000000000000000000000000000000000000000
--- a/code/format-time.lisp
+++ /dev/null
@@ -1,186 +0,0 @@
-;;; -*- Mode: Lisp; Package: Extensions; Log: code.log -*-
-
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-
-;;; Really slick time printing routines built upon the Common Lisp
-;;; format function.
-
-;;; Written by Jim Healy, September 1987. 
-
-;;; **********************************************************************
-
-(in-package "EXTENSIONS" :use '("LISP"))
-
-(export '(format-universal-time format-decoded-time))
-
-(defconstant abbrev-weekday-table
-  '#("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun"))
-
-(defconstant long-weekday-table
-  '#("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"
-     "Sunday"))
-
-(defconstant abbrev-month-table
-  '#("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov"
-     "Dec"))
-
-(defconstant long-month-table
-  '#("January" "February" "March" "April" "May" "June" "July" "August"
-     "September" "October" "November" "December"))
-
-;;; The timezone-table is incomplete but workable.
-
-(defconstant timezone-table
-  '#("GMT" "" "" "" "" "EST" "CST" "MST" "PST"))
-
-;;; Valid-Destination-P ensures the destination stream is okay
-;;; for the Format function.
-
-(defun valid-destination-p (destination)
-  (or (not destination)
-      (eq destination 't)
-      (streamp destination)
-      (and (stringp destination)
-	   (array-has-fill-pointer-p destination))))
-
-;;; Format-Universal-Time - External.
-
-(defun format-universal-time (destination universal-time
-					  &key (timezone nil)
-					  (style :short)
-					  (date-first t)
-					  (print-seconds t)
-					  (print-meridian t)
-					  (print-timezone t)
-					  (print-weekday t))
-  "Format-Universal-Time formats a string containing the time and date
-   given by universal-time in a common manner.  The destination is any
-   destination which can be accepted by the Format function.  The
-   timezone keyword is an integer specifying hours west of Greenwich.
-   The style keyword can be :short (numeric date), :long (months and
-   weekdays expressed as words), :abbreviated (like :long but words are
-   abbreviated), or :government (of the form \"XX Mon XX XX:XX:XX\")
-   The keyword date-first, if nil, will print the time first instead
-   of the date (the default).  The print- keywords, if nil, inhibit
-   the printing of the obvious part of the time/date."
-  (unless (valid-destination-p destination)
-    (error "~A: Not a valid format destination." destination))
-  (unless (integerp universal-time)
-    (error "~A: Universal-Time should be an integer." universal-time))
-  (when timezone
-    (unless (and (integerp timezone) (<= 0 timezone 32))
-      (error "~A: Timezone should be an integer between 0 and 32."
-	     timezone)))
-  (multiple-value-bind (secs mins hours day month year dow dst tz)
-		       (decode-universal-time universal-time timezone)
-    (declare (ignore dst) (fixnum secs mins hours day month year dow))
-    (let ((time-string "~2,'0D:~2,'0D")
-	  (date-string
-	   (case style
-	     (:short "~D/~D/~2,'0D")             ;;  MM/DD/YY
-	     ((:abbreviated :long) "~A ~D, ~D")  ;;  Month DD, YYYY
-	     (:government "~2,'0D ~:@(~A~) ~D")      ;;  DD MON YY
-	     (t
-	      (error "~A: Unrecognized :style keyword value." style))))
-	  (time-args
-	   (list mins (max (mod hours 12) (1+ (mod (1- hours) 12)))))
-	  (date-args (case style
-		       (:short
-			(list month day (mod year 100)))
-		       (:abbreviated
-			(list (svref abbrev-month-table (1- month)) day year))
-		       (:long
-			(list (svref long-month-table (1- month)) day year))
-		       (:government
-			(list day (svref abbrev-month-table (1- month))
-			      (mod year 100))))))
-      (declare (simple-string time-string date-string))
-      (when print-weekday
-	(push (case style
-		((:short :long) (svref long-weekday-table dow))
-		(:abbreviated (svref abbrev-weekday-table dow))
-		(:government (svref abbrev-weekday-table dow)))
-	      date-args)
-	(setq date-string
-	      (concatenate 'simple-string "~A, " date-string)))
-      (when (or print-seconds (eq style :government))
-	(push secs time-args)
-	(setq time-string
-	      (concatenate 'simple-string time-string ":~2,'0D")))
-      (when print-meridian
-	(push (signum (floor hours 12)) time-args)
-	(setq time-string
-	      (concatenate 'simple-string time-string " ~[am~;pm~]")))
-      (apply #'format destination
-	     (if date-first
-		 (concatenate 'simple-string date-string " " time-string
-			      (if print-timezone " ~A"))
-		 (concatenate 'simple-string time-string " " date-string
-			      (if print-timezone " ~A")))
-	     (if date-first
-		 (nconc date-args (nreverse time-args)
-			(if print-timezone
-			    (list
-			     (let ((which-zone (or timezone tz)))
-			       (if (or (= 0 which-zone) (<= 5 which-zone 8))
-				   (svref timezone-table which-zone)
-				   (format nil "[~D]" which-zone))))))
-		 (nconc (nreverse time-args) date-args
-			(if print-timezone
-			    (list
-			     (let ((which-zone (or timezone tz)))
-			       (if (or (= 0 which-zone) (< 5 which-zone 8))
-				   (svref timezone-table which-zone)
-				   (format nil "[~D]" which-zone)))))))))))
-
-;;; Format-Decoded-Time - External.
-
-(defun format-decoded-time (destination seconds minutes hours
-					  day month year
-					  &key (timezone nil)
-					  (style :short)
-					  (date-first t)
-					  (print-seconds t)
-					  (print-meridian t)
-					  (print-timezone t)
-					  (print-weekday t))
-  "Format-Decoded-Time formats a string containing decoded-time
-   expressed in a humanly-readable manner.  The destination is any
-   destination which can be accepted by the Format function.  The
-   timezone keyword is an integer specifying hours west of Greenwich.
-   The style keyword can be :short (numeric date), :long (months and
-   weekdays expressed as words), or :abbreviated (like :long but words are
-   abbreviated).  The keyword date-first, if nil, will cause the time
-   to be printed first instead of the date (the default).  The print-
-   keywords, if nil, inhibit the printing of certain semi-obvious
-   parts of the string."
-  (unless (valid-destination-p destination)
-    (error "~A: Not a valid format destination." destination))
-  (unless (and (integerp seconds) (<= 0 seconds 59))
-    (error "~A: Seconds should be an integer between 0 and 59." seconds))
-  (unless (and (integerp minutes) (<= 0 minutes 59))
-    (error "~A: Minutes should be an integer between 0 and 59." minutes))
-  (unless (and (integerp hours) (<= 0 hours 23))
-    (error "~A: Hours should be an integer between 0 and 23." hours))
-  (unless (and (integerp day) (<= 1 day 31))
-    (error "~A: Day should be an integer between 1 and 31." day))
-  (unless (and (integerp month) (<= 1 month 12))
-    (error "~A: Month should be an integer between 1 and 12." month))
-  (unless (and (integerp year) (plusp year))
-    (error "~A: Hours should be an non-negative integer." year))
-  (when timezone
-    (unless (and (integerp timezone) (<= 0 timezone 32))
-      (error "~A: Timezone should be an integer between 0 and 32."
-	     timezone)))
-  (format-universal-time destination
-   (encode-universal-time seconds minutes hours day month year)
-   :timezone timezone :style style :date-first date-first
-   :print-seconds print-seconds :print-meridian print-meridian
-   :print-timezone print-timezone :print-weekday print-weekday))
-
-
diff --git a/code/format.lisp b/code/format.lisp
deleted file mode 100644
index a3d1adfbca63187ac2a13427a94babdaac8e94ef..0000000000000000000000000000000000000000
--- a/code/format.lisp
+++ /dev/null
@@ -1,1538 +0,0 @@
-;;; -*- Log: code.log; Package: Lisp -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; Functions to implement FORMAT for Spice Lisp.
-;;;
-;;; Original by David Adam.
-;;; Re-write by Bill Maddox.
-;;; Currently not maintained.
-;;;
-;;; FORMAT is part of the standard Spice Lisp environment.
-;;;
-(in-package "LISP")
-
-(export '(format))
-
-;;; Special variables local to FORMAT
-
-(defvar *format-control-string* ""
-  "The current FORMAT control string")
-
-(defvar *format-index* 0
-  "The current index into *format-control-string*")
-
-(defvar *format-length* 0
-  "The length of the current FORMAT control string")
-
-(defvar *format-arguments* ()
-  "Arguments to the current call of FORMAT")
-
-(defvar *format-original-arguments* ()
- "Saved arglist from top-level FORMAT call for ~* and ~@*")
-
-(defvar *format-stream-stack* ()
-  "A stack of string streams for collecting FORMAT output")
-
-(defvar *format-dispatch-table* ()
-  "Dispatch table for FORMAT commands")
-
-
-;;; Specials imported from PRINT and STREAM
-
-(proclaim '(special *print-base* *standard-output* *terminal-io*))
-
-;;; Specials imported from ERRORFUNS
-
-(proclaim '(special *error-output*))
-
-
-
-;;;; ERRORS
-
-;;; Since errors may occur while an indirect control string is being
-;;; processed, i.e. by ~? or ~{~:}, some sort of backtrace is necessary
-;;; in order to indicate the location in the control string where the
-;;; error was detected.  To this end, errors detected by format are
-;;; signalled by throwing a list of the form ((control-string args))
-;;; to the tag FORMAT-ERROR.  This throw will be caught at each level
-;;; of indirection, and the list of error messages re-thrown with an
-;;; additional message indicating that indirection was present CONSed
-;;; onto it.  Ultimately, the last throw will be caught by the top level
-;;; FORMAT function, which will then signal an error to the Lisp error
-;;; system in such a way that all the errror messages will be displayed
-;;; in reverse order.
-
-(defun format-error (complaint &rest args)
-  (throw 'format-error
-	 (list (list "~1{~:}~%~S~%~V@T^" complaint args
-		     *format-control-string* (1+ *format-index*)))))
-
-
-
-;;; MACROS
-
-;;; This macro establishes the correct environment for processing
-;;; an indirect control string.  CONTROL-STRING is the string to
-;;; process, and FORMS are the forms to do the processing.  They 
-;;; invariably will involve a call to SUB-FORMAT.  CONTROL-STRING
-;;; is guaranteed to be evaluated exactly once.
-
-(defmacro format-with-control-string (control-string &body forms)
-  `(let ((string (if (simple-string-p ,control-string)
-		     ,control-string
-		     (coerce ,control-string 'simple-string))))
-     (declare (simple-string string))
-     (let ((error (catch 'format-error
-			 (let ((*format-control-string* string)
-			       (*format-length* (length string))
-			       (*format-index* 0))
-			   (declare (simple-string *format-control-string*)
-				    (fixnum *format-length* *format-index*))
-			   ,@forms
-			   nil))))
-       (when error
-	 (throw 'format-error
-	   (cons (list "While processing indirect control string~%~S~%~V@T^"
-		       *format-control-string*
-		       (1+ *format-index*))
-	       error))))))
-
-
-;;;; WITH-FORMAT-PARAMETERS, and other useful macros.
-;;; This macro rebinds collects output to the standard output stream
-;;; in a string.  For efficiency, we avoid consing a new stream on
-;;; every call.  A stack of string streams is maintained in order to
-;;; guarantee re-entrancy.
-
-(defmacro format-stringify-output (&body forms)
-  `(let ((*standard-output*
-	  (if *format-stream-stack*
-	      (pop *format-stream-stack*)
-	      (make-string-output-stream))))
-     (unwind-protect
-	 (progn ,@forms
-	   (prog1
-	       (get-output-stream-string *standard-output*)
-	     (push *standard-output* *format-stream-stack*)))
-       (get-output-stream-string *standard-output*))))
-
-
-
-;;; Pops an argument from the current argument list.  This is either the
-;;; list of arguments given to the top-level call to FORMAT, or the argument
-;;; list for the current iteration in a ~{~} construct.  An error is signalled
-;;; if the argument list is empty.
-
-(defmacro pop-format-arg ()
-  '(if *format-arguments*
-       (pop *format-arguments*)
-       (format-error "Missing argument")))
-
-
-;;; This macro decomposes the argument list returned by PARSE-FORMAT-OPERATION.
-;;; PARMVAR is the list of parameters.  PARMDEFS is a list of lists of the form
-;;; (<var> <default>).  The FORMS are evaluated in an environment where each 
-;;; <var> is bound to either the value of the parameter supplied in the 
-;;; parameter list, or to its <default> value if the parameter was omitted or
-;;; explicitly defaulted.
-
-(defmacro with-format-parameters (parmvar parmdefs &body forms)
-  (do ((parmdefs parmdefs (cdr parmdefs))
-       (bindings () (cons `(,(caar parmdefs) (or (if ,parmvar (pop ,parmvar))
-						 ,(cadar parmdefs)))
-			 bindings)))
-      ((null parmdefs)
-       `(let ,(nreverse bindings)
-	  (when ,parmvar
-	    (format-error "Too many parameters"))
-	  ,@forms))))
-
-
-
-;;;; Control String Parsing 
-
-;;; The current control string is kept in *format-control-string*. 
-;;; The variable *format-index* is the position of the last character
-;;; processed, indexing from zero.  The variable *format-length* is the
-;;; length of the control string, which is one greater than the maximum
-;;; value of *format-index*.  
-
-
-;;; Gets the next character from the current control string.  It is an
-;;; error if there is none.  Leave *format-index* pointing to the
-;;; character returned.
-
-(defmacro nextchar ()
-  '(if (< (the fixnum (incf (the fixnum *format-index*)))
-	  (the fixnum *format-length*))
-       (schar *format-control-string* *format-index*)
-       (format-error "Syntax error")))
-
-
-;;; Returns the current character, i.e. the one pointed to by *format-index*.
-
-(defmacro format-peek ()
-  '(schar *format-control-string* *format-index*))
-
-
-;;; Returns the index of the first occurrence of the specified character
-;;; between indices START (inclusive) and END (exclusive) in the control
-;;; string.
-
-
-(defmacro format-find-char (char start end)
-  `(position ,char (the simple-string *format-control-string*)
-	     :start ,start :end ,end :test #'char=))
-
-
-;;; Attempts to parse a parameter, starting at the current index.
-;;; Returns the value of the parameter, or NIL if none is found. 
-;;; On exit, *format-index* points to the first character which is
-;;; not a part of the recognized parameter.
-
-(defun format-get-parameter ()
-  (case (format-peek)
-    (#\# (nextchar) (length (the list *format-arguments*)))
-    ((#\V #\v) (prog1 (pop-format-arg) (nextchar)))
-    (#\' (prog1 (nextchar) (nextchar)))
-    ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
-     (do* ((number (digit-char-p (format-peek))
-		   (+ (* 10 number) (digit-char-p (format-peek)))))
-	  ((not (digit-char-p (nextchar))) number)))
-    (#\-
-     (nextchar)
-     (case (format-peek)
-       ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
-	(do* ((number (digit-char-p (format-peek))
-		      (+ (* 10 number) (digit-char-p (format-peek)))))
-	     ((not (digit-char-p (nextchar))) (- number))))
-       (t (decf (the fixnum *format-index*))  ; put back to out of place "-"
-	  nil)))
-    (#\+
-     (nextchar)
-     (case (format-peek)
-       ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
-	(do* ((number (digit-char-p (format-peek))
-		      (+ (* 10 number) (digit-char-p (format-peek)))))
-	     ((not (digit-char-p (nextchar))) number)))
-       (t (decf (the fixnum *format-index*))  ; put back to out of place "-"
-	  nil)))
-    (t nil)))
-
-
-;;;; Parsing the directives to FORMAT.
-
-;;; PARSE-FORMAT-OPERATION parses a format directive, including flags and
-;;; parameters.  On entry, *format-index* should point to the "~" preceding the
-;;; command.  On exit, *format-index* points to the command character itself.
-;;; Returns the list of parameters, the ":" flag, the "@" flag, and the command
-;;; character as multiple values.  Explicitly defaulted parameters appear in
-;;; the list of parameters as NIL.  Omitted parameters are simply not included
-;;; in the list at all.
-;;;
-(defmacro parse-format-operation-modifier ()
-  `(let ((temp (format-peek)))
-     (cond ((char= temp #\:)
-	    (nextchar)
-	    (setf colon-p t))
-	   ((char= temp #\@)
-	    (nextchar)
-	    (setf atsign-p t)))))
-;;;
-(defun parse-format-operation ()
-  (let* ((ch (nextchar))
-	 (parms (if (or (digit-char-p ch)
-			(member ch '(#\, #\# #\V #\v #\' #\+ #\-) :test #'char=))
-		    (do ((parms (list (format-get-parameter))
-				(cons (format-get-parameter) parms)))
-			((char/= (format-peek) #\,) (nreverse parms))
-		      (declare (list parms))
-		      (nextchar))
-		    '()))
-	 colon-p atsign-p)
-    (parse-format-operation-modifier)
-    (parse-format-operation-modifier)
-    (values parms colon-p atsign-p (format-peek))))
-
-
-
-;;; Starting at the current value of *format-index*, finds the first
-;;; occurrence of one of the specified directives. Embedded constructs,
-;;; i.e. those inside ~(~), ~[~], ~{~}, or ~<~>, are ignored.  And error is
-;;; signalled if no satisfactory command is found.  Otherwise, the
-;;; following are returned as multiple values:
-;;;
-;;;     The value of *format-index* at the start of the search
-;;;     The index of the "~" character preceding the command
-;;;     The parameter list of the command
-;;;     The ":" flag
-;;;     The "@" flag
-;;;     The command character
-;;;
-;;; Implementation note:  The present implementation is not particulary
-;;; careful with storage allocation.  It would be a good idea to have
-;;; a separate function for skipping embedded constructs which did not
-;;; bother to cons parameter lists and then throw them away.
-;;;
-;;; We go to some trouble here to use POSITION for most of the searching.
-;;;
-;;; Another note: *FORMAT-ARGUMENTS* is let bound here so that we can
-;;; guarantee that that list is not changed by FORMAT-FIND-COMMAND.
-;;; This is necessary since PARSE-FORMAT-OPERATION (called below) calls
-;;; FORMAT-GET-PARAMETER.  If the parameter is #\V or #\v then
-;;; FORMAT-GET-PARAMETER will pop *FORMAT-ARGUMENTS*.  This causes the
-;;; argument to be lost when we actually go to do the real formatting.
-;;;
-(defun format-find-command (command-list)
-  (let ((start *format-index*)
-	(*format-arguments* *format-arguments*))
-    (do ((place start *format-index*)
-	 (tilde (format-find-char #\~ start *format-length*)
-		(format-find-char #\~ place *format-length*)))
-	((not tilde)
-	 (format-error "Expecting one of ~S" command-list))
-      (setq *format-index* tilde)
-      (multiple-value-bind (parms colon atsign command)
-			   (parse-format-operation)
-	(when (member command command-list :test #'char=)
-	  (return (values start tilde parms colon atsign command)))
-	(case command
-	  (#\{ (nextchar)(format-find-command '(#\})))
-	  (#\< (nextchar)(format-find-command '(#\>)))
-	  (#\( (nextchar)(format-find-command '(#\))))
-	  (#\[ (nextchar)(format-find-command '(#\])))
-	  ((#\} #\> #\) #\])
-	   (format-error "No matching bracket")))))))
-
- 
-
-;;;; This is the FORMAT top-level function.
-
-(defun format (destination control-string &rest format-arguments)
-  "Provides various facilities for formatting output.
-  CONTROL-STRING contains a string to be output, possibly with embedded
-  directives, which are flagged with the escape character \"~\".  Directives
-  generally expand into additional text to be output, usually consuming one
-  or more of the FORMAT-ARGUMENTS in the process.  A few useful directives
-  are:
-        ~A or ~nA     Prints one argument as if by PRINC
-        ~S or ~nS     Prints one argument as if by PRIN1
-        ~D or ~nD     Prints one argument as a decimal integer
-        ~%            Does a TERPRI
-        ~&            Does a FRESH-LINE
-
-         where n is the width of the field in which the object is printed.
-  
-  DESTINATION controls where the result will go.  If DESTINATION is T, then
-  the output is sent to the standard output stream.  If it is NIL, then the
-  output is returned in a string as the value of the call.  Otherwise,
-  DESTINATION must be a stream to which the output will be sent.
-
-  Example:   (FORMAT NIL \"The answer is ~D.\" 10) => \"The answer is 10.\"
-
-  FORMAT has many additional capabilities not described here.  Consult the
-  manual for details."
-
-  (let ((*format-original-arguments* format-arguments)	;for abs. and rel. goto
-	(*format-arguments* format-arguments)
-	(*print-radix* nil)
-	(*format-control-string*
-	 (if (simple-string-p control-string)
-	     control-string
-	     (coerce control-string 'simple-string))))
-    (declare (simple-string *format-control-string*))
-    (cond
-     ((not destination)
-      (format-stringify-output
-       (let ((errorp (catch 'format-error
-		       (catch 'format-escape
-			 (catch 'format-colon-escape
-			   (sub-format 0 (length *format-control-string*))))
-		       nil)))
-	 (when errorp
-	   (error "~%~:{~@?~%~}" (nreverse errorp))))))
-     ((and (stringp destination) (array-has-fill-pointer-p destination))
-      (with-output-to-string (*standard-output* destination)
-	(let ((errorp (catch 'format-error
-			(catch 'format-escape
-			  (catch 'format-colon-escape
-			    (sub-format 0 (length *format-control-string*))))
-			nil)))
-	  (when errorp
-	    (error "~%~:{~@?~%~}" (nreverse errorp)))
-	  nil)))
-     (t
-      (let ((*standard-output*
-	     (if (or (eq destination 't)
-		     (and (synonym-stream-p destination)
-			  (eq (synonym-stream-symbol destination)
-			      '*standard-output*)))
-		 *standard-output*
-		 destination)))
-	(let ((errorp (catch 'format-error
-			(catch 'format-escape
-			  (catch 'format-colon-escape
-			    (sub-format 0 (length *format-control-string*))))
-			nil)))
-	  (when errorp
-	    (error "~%~:{~@?~%~}" (nreverse errorp))))
-	nil)))))
-
-;;;; SUB-FORMAT, the real work of FORMAT.
-
-;;; This function does the real work of format.  The segment of the control
-;;; string between indiced START (inclusive) and END (exclusive) is processed
-;;; as follows: Text not part of a directive is output without further
-;;; processing.  Directives are parsed along with their parameters and flags,
-;;; and the appropriate handlers invoked with the arguments COLON, ATSIGN, and
-;;; PARMS. 
-;;;
-;;; Implementation Note: FORMAT-FIND-CHAR uses the POSITION stream operation
-;;; for speed.  This is potentially faster than character-at-a-time searching.
-
-(defun sub-format (start end)
-  (declare (fixnum start end))
-  (let ((*format-index* start)
-	(*format-length* end))
-    (declare (fixnum *format-index* *format-length*))
-    (do* ((place start *format-index*)
-	  (tilde (format-find-char #\~ start end)
-		 (format-find-char #\~ place end)))
-	 ((not tilde)
-	  (write-string *format-control-string*	*standard-output*
-			:start place :end end))
-      (declare (fixnum place) (type (or fixnum null) tilde))
-      (when (> tilde place)
-	(write-string *format-control-string* *standard-output*
-		      :start place :end tilde))
-      (setq *format-index* tilde)
-      (multiple-value-bind
-       (parms colon atsign command)
-       (parse-format-operation)
-       (let ((cmdfun (svref *format-dispatch-table* (char-code command))))
-	 (if cmdfun
-	     (funcall cmdfun colon atsign parms)
-	     (format-error "Illegal FORMAT command ~~~S" command))))
-      (unless (< (the fixnum (incf (the fixnum *format-index*))) end)
-	(return)))))
-
-
-
-;;;; Conditional case conversion  ~( ... ~)
-
-(defun format-capitalization (colon atsign parms)
-  (when parms
-    (format-error "No parameters allowed to ~~("))
-  (nextchar)
-  (multiple-value-bind
-   (prev tilde end-parms end-colon end-atsign)
-   (format-find-command '(#\)))
-   (when (or end-parms end-colon end-atsign)
-     (format-error "Flags or parameters not allowed"))
-   (let ((string (format-stringify-output (sub-format prev tilde))))
-     (declare (string string))
-     (write-string
-      (cond ((and atsign colon)
-	     (nstring-upcase string))
-	    (colon
-	     (nstring-capitalize string))
-	    (atsign
-	     (let ((strlen (length string)))
-	       (declare (fixnum strlen))
-	       ;; Capitalize the first word only
-	       (nstring-downcase string)
-	       (do ((i 0 (1+ i)))
-		   ((or (<= strlen i) (alpha-char-p (char string i)))
-		    (setf (char string i) (char-upcase (char string i)))
-		    string)
-		 (declare (fixnum i)))))
-	    (t (nstring-downcase string)))))))
-
-
-
-;;; Up and Out (Escape)  ~^
-
-(defun format-escape (colon atsign parms)
-  (when atsign
-    (format-error "FORMAT command ~~~:[~;:~]@^ is undefined" colon))
-  (when (if (first parms)
-	    (if (second parms)
-		(if (third parms)
-		    (typecase (second parms)
-		      (integer
-		       (<= (first parms) (second parms) (third parms)))
-		      (character
-		       (char< (first parms) (second parms) (third parms)))
-		      (t nil))
-		    (equal (first parms) (second parms)))
-		(zerop (first parms)))
-	    (not *format-arguments*))
-    (throw (if colon 'format-colon-escape 'format-escape) nil)))
-
-
-;;;; Conditional expression  ~[ ... ]
-
-
-;;; ~[ 
-
-(defun format-untagged-condition ()
-  (let ((test (pop-format-arg)))
-    (unless (integerp test)
-      (format-error "Argument to ~~[ must be integer - ~S" test))
-    (do ((count 0 (1+ count)))
-	((= count test)
-	 (multiple-value-bind
-	  (prev tilde parms colon atsign cmd)
-	  (format-find-command '(#\; #\]))
-	  (declare (ignore colon))
-	  (when atsign
-	    (format-error "Atsign flag not allowed"))
-	  (when parms
-	    (format-error "No parameters allowed"))
-	  (sub-format prev tilde)
-	  (unless (char= cmd #\])
-	    (format-find-command '(#\])))))
-      (multiple-value-bind
-       (prev tilde parms colon atsign cmd)
-       (format-find-command '(#\; #\]))
-       (declare (ignore prev tilde))
-       (when atsign
-	 (format-error "Atsign flag not allowed"))
-       (when parms
-	 (format-error "Parameters not allowed"))
-       (when (char= cmd #\]) (return))
-       (when colon
-	 (nextchar)
-	 (multiple-value-bind (prev tilde parms colon atsign cmd)
-			      (format-find-command '(#\; #\]))
-	   (declare (ignore parms colon atsign))
-	   (sub-format prev tilde)
-	   (unless (char= cmd #\])
-	     (format-find-command '(#\]))))
-	 (return))
-       (nextchar)))))
-
-
-;;; ~@[
-
-(defun format-funny-condition ()
-  (multiple-value-bind
-   (prev tilde parms colon atsign)
-   (format-find-command '(#\]))
-   (when (or colon atsign parms)
-     (format-error "Flags or arguments not allowed"))
-   (if *format-arguments*
-       (if (car *format-arguments*)
-	   (sub-format prev tilde)
-	   (pop *format-arguments*))
-       (format-error "Missing argument"))))
-
-
-;;; ~:[ 
-
-(defun format-boolean-condition ()
-  (multiple-value-bind
-   (prev tilde parms colon atsign)
-   (format-find-command '(#\;))
-   (when (or parms colon atsign)
-     (format-error "Flags or parameters not allowed"))
-   (nextchar)			  
-   (if (pop-format-arg)
-       (multiple-value-bind
-	(prev tilde parms colon atsign)
-	(format-find-command '(#\]))
-	(when (or colon atsign parms)
-	  (format-error "Flags or parameters not allowed"))
-	(sub-format prev tilde))
-       (progn
-	(sub-format prev tilde)
-	(format-find-command '(#\]))))))
-
-
-(defun format-condition (colon atsign parms)
-  (when parms
-    (push (pop parms) *format-arguments*)
-    (unless (null parms)
-      (format-error "Too many parameters to ~[")))
-  (nextchar)
-  (cond (colon
-	 (when atsign
-	   (format-error  "~~:@[ undefined"))
-	 (format-boolean-condition))
-	(atsign
-	 (format-funny-condition))
-	(t (format-untagged-condition))))
-
-
-;;;; Iteration  ~{ ... ~}
-
-(defun format-iteration (colon atsign parms)
-  (with-format-parameters parms ((max-iter -1))
-    (nextchar)
-    (multiple-value-bind
-     (prev tilde end-parms end-colon end-atsign)
-     (format-find-command '(#\}))
-     (when (or end-atsign end-parms)
-       (format-error "Illegal terminator for ~~{"))
-     (if (= prev tilde)
-	 ;; Use an argument as the control string if ~{~} is empty
-	 (let ((string (pop-format-arg)))
-	   (unless (stringp string)
-	     (format-error "Control string is not a string"))
-	   (format-with-control-string string
-	     (format-do-iteration 0 *format-length*
-				  max-iter colon atsign end-colon)))
-	 (format-do-iteration prev tilde max-iter colon atsign end-colon)))))
-
-
-;;; The two catch tags FORMAT-ESCAPE and FORMAT-COLON-ESCAPE are needed here
-;;; to correctly implement ~^ and ~:^.  The former aborts only the current
-;;; iteration, but the latter aborts the entire iteration process.
-
-(defun format-do-iteration (start end max-iter colon atsign at-least-once-p)
-  (catch 'format-colon-escape
-    (catch 'format-escape
-      (if atsign
-	  (do* ((count 0 (1+ count)))
-	       ((or (= count max-iter)
-		    (and (null *format-arguments*)
-			 (if (= count 0) (not at-least-once-p) t))))
-	    (catch 'format-escape
-	      (if colon
-		  (let* ((*format-original-arguments* (pop-format-arg))
-			 (*format-arguments* *format-original-arguments*))
-		    (unless (listp *format-arguments*)
-		      (format-error "Argument must be a list"))
-		    (sub-format start end))
-		  (sub-format start end))))
-	  (let* ((*format-original-arguments* (pop-format-arg))
-		 (*format-arguments* *format-original-arguments*))
-	    (unless (listp *format-arguments*)
-	      (format-error "Argument must be a list"))
-	    (do* ((count 0 (1+ count)))
-		 ((or (= count max-iter)
-		      (and (null *format-arguments*)
-			   (if (= count 0) (not at-least-once-p) t))))
-	      (catch 'format-escape
-		(if colon
-		    (let* ((*format-original-arguments* (pop-format-arg))
-			   (*format-arguments* *format-original-arguments*))
-		      (unless (listp *format-arguments*)
-			(format-error "Argument must be a list of lists"))
-		      (sub-format start end))
-		    (sub-format start end)))))))))
-  
-
-
-;;;; Justification  ~< ... ~>
-
-;;; Parses a list of clauses delimited by ~; and terminated by ~>.
-;;; Recursively invoke SUB-FORMAT to process them, and return a list
-;;; of the results, the length of this list, and the total number of
-;;; characters in the strings composing the list.
-
-(defun format-get-trailing-segments ()
-  (nextchar)
-  (multiple-value-bind
-   (prev tilde colon atsign parms cmd)
-   (format-find-command '(#\; #\>))
-   (when colon
-     (format-error "~~:; allowed only after first segment in ~~<"))
-   (when (or atsign parms)
-     (format-error "Flags and parameters not allowed"))
-   (let ((str (catch 'format-escape
-		(format-stringify-output (sub-format prev tilde)))))
-     (declare (string str))
-     (if str
-	 (if (char= cmd #\;)
-	     (multiple-value-bind
-	      (segments numsegs numchars)
-	      (format-get-trailing-segments)
-	      (values (cons str segments)
-		      (1+ numsegs) (+ numchars (length str))))
-	     (values (list str) 1 (length str)))
-	 (values () 0 0)))))
-
-
-;;; Gets the first segment, which is treated specially.  Call 
-;;; FORMAT-GET-TRAILING-SEGMENTS to get the rest.
-
-(defun format-get-segments ()
-  (multiple-value-bind
-   (prev tilde parms colon atsign cmd)
-   (format-find-command '(#\; #\>))
-   (when atsign
-     (format-error "Atsign flag not allowed"))
-   (let ((first-seg (format-stringify-output (sub-format prev tilde))))
-     (if (char= cmd #\;)
-	 (multiple-value-bind
-	  (segments numsegs numchars)
-	  (format-get-trailing-segments)
-	  (if colon
-	      (values first-seg parms segments numsegs numchars)
-	      (values nil nil (cons first-seg segments) (1+ numsegs)
-		      (+ (length first-seg) numchars))))
-	 (values nil nil (list first-seg) 1 (length first-seg))))))
-
-
-   
-
-;;;; Padding functions for Justification.
-
-;;; Given the total number of SPACES needed for padding, and the number
-;;; of padding segments needed (PADDINGS), returns a list of such segments.
-;;; We try to allocate the spaces equally to each segment.  When this is
-;;; not possible, allocate any left over spaces to the first segment.
-;;;
-(defun make-pad-segs (spaces padding-segs)
-  (do* ((extra-space () (and (plusp extra-spaces)
-			     extra-inc
-			     (zerop (rem segs extra-inc))))
-	(result () (cons (cond ((= segs 1) (+ min-space extra-spaces))
-			       (extra-space (1+ min-space))
-			       (t min-space))
-			 result))
-	(min-space (truncate spaces padding-segs))
-	(extra-spaces (- spaces (* padding-segs min-space))
-		      (if extra-space
-			  (1- extra-spaces) extra-spaces))
-	(extra-inc (if (plusp extra-spaces)
-		       (truncate spaces extra-spaces)))
-	(segs padding-segs (1- segs)))
-       ((zerop segs) result)))
-  
-
-;;; Determine the actual width to be used for a field requiring WIDTH
-;;; characters according to the following rule:  If WIDTH is less than or
-;;; equal to MINCOL, use WIDTH as the actual width.  Otherwise, round up 
-;;; to MINCOL + k * COLINC for the smallest possible positive integer k.
-;;;
-(defun format-round-columns (width mincol colinc)
-  (if (> width mincol)
-      (multiple-value-bind
-       (quotient remainder)
-       (floor (- width mincol) colinc)
-       (+ mincol (* quotient colinc) (if (zerop remainder) 0 colinc)))
-      mincol))
-
-
-
-(defun format-justification (colon atsign parms)
-  (with-format-parameters parms
-    ((mincol 0) (colinc 1) (minpad 0) (padchar #\space))
-    (unless (and (integerp mincol) (not (minusp mincol)))
-      (format-error "Mincol must be a non-negative integer - ~S" mincol))
-    (unless (and (integerp colinc) (plusp colinc))
-      (format-error "Colinc must be a positive integer - ~S" colinc))
-    (unless (and (integerp minpad) (not (minusp minpad)))
-      (format-error "Minpad must be a non-negative integer - ~S" minpad))
-    (unless (characterp padchar)
-      (format-error "Padchar must be a character - ~S" padchar))
-    (nextchar)
-    (multiple-value-bind
-	(special-arg special-parms segments numsegs numchars)
-	(format-get-segments)
-      (let* ((padsegs (+ (if (or colon (= numsegs 1)) 1 0)
-			 (1- numsegs)
-			 (if (and atsign (or (/= numsegs 1) colon))
-			     1 0)))
-	     (width (format-round-columns (+ numchars (* minpad padsegs))
-					  mincol colinc))
-	     (spaces (append (if (or colon (= numsegs 1)) () '(0))
-			     (make-pad-segs (- width numchars) padsegs)
-			     (if (and atsign (or (/= numsegs 1) colon))
-				 () '(0)))))
-	(when special-arg
-	  (with-format-parameters special-parms ((spare 0)
-						 (linel (or (line-length) 72)))
-	    (let ((pos (or (charpos *standard-output*) 0)))
-	      (when (> (+ pos width spare) linel)
-		(write-string special-arg)))))
-	(cond ((and atsign (= numsegs 1) (not colon))
-	       (write-string (car segments))
-	       (dotimes (i (car spaces)) (write-char padchar)))
-	      (t
-	       (do ((segs segments (cdr segs))
-		    (spcs spaces (cdr spcs)))
-		   ((null segs) (dotimes (i (car spcs)) (write-char padchar)))
-		 (dotimes (i (car spcs)) (write-char padchar))
-		 (write-string (car segs)))))))))
-
-;;;; Newline  ~&
-
-(defun format-terpri (colon atsign parms)
-  (when (or colon atsign)
-    (format-error "Flags not allowed"))
-  (with-format-parameters parms ((repeat-count 1))
-    (dotimes (i repeat-count) (terpri))))
-
-
-;;; Fresh-line  ~%
-
-(defun format-freshline (colon atsign parms)
-  (when (or colon atsign)
-    (format-error "Flags not allowed"))
-  (with-format-parameters parms ((repeat-count 1))
-    (fresh-line)
-    (dotimes (i (1- repeat-count)) (terpri))))
-
-
-;;; Page  ~|
-
-(defun format-page (colon atsign parms)
-  (when (or colon atsign)
-    (format-error "Flags not allowed"))
-  (with-format-parameters parms ((repeat-count 1))
-    (dotimes (i repeat-count) (write-char #\form))))
-
-
-;;; Print a tilde  ~~
-
-(defun format-tilde (colon atsign parms)
-  (when (or colon atsign)
-    (format-error "Flags not allowed"))
-  (with-format-parameters parms ((repeat-count 1))
-    (dotimes (i repeat-count) (write-char #\~))))
-
-
-;;; Continue control string on next line  ~<newline>
-
-(defun format-eat-whitespace ()
-  (nextchar)
-  (setq *format-index*
-	(1- (the fixnum
-		 (position-if-not #'(lambda (ch) (or (whitespace-char-p ch)
-						     (char= ch #\linefeed)))
-				  (the simple-string *format-control-string*)
-				  :start *format-index*)))))
-
-
-(defun format-newline (colon atsign parms)
-  (when parms
-    (format-error "Parameters not allowed"))
-  (cond (colon
-	 (when atsign (format-error "~:@<newline> is undefined")))
-	(atsign (terpri)(format-eat-whitespace))
-	(t (format-eat-whitespace))))
-
-
-;;;; Pluralize word (~P) and Skip Arguments (~*)
-
-(defun format-plural (colon atsign parms)
-  (when parms
-    (format-error "Parameters not allowed"))
-  (when colon
-    ;; Back up one argument first
-    (let ((cdrs (- (length (the list *format-original-arguments*))
-		   (length (the list *format-arguments*))
-		   1)))
-      (if (minusp cdrs)
-	  (format-error  "No previous argument")
-	  (setq *format-arguments*
-		(nthcdr cdrs *format-original-arguments*)))))
-  (if (eql (pop-format-arg) 1)
-      (write-string (if atsign "y" ""))
-      (write-string (if atsign "ies" "s"))))
-
-
-
-;;; Skip arguments  (relative goto)  ~*
-
-(defun format-skip-arguments (colon atsign parms)
-  (with-format-parameters parms ((count 1))
-    (cond (atsign
-	   (when (or (minusp count)
-		     (> count (length *format-original-arguments*)))
-	     (format-error "Illegal to go to non-existant argument"))
-	   (setq *format-arguments*
-		 (nthcdr count *format-original-arguments*)))
-	  (colon
-	   (let ((cdrs (- (length (the list *format-original-arguments*))
-			  (length (the list *format-arguments*))
-			  count)))
-	     (if (minusp cdrs)
-		 (format-error  "Skip to nonexistant argument")
-		 (setq *format-arguments*
-		       (nthcdr cdrs *format-original-arguments*)))))
-	  (t
-	   (if (> count (length *format-arguments*))
-	       (format-error "Skip to nonexistant argument")
-	       (setq *format-arguments* (nthcdr count *format-arguments*)))))))
-
-  
-
-;;;; Indirection  ~?
-
-(defun format-indirection (colon atsign parms)
-  (if (or colon parms) (format-error "Colon flag or parameters not allowed"))
-  (let ((string (pop-format-arg)))
-    (unless (stringp string)
-      (format-error "Indirected control string is not a string"))
-    (format-with-control-string string
-      (if atsign
-	  (sub-format 0 *format-length*)
-	  (let* ((*format-original-arguments* (pop-format-arg))
-		 (*format-arguments* *format-original-arguments*))
-	    (unless (listp *format-arguments*)
-	      (format-error "Argument must be a list"))
-	    (sub-format 0 *format-length*))))))
-
-
-
-;;; Tabulation  ~T
-
-(defun format-tab (colon atsign parms)
-  (with-format-parameters parms ((colnum 1) (colinc 1))
-    (when colon
-      (format-error "Tab-to in pixel units not supported"))
-    (let* ((pos (charpos *standard-output*))
-	   (len (cond (pos (let ((col (if atsign (+ pos colnum) colnum)))
-			     (if (> pos col)
-				 (- colinc (rem (- pos col) colinc))
-				 (- col pos))))
-		      (atsign colnum)
-		      (t 2))))
-      (declare (fixnum len))
-      (do ((i len (- i 40)))
-	  ((<= i 40) (write-string "                                        "
-				   *standard-output* :start 0 :end i))
-	(declare (fixnum i))
-	(write-string "                                        "
-		      *standard-output*
-		      :start 0
-		      :end 40)))))
-
-;;;; Ascii  ~A
-
-(defun format-princ (colon atsign parms)
-  (let ((arg (pop-format-arg)))
-    (if (null parms)
-	(if arg (princ arg) (write-string (if colon "()" "NIL")))
-	(with-format-parameters parms
-	   ((mincol 0) (colinc 1) (minpad 0) (padchar #\space))
-	   (format-write-field (if arg
-				   (princ-to-string arg)
-				   (if colon "()" "NIL"))
-			       mincol colinc minpad padchar atsign)))))
-
-
-
-;;; S-expression  ~S
-	    
-(defun format-prin1 (colon atsign parms)
-  (let ((arg (pop-format-arg)))
-    (if (null parms)
-	(if arg (prin1 arg) (write-string (if colon "()" "NIL")))
-	(with-format-parameters parms
-	   ((mincol 0) (colinc 1) (minpad 0) (padchar #\space))
-	   (format-write-field (if arg
-				   (prin1-to-string arg)
-				   (if colon "()" "NIL"))
-			       mincol colinc minpad padchar atsign)))))
-
-
-
-;;; Character  ~C
-
-(defun format-print-character (colon atsign parms)
-  (with-format-parameters parms ()
-    (let ((char (pop-format-arg)))
-      (unless (characterp char)
-	(format-error "Argument must be a character"))
-      (cond ((not colon)
-	     (cond (atsign
-		    (prin1 char))
-		   ((zerop (char-bits char))
-		    (write-char char))
-		   (t
-		    (format-print-named-character char nil))))
-	    (t
-	     (format-print-named-character char t))))))
-
-(defun format-print-named-character (char longp)
-  (when (char-bit char :control) 
-    (write-string (if longp "Control-" "C-")))
-  (when (char-bit char :meta)
-    (write-string (if longp "Meta-" "M-")))
-  (when (char-bit char :super)
-    (write-string (if longp "Super-" "S-")))
-  (when (char-bit char :hyper)
-    (write-string (if longp "Hyper-" "H-")))
-  (let* ((ch (code-char (char-code char)))	;strip funny bits
-	 (name (char-name ch)))
-    (cond (name (write-string (string-capitalize name)))
-	  ;; Print control characters as "^"<char>
-	  ((<= 0 (the fixnum (char-code char)) 31)
-	   (write-char #\^)
-	   (write-char (code-char (+ 64 (the fixnum (char-code char))))))
-	  (t (write-char ch)))))
-	  
-
-
-
-;;;; NUMERIC PRINTING
-
-;;; Insert commas after every third digit, scanning from right to left.
-
-(defun format-add-commas (string commachar)
-  (do* ((length (length (the string string)))
-	(new-length (+ length
-		       (the fixnum (floor (the fixnum (1- length)) 3))))
-	(new-string (make-string new-length :initial-element commachar) 
-		    (replace (the string new-string)
-			     (the string string)
-			     :start1 (max 0 (- new-pos 3))
-			     :end1 new-pos
-			     :start2 (max 0 (- pos 3))
-			     :end2 pos))
-	(pos length  (- pos 3))
-	(new-pos new-length (- new-pos 4)))
-       ((not (plusp pos)) new-string)
-    (declare (fixnum length new-length pos new-pos))))
-
-
-;;; Output a string in a field at MINCOL wide, padding with PADCHAR.
-;;; Pads on the left if PADLEFT is true, else on the right.  If the
-;;; length of the string plus the minimum permissible padding, MINPAD,
-;;; is greater than MINCOL, the actual field size is rounded up to
-;;; MINCOL + k * COLINC for the smallest possible positive integer k.
-
-(defun format-write-field (string mincol colinc minpad padchar padleft)
-  (unless (and (integerp mincol) (not (minusp mincol)))
-    (format-error "Mincol must be a non-negative integer - ~S" mincol))
-  (unless (and (integerp colinc) (plusp colinc))
-    (format-error "Colinc must be a positive integer - ~S" colinc))
-  (unless (and (integerp minpad) (not (minusp minpad)))
-    (format-error "Minpad must be a non-negative integer - ~S" minpad))
-  (unless (characterp padchar)
-    (format-error "Padchar must be a character - ~S" padchar))
-  (let* ((strlen (length (the string string)))
-	 (width (format-round-columns (+ strlen minpad) mincol colinc)))
-    (cond (padleft
-	   (dotimes (i (- width strlen)) (write-char padchar))
-	   (write-string string))
-	  (t
-	   (write-string string)
-	   (dotimes (i (- width strlen)) (write-char padchar))))))
-
-
-;;; FORMAT-PRINT-NUMBER does most of the work for the numeric printing
-;;; directives.  The parameters are interpreted as defined for ~D.
-;;;
-(defun format-print-number (number radix print-commas-p print-sign-p parms)
-  (with-format-parameters parms
-    ((mincol 0) (padchar #\space) (commachar #\,))
-    (let* ((*print-base* radix)
-	   (text (princ-to-string number)))
-      (if (integerp number)
-	  (format-write-field
-	   (if (and (plusp number) print-sign-p)
-	       (if print-commas-p
-		   (concatenate 'string "+" (format-add-commas text commachar))
-		   (concatenate 'string "+" text))
-	       (if print-commas-p
-		   (format-add-commas text commachar)
-		   text))
-	   mincol 1 0 padchar t)	;colinc = 1, minpad = 0, padleft = t
-	  (write-string text)))))
-
-
-;;;; Print a cardinal number in English
-
-
-;;; The following are initialized in FORMAT-INIT to get around cold-loader
-;;; lossage.
-
-(defvar cardinal-ones () "Table of cardinal ones-place digits in English")
-
-(defvar cardinal-tens () "Table of cardinal tens-place digits in English")
-
-(defvar cardinal-teens () "Table of cardinal 'teens' digits in English")
-
-
-(defun format-print-small-cardinal (n)
-  (multiple-value-bind 
-   (hundreds rem) (truncate n 100)
-    (when (plusp hundreds)
-      (write-string (svref cardinal-ones hundreds))
-      (write-string " hundred")
-      (when (plusp rem) (write-char #\space)))    ; ; ; RAD
-    (when (plusp rem)
-      (multiple-value-bind (tens ones)
-			   (truncate rem 10)
-       (cond ((< 1 tens)
-	      (write-string (svref cardinal-tens tens))
-	      (when (plusp ones)
-		(write-char #\-)
-		(write-string (svref cardinal-ones ones))))
-	     ((= tens 1)
-	      (write-string (svref cardinal-teens ones)))
-	     ((plusp ones)
-	      (write-string (svref cardinal-ones ones))))))))
-
-
-(defvar cardinal-periods () "Table of cardinal 'illions' in English")
-
-
-(defun format-print-cardinal (n)
-  (cond ((minusp n)
-	 (write-string "negative ")
-	 (format-print-cardinal-aux (- n) 0 n))
-	((zerop n)
-	 (write-string "zero"))
-	(t (format-print-cardinal-aux n 0 n))))
-
-(defun format-print-cardinal-aux (n period err)
-  (multiple-value-bind (beyond here) (truncate n 1000)
-    (unless (<= period 10)
-      (format-error "Number too large to print in English: ~:D" err))
-    (unless (zerop beyond)
-      (format-print-cardinal-aux beyond (1+ period) err))
-    (unless (zerop here)
-      (unless (zerop beyond) (write-char #\space))
-      (format-print-small-cardinal here)
-      (write-string (svref cardinal-periods period)))))
-
-
-;;;; Print an ordinal number in English
-
-
-(defvar ordinal-ones () "Table of ordinal ones-place digits in English")
-
-(defvar ordinal-tens () "Table of ordinal tens-place digits in English")
-
-
-(defun format-print-ordinal (n)
-  (when (minusp n)
-    (write-string "negative "))
-  (let ((number (abs n)))
-    (multiple-value-bind
-     (top bot) (truncate number 100)
-     (unless (zerop top) (format-print-cardinal (- number bot)))
-     (when (and (plusp top) (plusp bot)) (write-char #\space))
-     (multiple-value-bind
-      (tens ones) (truncate bot 10)
-      (cond ((= bot 12) (write-string "twelfth"))
-	    ((= tens 1)
-	     (write-string (svref cardinal-teens ones));;;RAD
-	     (write-string "th"))
-	    ((and (zerop tens) (plusp ones))
-	     (write-string (svref ordinal-ones ones)))
-	    ((and (zerop ones)(plusp tens))
-	     (write-string (svref ordinal-tens tens)))
-	    ((plusp bot)
-	     (write-string (svref cardinal-tens tens))
-	     (write-char #\-)
-	     (write-string (svref ordinal-ones ones)))
-	    ((plusp number) (write-string "th"))
-	    (t (write-string "zeroeth")))))))
-
-
-;;; Print Roman numerals
-
-(defun format-print-old-roman (n)
-  (unless (< 0 n 5000)
-    (format-error "Number too large to print in old Roman numerals: ~:D" n))
-  (do ((char-list '(#\D #\C #\L #\X #\V #\I) (cdr char-list))
-       (val-list '(500 100 50 10 5 1) (cdr val-list))
-       (cur-char #\M (car char-list))
-       (cur-val 1000 (car val-list))
-       (start n (do ((i start (progn (write-char cur-char) (- i cur-val))))
-		    ((< i cur-val) i))))
-      ((zerop start))))
-
-
-(defun format-print-roman (n)
-  (unless (< 0 n 4000)
-    (format-error "Number too large to print in Roman numerals: ~:D" n))
-  (do ((char-list '(#\D #\C #\L #\X #\V #\I) (cdr char-list))
-       (val-list '(500 100 50 10 5 1) (cdr val-list))
-       (sub-chars '(#\C #\X #\X #\I #\I) (cdr sub-chars))
-       (sub-val '(100 10 10 1 1 0) (cdr sub-val))
-       (cur-char #\M (car char-list))
-       (cur-val 1000 (car val-list))
-       (cur-sub-char #\C (car sub-chars))
-       (cur-sub-val 100 (car sub-val))
-       (start n (do ((i start (progn (write-char cur-char) (- i cur-val))))
-		    ((< i cur-val)
-		     (cond ((<= (- cur-val cur-sub-val) i)
-			    (write-char cur-sub-char)
-			    (write-char cur-char)
-			    (- i (- cur-val cur-sub-val)))
-			   (t i))))))
-	  ((zerop start))))
-
-
-
-;;;; Format Radix Options (~D ~B ~O ~X ~R).
-
-;;; Decimal  ~D
-
-(defun format-print-decimal (colon atsign parms)
-  (format-print-number (pop-format-arg) 10 colon atsign parms))
-
-
-;;; Binary  ~B
-
-(defun format-print-binary (colon atsign parms)
-  (format-print-number (pop-format-arg) 2 colon atsign parms))
-
-
-;;; Octal  ~O
-
-(defun format-print-octal (colon atsign parms)
-  (format-print-number (pop-format-arg) 8 colon atsign parms))
-
-
-;;; Hexadecimal  ~X
-
-(defun format-print-hexadecimal (colon atsign parms)
-  (format-print-number (pop-format-arg) 16 colon atsign parms))
-
-
-;;; Radix  ~R
-
-(defun format-print-radix (colon atsign parms)
-  (let ((number (pop-format-arg)))
-    (if parms
-	(format-print-number number (pop parms) colon atsign parms)
-	(if atsign
-	    (if colon
-		(format-print-old-roman number)
-		(format-print-roman number))
-	    (if colon
-		(format-print-ordinal number)
-		(format-print-cardinal number))))))
-
-
-;;;; FLOATING-POINT NUMBERS
-
-;;; Fixed-format floating point  ~F
-;;;
-(defun format-fixed (colon atsign parms)
-  (when colon
-    (format-error "Colon flag not allowed"))
-  (with-format-parameters parms
-    ((w nil) (d nil) (k nil) (ovf nil) (pad #\space))
-    ;;Note that the scale factor k defaults to nil.  This is interpreted as
-    ;;zero by flonum-to-string, but more efficiently.
-    (let ((number (pop-format-arg)))
-      (if (floatp number)
-	  (format-fixed-aux number w d k ovf pad atsign)
-	  (if (rationalp number)
-	      (format-fixed-aux
-	       (coerce number 'short-float) w d k ovf pad atsign)
-	      (let ((*print-base* 10))
-		(format-write-field
-		 (princ-to-string number) w 1 0 #\space t)))))))
-
-
-(defun format-fixed-aux (number w d k ovf pad atsign)
-  (if (not (or w d))
-      (prin1 number)
-      (let ((spaceleft w))
-	(when (and w (or atsign (minusp number))) (decf spaceleft))
-	(multiple-value-bind 
-          (str len lpoint tpoint)
-	  (flonum-to-string (abs number) spaceleft d k)
-	  ;;if caller specifically requested no fraction digits, suppress the
-	  ;;optional trailing zero
-	  (when (and d (zerop d)) (setq tpoint nil))
-	  (when w 
-	    (decf spaceleft len)
-	    ;;optional leading zero
-	    (when lpoint
-	      (if (or (> spaceleft 0) tpoint) ;force at least one digit
-		  (decf spaceleft)
-		  (setq lpoint nil)))
-	    ;;optional trailing zero
-	    (when tpoint
-	      (if (> spaceleft 0)
-		  (decf spaceleft)
-		  (setq tpoint nil))))
-	  (cond ((and w (< spaceleft 0) ovf)
-		 ;;field width overflow
-		 (dotimes (i w) (write-char ovf)))
-		(t (when w (dotimes (i spaceleft) (write-char pad)))
-		   (if (minusp number)
-		       (write-char #\-)
-		       (if atsign (write-char #\+)))
-		   (when lpoint (write-char #\0))
-		   (write-string str)
-		   (when tpoint (write-char #\0))))))))
-
-
-;;;; Exponential-format floating point  ~E
-
-
-(defun format-exponential (colon atsign parms)
-  (when colon
-    (format-error "Colon flag not allowed"))
-  (with-format-parameters parms
-    ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (marker nil))
-    (let ((number (pop-format-arg)))
-      (if (floatp number)
-	  (format-exp-aux number w d e k ovf pad marker atsign)
-	  (if (rationalp number)
-	      (format-exp-aux
-	       (coerce number 'short-float) w d e k ovf pad marker atsign)
-	      (let ((*print-base* 10))
-		(format-write-field
-		 (princ-to-string number) w 1 0 #\space t)))))))
-
-
-(defun format-exponent-marker (number)
-  (if (typep number *read-default-float-format*)
-      #\E
-      (typecase number
-	(short-float #\S)
-;	(single-float #\F)
-	(double-float #\D)
-	(long-float #\L))))
-
-
-;;;Here we prevent the scale factor from shifting all significance out of
-;;;a number to the right.  We allow insignificant zeroes to be shifted in
-;;;to the left right, athough it is an error to specify k and d such that this
-;;;occurs.  Perhaps we should detect both these condtions and flag them as
-;;;errors.  As for now, we let the user get away with it, and merely guarantee
-;;;that at least one significant digit will appear.
-
-(defun format-exp-aux (number w d e k ovf pad marker atsign)
-  (if (not (or w d))
-      (prin1 number)
-      (multiple-value-bind (num expt)
-			   (scale-exponent (abs number))
-	(let* ((expt (- expt k))
-	       (estr (princ-to-string (abs expt)))
-	       (elen (if e (max (length estr) e) (length estr)))
-	       (fdig (if d (if (plusp k) (1+ (- d k)) d) nil))
-	       (fmin (if (minusp k) (- 1 k) nil))
-	       (spaceleft (if w (- w 2 elen) nil)))
-	  (when (or atsign (minusp number)) (decf spaceleft))
-	  (if (and w e ovf (> elen e))
-	      ;;exponent overflow
-	      (dotimes (i w) (write-char ovf))
-	      (multiple-value-bind (fstr flen lpoint )			;(tpoint)
-				   (flonum-to-string num spaceleft fdig k fmin)
-		(when w 
-		  (decf spaceleft flen)
-		  ;; (when tpoint (decf spaceleft)) ; deleted as per Rutgers' fix
-		  (when lpoint
-		    (if (> spaceleft 0)
-			(decf spaceleft)
-			(setq lpoint nil))))
-		(cond ((and w (< spaceleft 0) ovf)
-		       ;;significand overflow
-		       (dotimes (i w) (write-char ovf)))
-		      (t (when w
-			   (dotimes (i spaceleft) (write-char pad)))
-			 (if (minusp number)
-			     (write-char #\-)
-			     (if atsign (write-char #\+)))
-			 (when lpoint (write-char #\0))
-			 (write-string fstr)
-			 ;; (when tpoint (write-char #\0)) ; as per Rutgers' fix
-			 (write-char (if marker
-					 marker
-					 (format-exponent-marker number)))
-			 (write-char (if (minusp expt) #\- #\+))
-			 (when e 
-			   ;;zero-fill before exponent if necessary
-			   (dotimes (i (- e (length estr))) (write-char #\0)))
-			 (write-string estr)))))))))
-
-
-
-;;;; General Floating Point -  ~G
-
-(defun format-general-float (colon atsign parms)
-  (when colon
-    (format-error "Colon flag not allowed"))
-  (with-format-parameters parms
-    ((w nil) (d nil) (e nil) (k nil) (ovf #\*) (pad #\space) (marker nil))
-    (let ((number (pop-format-arg)))
-      ;;The Excelsior edition does not say what to do if
-      ;;the argument is not a float.  Here, we adopt the
-      ;;conventions used by ~F and ~E.
-      (if (floatp number)
-	  (format-general-aux number w d e k ovf pad marker atsign)
-	  (if (rationalp number)
-	      (format-general-aux
-	       (coerce number 'short-float) w d e k ovf pad marker atsign)
-	      (let ((*print-base* 10))
-		(format-write-field
-		 (princ-to-string number) w 1 0 #\space t)))))))
-
-
-(defun format-general-aux (number w d e k ovf pad marker atsign)
-  (multiple-value-bind (ignore n) 
-		       (scale-exponent (abs number))
-    (declare (ignore ignore))
-    ;;Default d if omitted.  The procedure is taken directly
-    ;;from the definition given in the manual, and is not
-    ;;very efficient, since we generate the digits twice.
-    ;;Future maintainers are encouraged to improve on this.
-    (unless d
-      (multiple-value-bind (str len) 
-			   (flonum-to-string (abs number))
-	(declare (ignore str))
-	(let ((q (if (= len 1) 1 (1- len))))
-	  (setq d (max q (min n 7))))))
-    (let* ((ee (if e (+ e 2) 4))
-	   (ww (if w (- w ee) nil))
-	   (dd (- d n)))
-      (cond ((<= 0 dd d)
-	     (format-fixed-aux number ww dd nil ovf pad atsign)
-	     (dotimes (i ee) (write-char #\space)))
-	    (t (format-exp-aux 
-		 number w d e (or k 1) ovf pad marker atsign))))))
-
-
-;;; Dollars floating-point format  ~$
-
-(defun format-dollars (colon atsign parms)
-  (with-format-parameters parms ((d 2) (n 1) (w 0) (pad #\space))
-    (let ((number (pop-format-arg)))
-      (if (rationalp number) (setq number (coerce number 'short-float)))
-      (if (floatp number)
-	  (let* ((signstr (if (minusp number) "-" (if atsign "+" "")))
-		 (signlen (length signstr)))
-	    (multiple-value-bind (str strlen ig2 ig3 pointplace)
-				 (flonum-to-string number nil d nil)
-	      (declare (ignore ig2 ig3))
-	      (when colon (write-string signstr))
-	      (dotimes (i (- w signlen (- n pointplace) strlen))
-		(write-char pad))
-	      (unless colon (write-string signstr))
-	      (dotimes (i (- n pointplace)) (write-char #\0))
-	      (write-string str)))
-	  (let ((*print-base* 10))
-	    (format-write-field (princ-to-string number) w 1 0 #\space t))))))
-
-
-;;;; Some stuff for Compiler, MACLISP interaction.
-
-;;; The following crock simulates some Common Lisp functions in the
-;;; cross-compiler's MACLISP environment for the benefit of the hairy
-;;; dispatch-table initialization macro. The internal representation
-;;; of character objects in the compiler is known to this code.  
-
-#|
-(eval-when (compile-maclisp)
-
-  (setq char-code-limit 256)
-
-  (defun char-downcase (char)
-    (let ((ch (cadr char)))
-      (if (lessp 64 ch 91) (list '**character** (+ ch 32)) char)))
-
-  (defun char-upcase (char)
-    (let ((ch (cadr char)))
-      (if (lessp 96 ch 123) (list '**character** (- ch 32)) char)))
-
-  (defun char= (a b)
-    (= (cadr a) (cadr b)))
-
-  (defun char< (a b)
-    (< (cadr a) (cadr b)))
-
-  (defun char-code (char)
-    (cadr char))
-
-  (defun code-char (code)
-    (list '**character** code)))
-|#
-
-;;;; INITIALIZATION
-
-
-;;; Hairy dispatch-table initialization macro.  Takes a list of two-element
-;;; lists (<character> <function-object>) and returns a vector char-code-limit
-;;; elements in length, where the Ith element is the function associated with
-;;; the character with char-code I.  If the character is case-convertible, it
-;;; must be given in only one case; however, an entry in the vector will be
-;;; made for both.
-
-
-(defmacro make-dispatch-vector (&body entries)
-  (let ((entries (mapcan #'(lambda (x)
-			     (let ((lower (char-downcase (car x)))
-				   (upper (char-upcase (car x))))
-			       (if (char= lower upper)
-				   (list x)
-				   (list (cons upper (cdr x))
-					 (cons lower (cdr x))))))
-			 entries)))
-    (do ((entries (sort entries #'(lambda (x y) (char< (car x) (car y)))))
-	 (charidx 0 (1+ charidx))
-	 (comtab () (cons (if entries
-			      (if (= (char-code (caar entries)) charidx)
-				  (cadr (pop entries))
-				  nil)
-			      nil)
-			  comtab)))
-	((= charidx char-code-limit)
-	 (if entries
-	     (error "Garbage in dispatch vector - ~S" entries))
-	 `(vector ,@(nreverse comtab))))))
-
-
-
-;;; These initializations properly belong in the DEFVARs for these objects.
-;;; At present, they must be done after loading due to a limitation in the
-;;; cold loader.
-
-(defun format-init ()
-  (setf cardinal-ones
-	'#(nil "one" "two" "three" "four" "five" "six" "seven" "eight" "nine"))
-  (setf cardinal-tens
-	'#(nil nil "twenty" "thirty" "forty"
-	       "fifty" "sixty" "seventy" "eighty" "ninety"))
-  (setf cardinal-teens
-	'#("ten" "eleven" "twelve" "thirteen" "fourteen"  ;;; RAD
-	       "fifteen" "sixteen" "seventeen" "eighteen" "nineteen"))
-  (setf cardinal-periods
-	'#("" " thousand" " million" " billion" " trillion" " quadrillion"
-	   " quintillion" " sextillion" " septillion" " octillion" " nonillion"
-	   " decillion"))
-  (setf ordinal-ones
-	'#(nil "first" "second" "third" "fourth"
-	       "fifth" "sixth" "seventh" "eighth" "ninth"))
-  (setf ordinal-tens 
-	'#(nil "tenth" "twentieth" "thirtieth" "fortieth"
-	       "fiftieth" "sixtieth" "seventieth" "eightieth" "ninetieth"))
-  (setf *format-dispatch-table*
-	(make-dispatch-vector
-	 (#\B #'format-print-binary)
-	 (#\O #'format-print-octal)
-	 (#\D #'format-print-decimal)
-	 (#\X #'format-print-hexadecimal)
-	 (#\R #'format-print-radix)
-	 (#\F #'format-fixed)
-	 (#\E #'format-exponential)
-         (#\G #'format-general-float)
-	 (#\A #'format-princ)
-	 (#\C #'format-print-character)
-	 (#\P #'format-plural)
-	 (#\S #'format-prin1)
-	 (#\T #'format-tab)
-	 (#\% #'format-terpri)
-	 (#\& #'format-freshline)
-	 (#\* #'format-skip-arguments)
-	 (#\| #'format-page)
-	 (#\~ #'format-tilde)
-	 (#\$ #'format-dollars)
-	 (#\? #'format-indirection)
-	 (#\^ #'format-escape)
-	 (#\[ #'format-condition)
-	 (#\{ #'format-iteration)
-	 (#\< #'format-justification)
-	 (#\( #'format-capitalization)
-	 (#\newline #'format-newline))))
diff --git a/code/gc.lisp b/code/gc.lisp
deleted file mode 100644
index 6f212a8e703fda1a17a697dfdd024e42d105b1eb..0000000000000000000000000000000000000000
--- a/code/gc.lisp
+++ /dev/null
@@ -1,612 +0,0 @@
-;;; -*- Mode: Lisp; Package: LISP; Log: code.log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; Spice Lisp is currently incomplete and under active development.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (Scott.Fahlman@CS.CMU.EDU). 
-;;; **********************************************************************
-;;;
-;;; Garbage collection and allocation related code.
-;;;
-;;; Written by Christopher Hoover, Rob MacLachlan, Dave McDonald, et al.
-;;; 
-
-(in-package "EXTENSIONS")
-(export '(*before-gc-hooks* *after-gc-hooks* gc gc-on gc-off
-	  *bytes-consed-between-gcs* *gc-verbose* *gc-inhibit-hook*
-	  *gc-notify-before* *gc-notify-after* get-bytes-consed))
-
-(in-package "LISP")
-(export '(room))
-
-
-
-;;;; Room.
-
-(defvar alloctable-address (int-sap %fixnum-alloctable-address)
-  "A system area pointer that addresses the the alloctable.")
-
-(defun alloc-ref (index)
-  (logior (%primitive 16bit-system-ref alloctable-address (1+ index))
-	  (ash (logand %type-space-mask
-		       (%primitive 16bit-system-ref alloctable-address index))
-	       16)))
-
-(defun space-usage (type)
-  (let ((base (ash type %alloc-ref-type-shift)))
-    (values (alloc-ref base)
-	    (alloc-ref (+ base 8))
-	    (alloc-ref (+ base 12)))))
-
-(defconstant type-space-names
-  '#("Bignum" "Ratio" "Complex" "Short-Float" "Short-Float" "Long-Float"
-     "String" "Bit-Vector" "Integer-Vector" "Code-Vector" "General-Vector"
-     "Array" "Function" "Symbol" "List"))
-
-(defun room-header ()
-  (fresh-line)
-  (princ "       Type        |  Dynamic  |   Static  | Read-Only |   Total")
-  (terpri)
-  (princ "-------------------|-----------|-----------|-----------|-----------")
-  (terpri))
-
-(defun room-summary (dynamic static read-only)
-  (princ "-------------------|-----------|-----------|-----------|-----------")
-  (format t "~% Totals:           |~10:D |~10:D |~10:D =~10:D~%" 
-	  dynamic static read-only (+ static dynamic read-only)))
-
-(defun describe-one-type (type dynamic static read-only)
-  (declare (fixnum type dynamic static read-only))
-  (format t "~18A |~10:D |~10:D |~10:D |~10:D~%"
-	  (elt (the simple-vector type-space-names)
-	       (the fixnum (- type (the fixnum %first-pointer-type))))
-	  dynamic static read-only (the fixnum (+ static dynamic read-only))))
-
-(defun room (&optional (x t) (object nil argp))
-  "Displays information about storage allocation.
-  If X is true then information is displayed broken down by types.
-  If Object is supplied then just display information for objects of
-  that type."
-  (when x
-    (let ((type (%primitive get-type object)))
-      (when (or (> type %last-pointer-type)
-		(< type %first-pointer-type))
-	(error "Objects of type ~S have no allocated storage."
-	       (type-of object)))
-      (room-header)
-      (cond
-       (argp
-	(multiple-value-bind (dyn stat ro)
-			     (space-usage type)
-	  (describe-one-type type dyn stat ro)))
-       (t
-        (let ((cum-dyn 0)
-	      (cum-stat 0)
-	      (cum-ro 0))
-	  (do ((type %first-pointer-type (1+ type)))
-	      ((= type (1+ %last-pointer-type)))
-	    (if (not (or (eq type %short-+-float-type)
-			 (eq type %short---float-type)))
-		(multiple-value-bind (dyn stat ro)
-				     (space-usage type)
-		  (describe-one-type type dyn stat ro)
-		  (incf cum-dyn dyn) (incf cum-stat stat) (incf cum-ro ro))))
-	  (room-summary cum-dyn cum-stat cum-ro)))))))
-
-
-;;;; DYNAMIC-USAGE.
-
-;;; 
-;;; DYNAMIC-USAGE -- Interface
-;;;
-;;; Return the number of bytes of dynamic storage allocated.
-;;;
-(defun dynamic-usage ()
-  "Returns the number of bytes of dynamic storage currently allocated."
-  (system:%primitive dynamic-space-in-use))
-
-
-;;;; GET-BYTES-CONSED.
-
-;;;
-;;; Internal State
-;;; 
-(defvar *last-bytes-in-use* nil)
-(defvar *total-bytes-consed* 0)
-
-;;;
-;;; GET-BYTES-CONSED -- Exported
-;;; 
-(defun get-bytes-consed ()
-  "Returns the number of bytes consed since the first time this function
-  was called.  The first time it is called, it returns zero."
-  (cond ((null *last-bytes-in-use*)
-	 (setq *last-bytes-in-use* (dynamic-usage))
-	 (setq *total-bytes-consed* 0))
-	(t
-	 (let ((bytes (dynamic-usage)))
-	   (incf *total-bytes-consed* (- bytes *last-bytes-in-use*))
-	   (setq *last-bytes-in-use* bytes))))
-  *total-bytes-consed*)
-    
-
-;;;; Variables and Constants.
-
-;;; The default value of *BYTES-CONSED-BETWEEN-GCS* and *GC-TRIGGER*.
-;;; 
-(defconstant default-bytes-consed-between-gcs 2000000)
-
-;;; This variable is the user-settable variable that specifices the
-;;; minimum amount of dynamic space which must be consed before a GC
-;;; will be triggered.
-;;; 
-(defvar *bytes-consed-between-gcs* default-bytes-consed-between-gcs
-  "This number specifies the minimum number of bytes of dynamic space
-  that must be consed before the next gc will occur.")
-
-;;; Internal trigger.  When the dynamic usage increases beyond this
-;;; amount, the system notes that a garbage collection needs to occur by
-;;; setting *NEED-TO-COLLECT-GARBAGE* to T.
-;;; 
-(defvar *gc-trigger* default-bytes-consed-between-gcs)
-
-
-
-;;;
-;;; The following specials are used to control when garbage collection
-;;; occurs.
-;;; 
-
-;;; 
-;;; *GC-INHIBIT*
-;;;
-;;; When non-NIL, inhibits garbage collection.
-;;; 
-(defvar *gc-inhibit* nil)
-
-;;;
-;;; *ALREADY-MAYBE-GCING*
-;;;
-;;; This flag is used to prevent recursive entry into the garbage
-;;; collector.
-;;; 
-(defvar *already-maybe-gcing* nil)
-
-;;; When T, indicates that the dynamic usage has exceeded the value
-;;; *GC-TRIGGER*.
-;;; 
-(defvar *need-to-collect-garbage* nil)
-
-
-;;;; GC Hooks.
-
-;;;
-;;; *BEFORE-GC-HOOKS*
-;;; *AFTER-GC-HOOKS*
-;;;
-;;; These variables are a list of functions which are run before and
-;;; after garbage collection occurs.
-;;;
-(defvar *before-gc-hooks* nil
-  "A list of functions that are called before garbage collection occurs.
-  The functions should take no arguments.")
-;;; 
-(defvar *after-gc-hooks* nil
-  "A list of functions that are called after garbage collection occurs.
-  The functions should take no arguments.")
-
-;;;
-;;; *GC-INHIBIT-HOOK*
-;;; 
-;;; This hook is invoked whenever SUB-GC intends to GC (unless the GC
-;;; was explicitly forced by calling EXT:GC).  If the hook function
-;;; returns NIL then the GC procedes; otherwise, the GC is inhibited and
-;;; *GC-INHIBIT* and *NEED-TO-COLLECT-GARBAGE* are left bound to T.
-;;; Presumably someone will call GC-ON later to collect the garbage.
-;;;
-(defvar *gc-inhibit-hook* nil
-  "Should be bound to a function or NIL.  If it is a function, this
-  function should take one argument, the current amount of dynamic
-  usage.  The function should return NIL if garbage collection should
-  continue and non-NIL if it should be inhibited.  Use with caution.")
-
-
-
-;;;
-;;; *GC-VERBOSE*
-;;;
-(defvar *gc-verbose* t
-  "When non-NIL, causes the functions bound to *GC-NOTIFY-BEFORE* and
-  *GC-NOTIFY-AFTER* to be called before and after a garbage collection
-  occurs respectively.")
-
-
-(defun default-gc-notify-before (bytes-in-use)
-  (system:beep *standard-output*)
-  (format t "~&[GC threshold exceeded with ~:D bytes in use.  ~
-  Commencing GC.]~%" bytes-in-use)
-  (finish-output))
-;;;
-(defparameter *gc-notify-before* #'default-gc-notify-before
-  "This function bound to this variable is invoked before GC'ing (unless
-  *GC-VERBOSE* is NIL) with the current amount of dynamic usage (in
-  bytes).  It should notify the user that the system is going to GC.")
-
-(defun default-gc-notify-after (bytes-retained bytes-freed new-trigger)
-  (format t "[GC completed with ~:D bytes retained and ~:D bytes freed.]~%"
-	  bytes-retained bytes-freed)
-  (format t "[GC will next occur when at least ~:D bytes are in use.]~%"
-	  new-trigger)
-  (system:beep *standard-output*)
-  (finish-output))
-;;;
-(defparameter *gc-notify-after* #'default-gc-notify-after
-  "The function bound to this variable is invoked after GC'ing (unless
-  *GC-VERBOSE* is NIL) with the amount of dynamic usage (in bytes) now
-  free, the number of bytes freed by the GC, and the new GC trigger
-  threshold.  The function should notify the user that the system has
-  finished GC'ing.")
-
-
-;;;; Stack grovelling:
-
-;;; VECTOR-ALLOC-END  --  Internal
-;;;
-;;;    Return a pointer to past the end of the memory allocated for a
-;;; vector-like object.
-;;;
-(defun vector-alloc-end (vec)
-  (%primitive pointer+
-	      vec
-	      (* (%primitive vector-word-length vec) %word-size)))
-
-
-(defvar *gc-debug* nil)
-
-;;; PRINT-RAW-ADDR  --  Interface
-;;;
-;;;    Print the full address of an arbitary object.
-;;;
-(defun print-raw-addr (x &optional (stream *standard-output*))
-  (let ((fix (%primitive make-fixnum x)))
-    (format stream "~4,'0X~4,'0X "
-	    (logior (ash (%primitive get-type x) 11)
-		    (ash (%primitive get-space x) 9)
-		    (ash fix -16))
-	    (logand fix #xFFFF))))
-
-
-;;; GC-GROVEL-STACK  --  Internal
-;;;
-;;;    Locate all raw pointers on stack stack, and clobber them with something
-;;; that won't cause GC to gag.  We return a list of lists of the form:
-;;;    (object offset stack-location*),
-;;; 
-;;; where Object is some valid vector-like object pointer and Offset is an
-;;; offset to be added to Object.  The result of this addition should be stored
-;;; into each Stack-Location after GC completes.  We clobber the stack
-;;; locations with Offset for no particular reason (might aid debugging.)
-;;;
-;;; There are three major steps in the algorithm:
-;;;
-;;;  1] Find all the distinct vector-like pointers on the stack, building a
-;;;     list of all the locations that each pointer is stored in.  We do this
-;;;     using two hash-tables: the one for code pointers is separate, since
-;;;     they must be special-cased.
-;;;
-;;;     Note that we do our scan downward from the current CONT, and thus don't
-;;;     scan our own frame.  We don't want to modify the frame for the running
-;;;     function, as this is apt to cause problems.  It isn't necessary to
-;;;     grovel the current frame because we return before GC happens.
-;;;
-;;;  2] Sort all of the vector-like pointers (other than code vectors), and
-;;;     scan through this list finding raw pointers based on the assumption
-;;;     that we will always see the true pointer to the vector header before
-;;;     any raw pointers into that vector.  This exploits our GC invariant that
-;;;     when an indexing temp is in use, the true object pointer must be live
-;;;     on the stack or in a register.  [By now, any register indexing temp
-;;;     will have been saved on the stack.]
-;;;
-;;;     During this scan, we also note any true vector pointers that point to a
-;;;     function object.
-;;;
-;;;     Whenever we locate a raw vector pointer, we create a fixup for the
-;;;     locations holding that pointer and then clobber the locations.
-;;;
-;;;  3] Iterate over all code pointers, clobbering the locations and
-;;;     making fixups for those pointers that point inside some function object
-;;;     that appears on the stack.  This exploits our GC invariant that a
-;;;     *valid* code pointer only appears on the stack when some containing
-;;;     function object also appears on the stack.  Note that *invalid* code
-;;;     pointers may appear in the stack garbage unaccompanied by any function
-;;;     object.  Such isolated code pointers are set to 0.  (Code pointers in
-;;;     the heap must always point to the code vector header, and are always
-;;;     considered valid.)
-;;;
-;;;     This different invariant for code pointers allows us to throw around
-;;;     raw code pointers without clearing them when they are no longer needed.
-;;;
-(defun gc-grovel-stack ()
-  (let ((vec-table (make-hash-table :test #'eq))
-	(code-table (make-hash-table :test #'eq))
-	(base (%primitive make-immediate-type 0 %control-stack-type))
-	(fixups ()))
-    ;;
-    ;; Find all vector-like objects on the stack, putting code vectors in a
-    ;; separate table. (step 1)
-    (do ((sp (%primitive pointer+ (%primitive current-cont)
-			 (- %stack-increment))
-	     (%primitive pointer+ sp (- %stack-increment))))
-	((%primitive pointer< sp base))
-      (let* ((el (%primitive read-control-stack sp))
-	     (el-type (%primitive get-type el)))
-	
-	(when (and *gc-debug* (simple-vector-p el))
-	  (let ((hdr (%primitive read-control-stack el)))
-	    (unless (and (fixnump hdr) (> hdr 0)
-			 (<= (length el) #xFFFF)
-			 (<= (%primitive get-vector-subtype el)
-			     3))
-	      (format t "Suspicious G-vector ")
-	      (print-raw-addr el)
-	      (format t "at ")
-	      (print-raw-addr sp)
-	      (terpri))))
-
-	(when (and (< (%primitive get-space el) %static-space)
-		   (<= %string-type el-type %function-type))
-	  (push sp (gethash el
-			    (if (eq el-type %code-type)
-				code-table
-				vec-table))))))
-
-    (let ((vecs ())
-	  (functions ()))
-      (maphash #'(lambda (k v)
-		   (declare (ignore v))
-		   (push k vecs))
-	       vec-table)
-
-      (setq vecs
-	    (sort vecs
-		  #'(lambda (x y)
-		      (%primitive pointer< x y))))
-
-      ;;
-      ;; Iterate over non-code vector-like pointers in order (step 2.)
-      (loop
-	(unless vecs (return))
-	(let* ((base (pop vecs))
-	       (end (vector-alloc-end base)))
-	  
-	  (when (and (= (%primitive get-type base) %function-type)
-		     (<= %function-entry-subtype
-			 (%primitive get-vector-subtype base)
-			 %function-constants-subtype))
-	    (push base functions))
-
-	  (loop
-	    (unless vecs (return))
-	    (let ((next (first vecs)))
-	      (unless (%primitive pointer< next end) (return))
-	      (pop vecs)
-	      
-	      (let ((offset (%primitive pointer- next base))
-		    (sps (gethash next vec-table)))
-		(dolist (sp sps)
-		  (%primitive write-control-stack sp offset))
-		(push (list* base offset sps) fixups))))))
-
-      ;;
-      ;; Iterate over all code pointers (step 3.)
-      (maphash #'(lambda (code-ptr sps)
-		   (dolist (fun functions
-				(dolist (sp sps)
-				  (%primitive write-control-stack sp 0)))
-		     (let* ((base (%primitive header-ref fun
-					      %function-code-slot))
-			    (end (vector-alloc-end base)))
-		       (when (and (not (%primitive pointer< code-ptr base))
-				  (%primitive pointer< code-ptr end))
-			 (let ((offset (%primitive pointer- code-ptr base)))
-			   (dolist (sp sps)
-			     (%primitive write-control-stack sp offset))
-			   (push (list* base offset sps) fixups))
-			 (return)))))
-	       code-table)
-
-      (when *gc-debug*
-	(dolist (f fixups)
-	  (terpri)
-	  (print-raw-addr (first f))
-	  (format t "~X " (second f))
-	  (dolist (sp (cddr f))
-	    (print-raw-addr sp)))
-	(terpri))
-
-      fixups)))
-
-
-;;; GC-FIXUP-STACK  --  Internal
-;;;
-;;;    Given a list of GC fixups as returned by GC-GROVEL-STACK, fix up all the
-;;; raw pointers on the stack.
-;;;
-(defun gc-fixup-stack (fixups)
-  (dolist (fixup fixups)
-    (let ((new (%primitive pointer+ (first fixup) (second fixup))))
-      (dolist (sp (cddr fixup))
-	(%primitive write-control-stack sp new)))))
-
-
-;;;; Internal GC
-
-;;; %GC  --  Internal
-;;;
-;;; %GC is the real garbage collector.  What we do:
-;;;  -- Call GC-GROVEL-STACK to locate any raw pointers on the stack.
-;;;  -- Invoke the COLLECT-GARBAGE miscop, adding the amount of garbage
-;;;     collected to *total-bytes-consed*.
-;;;  -- Invalidate & revalidate the old spaces to free up their memory.
-;;;  -- Call GC-FIXUP-STACK to restore raw pointers on the stack.
-;;;
-;;; *** Warning: the stack *including the current frame* is in a somewhat
-;;; altered state until after GC-FIXUP-STACK is called.  Don't change a single
-;;; character from the start of this function until after call to
-;;; GC-FIXUP-STACK unless you really know what you are doing.
-;;;
-;;; It is important that we not do anything that creates raw pointers between
-;;; the time we call GC-GROVEL-STACK and the time we invoke COLLECT-GARBAGE.
-;;; In particular, this means no function calls.  All raw pointers on the stack
-;;; have been trashed, so we cannot use any raw pointers until they have been
-;;; regenerated.  In particular, we cannot return from this function, since the
-;;; return PC is a raw pointer.
-;;;
-;;; We also can't expect the value of any variables allocated between the
-;;; grovel and fixup to persist after the fixup, since the value that variable
-;;; held at grovel time may have been a pointer that needed to be fixed.
-;;;
-(defun %gc ()
-  (let* ((oldspace-base (ash (%primitive newspace-bit) 25))
-	 (old-bytes (system:%primitive dynamic-space-in-use))
-	 (result nil)
-	 (fixups (gc-grovel-stack)))
-    (%primitive clear-registers)
-    (setq result (%primitive collect-garbage))
-    (let ((new-bytes (system:%primitive dynamic-space-in-use)))
-      (when *last-bytes-in-use*
-	(incf *total-bytes-consed* (- old-bytes *last-bytes-in-use*))
-	(setq *last-bytes-in-use* new-bytes)))
-    (gc-fixup-stack fixups)
-    (do* ((i %first-pointer-type (1+ i))
-	  (this-space (logior oldspace-base (ash i 27))
-		      (logior oldspace-base (ash i 27)))
-	  (losing-gr nil))
-	 ((= i (1+ %last-pointer-type))
-	  (when losing-gr
-	    (system:gr-error "While reclaiming VM" losing-gr)))
-      (let ((gr (mach:vm_deallocate *task-self* this-space
-				    (- #x2000000 8192))))
-	(unless (eql gr mach:kern-success) (setq losing-gr gr)))
-      (let ((gr (mach:vm_allocate *task-self* this-space
-				  (- #x2000000 8192) nil)))
-	(unless (eql gr mach:kern-success) (setq losing-gr gr))))
-    result))
-
-;;;
-;;; *INTERNAL-GC*
-;;;
-;;; This variables contains the function that does the real GC.  This is
-;;; for low-level GC experimentation.  Do not touch it if you do not
-;;; know what you are doing.
-;;; 
-(defvar *internal-gc* #'%gc)
-
-
-;;;; SUB-GC
-
-;;;
-;;; CAREFULLY-FUNCALL -- Internal
-;;;
-;;; Used to carefully invoke hooks.
-;;; 
-(defmacro carefully-funcall (function &rest args)
-  `(handler-case (funcall ,function ,@args)
-     (error (cond)
-       (warn "(FUNCALL ~S~{ ~S~}) lost:~%~A" ',function ',args cond)
-       nil)))
-
-;;;
-;;; SUB-GC -- Internal
-;;;
-;;; SUB-GC decides when and if to do a garbage collection.  The
-;;; VERBOSE-P flag controls whether or not the notify functions are
-;;; called.  The FORCE-P flags controls if a GC should occur even if the
-;;; dynamic usage is not greater than *GC-TRIGGER*.
-;;; 
-(defun sub-gc (verbose-p force-p)
-  (unless *already-maybe-gcing*
-    (let* ((*already-maybe-gcing* t)
-	   (pre-gc-dyn-usage (dynamic-usage)))
-      (unless (integerp *bytes-consed-between-gcs*)
-	(warn "The value of *BYTES-CONSED-BETWEEN-GCS*, ~S, is not an ~
-	integer.  Reseting it to 2000000" *bytes-consed-between-gcs*)
-	(setf *bytes-consed-between-gcs* default-bytes-consed-between-gcs))
-      (when (> *bytes-consed-between-gcs* *gc-trigger*)
-	(setf *gc-trigger* *bytes-consed-between-gcs*))
-      (when (> pre-gc-dyn-usage *gc-trigger*)
-	(setf *need-to-collect-garbage* t))
-      (when (or force-p
-		(and *need-to-collect-garbage* (not *gc-inhibit*)))
-	(setf *gc-inhibit* t) ; Set *GC-INHIBIT* to T before calling the hook
-	(when (and (not force-p)
-		   *gc-inhibit-hook*
-		   (carefully-funcall *gc-inhibit-hook* pre-gc-dyn-usage))
-	  (return-from sub-gc nil))
-	(setf *gc-inhibit* nil) ; Reset *GC-INHIBIT*
-	(multiple-value-bind
-	    (winp old-mask)
-	    (mach:unix-sigsetmask lockout-interrupts)
-	  (unwind-protect
-	      (progn
-		(unless winp (warn "Could not set sigmask!"))
-		(let ((*standard-output* *terminal-io*))
-		  (when verbose-p
-		    (carefully-funcall *gc-notify-before* pre-gc-dyn-usage))
-		  (dolist (hook *before-gc-hooks*)
-		    (carefully-funcall hook))
-		  (funcall *internal-gc*)
-		  (let* ((post-gc-dyn-usage (dynamic-usage))
-			 (bytes-freed (- pre-gc-dyn-usage post-gc-dyn-usage)))
-		    (setf *need-to-collect-garbage* nil)
-		    (setf *gc-trigger*
-			  (+ post-gc-dyn-usage *bytes-consed-between-gcs*))
-		    (dolist (hook *after-gc-hooks*)
-		      (carefully-funcall hook))
-		    (when verbose-p
-		      (carefully-funcall *gc-notify-after*
-					 post-gc-dyn-usage bytes-freed
-					 *gc-trigger*)))))
-	    (when winp
-	      (unless (values (mach:unix-sigsetmask old-mask))
-		(warn "Could not restore sigmask!"))))))))
-  nil)
-
-;;;
-;;; MAYBE-GC -- Internal
-;;; 
-;;; This routine is called by the allocation miscops to decide if a GC
-;;; should occur.  The argument, object, is the newly allocated object
-;;; which must be returned to the caller.
-;;; 
-(defun maybe-gc (object)
-  (sub-gc *gc-verbose* nil)
-  object)
-
-;;;
-;;; GC -- Exported
-;;;
-;;; This is the user advertised garbage collection function.
-;;; 
-(defun gc (&optional (verbose-p *gc-verbose*))
-  "Initiates a garbage collection.  The optional argument, VERBOSE-P,
-  which defaults to the value of the variable *GC-VERBOSE* controls
-  whether or not GC statistics are printed."
-  (sub-gc verbose-p t))
-
-
-;;;; Auxiliary Functions.
-
-(defun gc-on ()
-  "Enables the garbage collector."
-  (setq *gc-inhibit* nil)
-  (when *need-to-collect-garbage*
-    (sub-gc *gc-verbose* nil))
-  nil)
-
-(defun gc-off ()
-  "Disables the garbage collector."
-  (setq *gc-inhibit* t)
-  nil)
diff --git a/code/globals.lisp b/code/globals.lisp
deleted file mode 100644
index 696759b8785b66720fe2a79c6e5397a92ba65a19..0000000000000000000000000000000000000000
--- a/code/globals.lisp
+++ /dev/null
@@ -1,56 +0,0 @@
-;;; -*- Package: Lisp; Log: code.log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    This file contains special proclamations for variables that are
-;;; referenced in the code sources before they are defined.  There is also a
-;;; function proclamation to make some common functions be known, avoiding
-;;; large amounts of work in recording the calls that are done before the
-;;; definition.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'lisp)
-
-(proclaim '(special *keyword-package* *lisp-package* *package* *query-io*
-		    *terminal-io* *error-output* *trace-output* *debug-io*
-		    *standard-input* *standard-output* *file-input-handlers*
-		    *hemlock-version* *evalhook* *applyhook*
-		    *task-self* *command-line-switches*
-		    *command-switch-demons* ext::temporary-foreign-files
-		    *display-event-handlers* original-lisp-environment
-		    *environment-list* 
-		    *read-default-float-format* *read-suppress* *readtable*
-		    *print-base* *print-radix* *print-length* *print-level*
-		    *print-pretty* *print-escape* *print-case* *print-circle*
-		    *print-gensym* *print-array*
-		    defmacro-error-string defsetf-error-string
-		    std-lisp-readtable
-		    hi::*in-the-editor* debug::*in-the-debugger*
-		    mach::*free-trap-arg-blocks* conditions::*handler-clusters*
-		    conditions::*restart-clusters*
-		    alloctable-address ext::*c-type-names* *gc-inhibit*
-		    *need-to-collect-garbage*
-		    defmacro-error-string deftype-error-string
-		    defsetf-error-string %sp-interrupts-inhibited
-		    *software-interrupt-vector* *load-verbose*
-		    *load-print-stuff* *in-compilation-unit*
-		    *aborted-compilation-units*
-
-		    ;; hack to get these args to with-trap-arg-block to work in
-		    ;; the bootstrapping env, since the var must be known to be
-		    ;; special, in addition to being known to be an alien var.
-		    mach::timeval mach::timezone mach::int1 mach::int2
-		    mach::int3 mach::tchars mach::ltchars))
-
-
-(proclaim '(ftype (function (&rest t) *)
-		  c::%%defun c::%%defmacro c::%%defconstant c::%defstruct
-		  c::%%compiler-defstruct c::get-info-value c::set-info-value
-		  find-keyword keyword-test assert-error assert-prompt
-		  check-type-error case-body-error))
diff --git a/code/hash.lisp b/code/hash.lisp
deleted file mode 100644
index 7ecea07d1841032cab53f224f9f82d0678921c47..0000000000000000000000000000000000000000
--- a/code/hash.lisp
+++ /dev/null
@@ -1,429 +0,0 @@
-;;; -*- Log: code.log; Package: Lisp -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; Hashing and hash table functions for Spice Lisp.
-;;; Written by Skef Wholey.
-;;;
-(in-package 'lisp)
-(export '(hash-table hash-table-p make-hash-table
-	  gethash remhash maphash clrhash
-	  hash-table-count sxhash))
-
-;;; What a hash-table is:
-
-(defstruct (hash-table (:constructor make-hash-table-structure)
-		       (:conc-name hash-table-)
-		       (:print-function %print-hash-table))
-  "Structure used to implement hash tables."
-  (kind 'eq)
-  (size 65 :type fixnum)
-  (rehash-size 101)				; might be a float
-  (rehash-threshold 57 :type fixnum)
-  (number-entries 0 :type fixnum)
-  (table () :type simple-vector))
-
-;;; A hash-table-table is a vector of association lists.  When an
-;;; entry is made in a hash table, a pair of (key . value) is consed onto
-;;; the element in the vector arrived at by hashing.
-
-;;; How to print one:
-
-(defun %print-hash-table (structure stream depth)
-  (declare (ignore depth))
-  (format stream "#<~A Hash Table {~X}>"
-	  (symbol-name (hash-table-kind structure))
-	  (system:%primitive lisp::make-fixnum structure)))
-
-
-
-;;; Hashing functions for the three kinds of hash tables:
-
-(eval-when (compile)
-
-(defmacro eq-hash (object)
-  "Gives us a hashing of an object such that (eq a b) implies
-   (= (eq-hash a) (eq-hash b))"
-  `(%primitive make-fixnum ,object))
-
-(defmacro eql-hash (object)
-  "Gives us a hashing of an object such that (eql a b) implies
-   (= (eql-hash a) (eql-hash b))"
-  `(if (numberp ,object)
-       (logand (truncate ,object) most-positive-fixnum)
-       (%primitive make-fixnum ,object)))
-
-(defmacro equal-hash (object)
-  "Gives us a hashing of an object such that (equal a b) implies
-   (= (equal-hash a) (equal-hash b))"
-  `(sxhash ,object))
-
-)
-
-;;; Rehashing functions:
-
-(defun almost-primify (num)
-  (declare (fixnum num))
-  "Almost-Primify returns an almost prime number greater than or equal
-   to NUM."
-  (if (= (rem num 2) 0)
-      (setq num (+ 1 num)))
-  (if (= (rem num 3) 0)
-      (setq num (+ 2 num)))
-  (if (= (rem num 7) 0)
-      (setq num (+ 4 num)))
-  num)
-
-(eval-when (compile)
-
-(defmacro grow-size (table)
-  "Returns a fixnum for the next size of a growing hash-table."
-  `(let ((rehash-size (hash-table-rehash-size ,table)))
-     (if (floatp rehash-size)
-	 (ceiling (* rehash-size (hash-table-size ,table)))
-	 (+ rehash-size (hash-table-size ,table)))))
-
-(defmacro grow-rehash-threshold (table new-length)
-  "Returns the next rehash threshold for the table."
-  table
-  `,new-length
-;  `(ceiling (* (hash-table-rehash-threshold ,table)
-;	       (/ ,new-length (hash-table-size ,table))))
-  )
-
-(defmacro hash-set (vector key value length hashing-function)
-  "Used for rehashing.  Enters the value for the key into the vector
-   by hashing.  Never grows the vector.  Assumes the key is not yet
-   entered."
-  `(let ((index (rem (the fixnum (funcall ,hashing-function ,key))
-		     (the fixnum ,length))))
-     (declare (fixnum index))
-     (setf (aref (the simple-vector ,vector) index)
-	   (cons (cons ,key ,value)
-		 (aref (the simple-vector ,vector) index)))))
-
-)
-
-(defun rehash (structure hash-vector new-length)
-  (declare (simple-vector hash-vector))
-  (declare (fixnum new-length))
-  "Rehashes a hash table and replaces the TABLE entry in the structure if
-   someone hasn't done so already.  New vector is of NEW-LENGTH."
-  (do ((new-vector (make-array new-length))
-       (i 0 (1+ i))
-       (size (hash-table-size structure))
-       (hashing-function (case (hash-table-kind structure)
-			   (eq #'(lambda (x) (eq-hash x)))
-			   (eql #'(lambda (x) (eql-hash x)))
-			   (equal #'(lambda (x) (equal-hash x))))))
-      ((= i size)
-       (cond ((eq hash-vector (hash-table-table structure))
-	      (cond ((> new-length size)
-		     (setf (hash-table-table structure) new-vector)
-		     (setf (hash-table-rehash-threshold structure)
-			   (grow-rehash-threshold structure new-length))
-		     (setf (hash-table-size structure) new-length))
-		    (t
-		     (setf (hash-table-table structure) new-vector)))
-	      (if (not (eq (hash-table-kind structure) 'equal))
-		  (%primitive set-vector-subtype new-vector
-			      (+ 2 (%primitive newspace-bit)))))))
-    (declare (fixnum i size))
-    (do ((bucket (aref hash-vector i) (cdr bucket)))
-	((null bucket))
-      (hash-set new-vector (caar bucket) (cdar bucket) new-length
-		hashing-function))
-    (setf (aref hash-vector i) nil)))
-
-;;; Macros for Gethash, %Puthash, and Remhash:
-
-(eval-when (compile)
-
-;;; Hashop dispatches on the kind of hash table we've got, rehashes if
-;;; necessary, and binds Vector to the hash vector, Index to the index
-;;; into that vector that the Key points to, and Size to the size of the
-;;; hash vector.  Since Equal hash tables only need to be maybe rehashed
-;;; sometimes, one can tell it if it's one of those times with the
-;;; Equal-Needs-To-Rehash-P argument.
-
-(defmacro hashop (equal-needs-to-rehash-p eq-body eql-body equal-body)
-  `(let* ((vector (hash-table-table hash-table))
-	  (size (length vector)))
-     (declare (simple-vector vector) (fixnum size)
-	      (inline assoc))
-     (case (hash-table-kind hash-table)
-       (equal
-	,@(if equal-needs-to-rehash-p `((equal-rehash-if-needed)))
-	(let ((index (rem (the fixnum (equal-hash key)) size)))
-	  (declare (fixnum index))
-	  ,equal-body))
-       (eq
-	(without-gcing
-	  (eq-rehash-if-needed)
-	  (let ((index (rem (the fixnum (eq-hash key)) size)))
-	    (declare (fixnum index))
-	    ,eq-body)))
-       (eql
-	(without-gcing
-	  (eq-rehash-if-needed)
-	  (let ((index (rem (the fixnum (eql-hash key)) size)))
-	    (declare (fixnum index))
-	    ,eql-body))))))
-
-(defmacro eq-rehash-if-needed ()
-  `(let ((subtype (%primitive get-vector-subtype vector)))
-     (declare (fixnum subtype))
-     (cond ((or (= subtype 4)
-		(/= subtype (+ 2 (%primitive newspace-bit))))
-	    (rehash hash-table vector size)
-	    (setq vector (hash-table-table hash-table)))
-	   ((> (hash-table-number-entries hash-table)
-	       (hash-table-rehash-threshold hash-table))
-	    (rehash hash-table vector (grow-size hash-table))
-	    (setq vector (hash-table-table hash-table))
-	    (setq size (length vector))))))
-
-(defmacro equal-rehash-if-needed ()
-  `(cond ((> (hash-table-number-entries hash-table)
-	     (hash-table-rehash-threshold hash-table))
-	  (rehash hash-table vector (grow-size hash-table))
-	  (setq vector (hash-table-table hash-table))
-	  (setq size (length vector)))))
-
-(defmacro rehash-if-needed ()
-  `(let ((subtype (%primitive get-vector-subtype vector))
-	 (size (length vector)))
-     (declare (fixnum subtype size))
-     (cond ((and (not (eq (hash-table-kind hash-table) 'equal))
-		 (or (= subtype 4)
-		     (/= subtype (the fixnum (+ 2 (the fixnum (%primitive newspace-bit)))))))
-	    (rehash hash-table vector size)
-	    (setq vector (hash-table-table hash-table))
-	    (setq size (length vector)))
-	   ((> (hash-table-number-entries hash-table)
-	       (hash-table-rehash-threshold hash-table))
-	    (rehash hash-table vector (grow-size hash-table))
-	    (setq vector (hash-table-table hash-table))
-	    (setq size (length vector))))))
-
-)
-
-;;; Making hash tables:
-
-(defun make-hash-table (&key (test 'eql) (size 65) (rehash-size 101)
-			     rehash-threshold)
-  "Creates and returns a hash table.  See manual for details."
-  (declare (fixnum size))
-  (cond ((eq test #'eq) (setq test 'eq))
-	((eq test #'eql) (setq test 'eql))
-	((eq test #'equal) (setq test 'equal)))
-  (if (not (memq test '(eq eql equal)))
-      (error "~S is an illegal :Test for hash tables." test))
-  (setq size (if (<= size 37) 37 (almost-primify size)))
-  (cond ((null rehash-threshold)
-	 (setq rehash-threshold size))
-	((floatp rehash-threshold)
-	 (setq rehash-threshold (ceiling (* rehash-threshold size)))))
-  (make-hash-table-structure :size size
-			     :rehash-size rehash-size
-			     :rehash-threshold rehash-threshold
-			     :table
-			     (if (eq test 'equal)
-				 (make-array size)
-				 (%primitive set-vector-subtype
-				  (make-array size)
-				  (the fixnum (+ 2 (the fixnum (%primitive newspace-bit))))))
-			     :kind test)))
-
-;;; Manipulating hash tables:
-
-(defun gethash (key hash-table &optional default)
-  "Finds the entry in Hash-Table whose key is Key and returns the associated
-   value and T as multiple values, or returns Default and Nil if there is no
-   such entry."
-  (macrolet ((lookup (test)
-	       `(let ((cons (assoc key (aref vector index) :test #',test)))
-		  (declare (list cons))
-		  (if cons
-		      (values (cdr cons) t)
-		      (values default nil)))))
-    (hashop nil
-      (lookup eq)
-      (lookup eql)
-      (lookup equal))))
-
-(defun %puthash (key hash-table value)
-  "Create an entry in HASH-TABLE associating KEY with VALUE; if there already
-   is an entry for KEY, replace it.  Returns VALUE."
-  (macrolet ((store (test)
-	       `(let ((cons (assoc key (aref vector index) :test #',test)))
-		  (declare (list cons))
-		  (cond (cons (setf (cdr cons) value))
-			(t
-			 (push (cons key value) (aref vector index))
-			 (incf (hash-table-number-entries hash-table))
-			 value)))))
-    (hashop t
-      (store eq)
-      (store eql)
-      (store equal))))
-
-(defun remhash (key hash-table)
-  "Remove any entry for KEY in HASH-TABLE.  Returns T if such an entry
-   existed; () otherwise."
-  (hashop nil
-   (let ((bucket (aref vector index)))		; EQ case
-     (cond ((and bucket (eq (caar bucket) key))
-	    (pop (aref vector index))
-	    (decf (hash-table-number-entries hash-table))
-	    t)
-	   (t
-	    (do ((last bucket bucket)
-		 (bucket (cdr bucket) (cdr bucket)))
-		((null bucket) ())
-	      (when (eq (caar bucket) key)
-		(rplacd last (cdr bucket))
-		(decf (hash-table-number-entries hash-table))
-		(return t))))))
-   (let ((bucket (aref vector index)))		; EQL case
-     (cond ((and bucket (eql (caar bucket) key))
-	    (pop (aref vector index))
-	    (decf (hash-table-number-entries hash-table))
-	    t)
-	   (t
-	    (do ((last bucket bucket)
-		 (bucket (cdr bucket) (cdr bucket)))
-		((null bucket) ())
-	      (when (eql (caar bucket) key)
-		(rplacd last (cdr bucket))
-		(decf (hash-table-number-entries hash-table))
-		(return t))))))
-   (let ((bucket (aref vector index)))		; EQUAL case
-     (cond ((and bucket (equal (caar bucket) key))
-	    (pop (aref vector index))
-	    (decf (hash-table-number-entries hash-table))
-	    t)
-	   (t
-	    (do ((last bucket bucket)
-		 (bucket (cdr bucket) (cdr bucket)))
-		((null bucket) ())
-	      (when (equal (caar bucket) key)
-		(rplacd last (cdr bucket))
-		(decf (hash-table-number-entries hash-table))
-		(return t))))))))
-
-(defun maphash (map-function hash-table)
-  "For each entry in HASH-TABLE, calls MAP-FUNCTION on the key and value
-  of the entry; returns T."
-  (let ((vector (hash-table-table hash-table)))
-    (declare (simple-vector vector))
-    (rehash-if-needed)
-    (do ((i 0 (1+ i))
-	 (size (hash-table-size hash-table)))
-	((= i size))
-      (declare (fixnum i size))
-      (do ((bucket (aref vector i) (cdr bucket)))
-	  ((null bucket))
-	
-	(funcall map-function (caar bucket) (cdar bucket))))))
-
-(defun clrhash (hash-table)
-  "Removes all entries of HASH-TABLE and returns the hash table itself."
-  (let ((vector (hash-table-table hash-table)))
-    (declare (simple-vector vector))
-    (setf (hash-table-number-entries hash-table) 0)
-    (do ((i 0 (1+ i))
-	 (size (hash-table-size hash-table)))
-	((= i size) hash-table)
-      (declare (fixnum i size))
-      (setf (aref vector i) nil))))
-
-(defun hash-table-count (hash-table)
-  "Returns the number of entries in the given Hash-Table."
-  (hash-table-number-entries hash-table))
-
-;;; Primitive Hash Function
-
-;;; The maximum length and depth to which we hash lists.
-(defconstant sxhash-max-len 7)
-(defconstant sxhash-max-depth 3)
-
-(eval-when (compile eval)
-
-;;; We could use a rotate function here, but that isn't in ucode, so
-;;; instead we Xor the number with a lsh'ed version of itself...
-;;;
-(defmacro sxmash (x num)
-  (let ((n-x (gensym)))
-    `(let ((,n-x ,x))
-       (declare (fixnum ,n-x))
-       (abs (logxor (the fixnum (%primitive lsh ,n-x ,num)) ,n-x)))))
-
-(defmacro sxhash-simple-string (sequence)
-  `(%primitive sxhash-simple-string ,sequence))
-
-(defmacro sxhash-string (sequence)
-  (let ((data (gensym))
-	(start (gensym))
-	(end (gensym)))
-    `(with-array-data ((,data ,sequence)
-		       (,start)
-		       (,end (%primitive header-ref ,sequence
-					 %array-fill-pointer-slot)))
-       (if (zerop ,start)
-	   (%primitive sxhash-simple-substring ,data ,end)
-	   (sxhash-simple-string (coerce (the string ,sequence)
-					 'simple-string))))))
-
-(defmacro sxhash-list (sequence depth)
-  `(if (= ,depth sxhash-max-depth)
-       0
-       (do ((sequence ,sequence (cdr (the list sequence)))
-	    (index 0 (1+ index))
-	    (hash 2))
-	   ((or (atom sequence) (= index sxhash-max-len)) hash)
-	 (declare (fixnum hash index))
-	 (setq hash
-	       (sxmash
-		(logxor
-		 hash
-		 (internal-sxhash (car sequence) (1+ ,depth)))
-		7)))))
-
-); eval-when (compile eval)
-
-
-;;; This multi-level type dispatch is faster, since typecase doesn't
-;;; turn into a real dispatch.
-;;;
-(defun sxhash (s-expr)
-  "Computes a hash code for S-EXPR and returns it as an integer."
-  (internal-sxhash s-expr 0))
-
-(defun internal-sxhash (s-expr depth)
-  (typecase s-expr
-    (array
-     (typecase s-expr
-       (simple-string (sxhash-simple-string s-expr))
-       (string (sxhash-string s-expr))
-       (t (array-rank s-expr))))
-    (symbol (sxhash-simple-string (symbol-name s-expr)))
-    (list (sxhash-list s-expr depth))
-    (number
-     (etypecase s-expr
-       (integer (ldb (byte 23 0) s-expr))
-       (float (multiple-value-bind (significand exponent)
-				   (integer-decode-float s-expr)
-		(logxor (the fixnum (ldb (byte 23 0) significand))
-			(the fixnum (ldb (byte 23 0) exponent)))))
-       (ratio (the fixnum (+ (internal-sxhash (numerator s-expr) 0)
-			     (internal-sxhash (denominator s-expr) 0))))
-       (complex (the fixnum (+ (internal-sxhash (realpart s-expr) 0)
-			       (internal-sxhash (imagpart s-expr) 0))))))
-    (compiled-function (%primitive header-length s-expr))
-    (t (%primitive make-fixnum s-expr))))
diff --git a/code/internet.lisp b/code/internet.lisp
deleted file mode 100644
index a01e8e1b254bf86ced7a4a1d8d10cfb9571c6993..0000000000000000000000000000000000000000
--- a/code/internet.lisp
+++ /dev/null
@@ -1,424 +0,0 @@
-;;; -*- Log: code.log; Package: extensions -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; This file contains an interface to internet domain sockets.
-;;;
-;;; Written by William Lott.
-;;;
-
-(in-package "EXTENSIONS")
-
-(export '(htonl ntohl htons ntohs lookup-host-entry host-entry host-entry-name
-	  host-entry-aliases host-entry-addr-list host-entry-addr
-	  create-inet-socket connect-to-inet-socket create-inet-listener
-	  accept-tcp-connection close-socket ipproto-tcp ipproto-udp inaddr-any
-	  add-oob-handler remove-oob-handler remove-all-oob-handlers
-	  send-character-out-of-band))
-
-
-(defvar *internet-protocols*
-  (list (list :stream 6 sock-stream)
-	(list :data-gram 17 sock-dgram))
-  "AList of socket kinds and protocol values.")
-
-(defun internet-protocol (kind)
-  (let ((entry (assoc kind *internet-protocols*)))
-    (unless entry
-      (error "Invalid kind (~S) for internet domain sockets." kind))
-    (values (cadr entry)
-	    (caddr entry))))
-
-
-
-(eval-when (compile load eval)
-  #+ :IBM-RT-PC
-  (pushnew :NETWORK-BYTE-ORDER *features*)
-  )
-
-#+ :NETWORK-BYTE-ORDER
-(progn
-  (defmacro htonl (x) x)
-  (defmacro ntohl (x) x)
-  (defmacro htons (x) x)
-  (defmacro ntohs (x) x))
-
-#- :NETWORK-BYTE-ORDER
-(progn
-  (defmacro htonl (x)
-    (let ((val (gensym)))
-      `(let ((,val ,x))
-	 (logior (ash (ldb (byte 8 0)
-			   ,val)
-		      24)
-		 (ash (ldb (byte 8 8)
-			   ,val)
-		      16)
-		 (ash (ldb (byte 8 16)
-			   ,val)
-		      8)
-		 (ldb (byte 8 24)
-		      ,val)))))
-  (defmacro ntohl (x)
-    `(htonl ,x))
-  (defmacro htons (x)
-    (let ((val (gensym)))
-      `(let ((,val ,x))
-	 (logior (ash (ldb (byte 8 0)
-			   ,val)
-		      8)
-		 (ldb (byte 8 8)
-		      ,val)))))
-  (defmacro ntohs (x)
-    `(htons ,x)))
-
-
-
-;;;; Host entry operations.
-
-(defstruct host-entry
-  name
-  aliases
-  addr-type
-  addr-list)
-
-(defun host-entry-addr (host)
-  (car (host-entry-addr-list host)))
-
-
-(def-c-pointer *char (null-terminated-string 256))
-(def-c-type pointer (unsigned-byte 32))
-
-(def-c-record inet-sockaddr
-  (family short)
-  (port unsigned-short)
-  (addr unsigned-long)
-  (zero (unsigned-byte 64)))
-
-(def-c-record hostent
-  (name *char)
-  (aliases pointer)
-  (addrtype int)
-  (length int)
-  (addr_list pointer))
-
-(def-c-routine "gethostbyname" (*hostent)
-  (name *char))
-(def-c-routine "gethostbyaddr" (*hostent)
-  (addr pointer)
-  (len int)
-  (type int))
-
-(defalien *alien-ulong* (unsigned-byte 32) 32)
-(defalien *alien-sockaddr* inet-sockaddr (c-sizeof 'inet-sockaddr))
-
-(defoperator (my-hostent-aliases pointer)
-	     ((hostent hostent))
-  `(alien-index (alien-value ,hostent)
-		(long-words 1)
-		(long-words 1)))
-
-(defoperator (my-hostent-addr_list pointer)
-	     ((hostent hostent))
-  `(alien-index (alien-value ,hostent)
-		(long-words 4)
-		(long-words 1)))
-
-(defoperator (pointer-index pointer)
-	     ((pointer pointer)
-	      index)
-  `(alien-index (alien-value ,pointer)
-		(long-words ,index)
-		(long-words 1)))
-
-(defoperator (pointer-indirect pointer)
-	     ((pointer pointer)
-	      index)
-  `(alien-indirect (alien-index (alien-value ,pointer)
-				0
-				(long-words 1))
-		   (long-words (1+ ,index))))
-
-(defun mumble (array)
-  (alien-bind ((foo array pointer t)
-	       (bar (pointer-indirect (alien-value foo) 0) pointer t)
-	       (baz (pointer-index (alien-value bar) 0) pointer t))
-    (alien-value baz)))
-
-(defoperator (deref-string-ptr (null-terminated-string 512))
-	     ((alien pointer))
-  `(alien-indirect (alien-value ,alien)
-		   (bytes 512)))
-
-(defoperator (deref-ulong-ptr (unsigned-byte 32))
-	     ((alien pointer))
-  `(alien-indirect (alien-value ,alien)
-		   (long-words 1)))
-
-(defmacro listify-c-array (array derefer)
-  (let ((results (gensym))
-	(index (gensym))
-	(p1 (gensym))
-	(p2 (gensym))
-	(p3 (gensym)))
-    `(let ((,results nil)
-	   (,index 0))
-       (loop
-	 (alien-bind
-	     ((,p1 (pointer-indirect ,array ,index) pointer t)
-	      (,p2 (pointer-index (alien-value ,p1) ,index) pointer t)
-	      (,p3 (,derefer (alien-value ,p2))))
-	   (when (zerop (alien-address (alien-value ,p3)))
-	     (return (nreverse ,results)))
-	   (push (alien-access (alien-value ,p3))
-		 ,results))
-	 (incf ,index)))))
-
-(defun lookup-host-entry (host)
-  (if (typep host 'host-entry)
-    host
-    (let ((hostent
-	   (typecase host
-	     (string
-	      (gethostbyname host))
-	     ((unsigned-byte 32)
-	      (setf (system:alien-access *alien-ulong*) host)
-	      (gethostbyaddr (system:alien-sap *alien-ulong*)
-			     4 ; bytes per ulong
-			     af-inet))
-	     (t
-	      (error "Invalid host ~S for ~S -- must be either a string or (unsigned-byte 32)")))))
-      (if (not (null hostent))
-	(alien-bind ((alien hostent hostent t)
-		     (name
-		      (alien-access (hostent-name (alien-value alien))
-				    '(alien (null-terminated-string 256)
-					    2048))
-		      (null-terminated-string 256)
-		      t)
-		     (aliases
-		      (my-hostent-aliases (alien-value alien))
-		      pointer
-		      t)
-		     (addr-list
-		      (my-hostent-addr_list (alien-value alien))
-		      pointer
-		      t))
-	  (make-host-entry
-	   :name (alien-access (alien-value name))
-	   :aliases (listify-c-array (alien-value aliases) deref-string-ptr)
-	   :addr-type (alien-access (hostent-addrtype (alien-value alien)))
-	   :addr-list (listify-c-array (alien-value addr-list)
-				       deref-ulong-ptr)))))))
-
-(defun fill-in-sockaddr (addr port)
-  (setf (alien-access (inet-sockaddr-family (alien-value *alien-sockaddr*)))
-	af-inet)
-  (setf (alien-access (inet-sockaddr-port (alien-value *alien-sockaddr*)))
-	port)
-  (setf (alien-access (inet-sockaddr-addr (alien-value *alien-sockaddr*)))
-	addr)
-  (values))
-
-(defun create-inet-socket (&optional (kind :stream))
-  (multiple-value-bind (proto type)
-		       (internet-protocol kind)
-    (multiple-value-bind (socket err)
-			 (unix-socket af-inet type proto)
-      (when (null socket)
-	(error "Error creating socket: ~A"
-	       (get-unix-error-msg err)))
-      socket)))
-
-(defun connect-to-inet-socket (host port &optional (kind :stream))
-  (let ((socket (create-inet-socket kind))
-	(hostent (lookup-host-entry host)))
-    (fill-in-sockaddr (host-entry-addr hostent) port)
-    (multiple-value-bind (ok err)
-			 (unix-connect socket
-				       *alien-sockaddr*)
-      (unless ok
-	(unix-close socket)
-	(error "Error connecting socket to [~A:~A]: ~A"
-	       (host-entry-name hostent)
-	       port
-	       (get-unix-error-msg err)))
-      socket)))
-
-(defun create-inet-listener (port &optional (kind :stream))
-  (let ((socket (create-inet-socket kind)))
-    (fill-in-sockaddr 0 port)
-    (multiple-value-bind (ok err)
-			 (unix-bind socket
-				    *alien-sockaddr*)
-      (unless ok
-	(unix-close socket)
-	(error "Error binding socket to port ~a: ~a"
-	       port
-	       (get-unix-error-msg err))))
-    (when (eq kind :stream)
-      (multiple-value-bind (ok err)
-			   (unix-listen socket 5)
-	(unless ok
-	  (unix-close socket)
-	  (error "Error listening to socket: ~a"
-		 (get-unix-error-msg err)))))
-    socket))
-
-(defun accept-tcp-connection (unconnected)
-  (declare (fixnum unconnected))
-  (multiple-value-bind (connected err)
-		       (unix-accept unconnected
-				    *alien-sockaddr*)
-    (when (null connected)
-      (error "Error accepting a connection: ~a"
-	     (get-unix-error-msg err)))
-    (values connected
-	    (alien-access (inet-sockaddr-addr *alien-sockaddr*)))))
-
-(defun close-socket (socket)
-  (multiple-value-bind (ok err)
-		       (unix-close socket)
-    (unless ok
-      (error "Error closing socket: ~a"
-	     (get-unix-error-msg err))))
-  (values))
-
-
-
-;;;; Out of Band Data.
-
-
-;;; Two level AList. First levels key is the file descriptor, second levels
-;;; key is the character. The datum is the handler to call.
-
-(defvar *oob-handlers* nil)
-
-;;; SIGURG-HANDLER -- internal
-;;;
-;;;   Routine that gets called whenever out-of-band data shows up. Checks each
-;;; file descriptor for any oob data. If there is any, look for a handler for
-;;; that character. If any are found, funcall them.
-
-(defun sigurg-handler (signo code scp)
-  (declare (ignore signo code scp))
-  (let ((buffer (make-string 1))
-	(handled nil))
-    (declare (simple-string buffer))
-    (dolist (handlers *oob-handlers*)
-      (declare (list handlers))
-      (multiple-value-bind (value err)
-			   (mach:unix-recv (car handlers)
-					   buffer
-					   1
-					   mach:msg-oob)
-	(cond ((null value)
-	       (cerror "Ignore it"
-		       "Error recving oob data on ~A: ~A"
-		       (car handlers)
-		       (mach:get-unix-error-msg err)))
-	      (t
-	       (setf handled t)
-	       (let ((char (schar buffer 0))
-		     (handled nil))
-		 (declare (string-char char))
-		 (dolist (handler (cdr handlers))
-		   (declare (list handler))
-		   (when (eql (car handler) char)
-		     (funcall (cdr handler))
-		     (setf handled t)))
-		 (unless handled
-		   (cerror "Ignore it"
-			   "No oob handler defined for ~S on ~A"
-			   char
-			   (car handlers))))))))
-    (unless handled
-      (cerror "Ignore it"
-	      "Got a SIGURG, but couldn't find any out-of-band data.")))
-  (values))
-
-;;; ADD-OOB-HANDLER -- public
-;;;
-;;;   First, check to see if we already have any handlers for this file
-;;; descriptor. If so, just add this handler to them. If not, add this
-;;; file descriptor to *oob-handlers*, make sure our interupt handler is
-;;; installed, and that the given file descriptor is "owned" by us (so sigurg
-;;; will be delivered.)
-
-(defun add-oob-handler (fd char handler)
-  "Arange to funcall HANDLER when CHAR shows up out-of-band on FD."
-  (declare (integer fd)
-	   (string-char char))
-  (let ((handlers (assoc fd *oob-handlers*)))
-    (declare (list handlers))
-    (cond (handlers
-	   (push (cons char handler)
-		 (cdr handlers)))
-	  (t
-	   (push (list fd
-		       (cons char
-			     handler))
-		 *oob-handlers*)
-	   (system:enable-interrupt mach:sigurg #'sigurg-handler)
-	   (mach:unix-fcntl fd mach::f-setown (mach:unix-getpid)))))
-  (values))
-
-;;; REMOVE-OOB-HANDLER -- public
-;;;
-;;;   Delete any handlers for the given char from the list of handlers for the
-;;; given file descriptor. If there are no more, nuke the entry for the file
-;;; descriptor.
-
-(defun remove-oob-handler (fd char)
-  "Remove any handlers for CHAR on FD."
-  (declare (integer fd)
-	   (string-char char))
-  (let ((handlers (assoc fd *oob-handlers*)))
-    (declare (list handlers))
-    (when handlers
-      (let ((remaining (delete char handlers
-			       :test #'eql
-			       :key #'car)))
-	(declare (list remaining))
-	(if remaining
-	  (setf (cdr handlers) remaining)
-	  (setf *oob-handlers*
-		(delete fd *oob-handlers*
-			:test #'eql
-			:key #'car))))))
-  (values))
-
-;;; REMOVE-ALL-OOB-HANDLERS -- public
-;;;
-;;;   Delete the entry for the given file descriptor.
-
-(defun remove-all-oob-handlers (fd)
-  "Remove all handlers for FD."
-  (declare (integer fd))
-  (setf *oob-handlers*
-	(delete fd *oob-handlers*
-		:test #'eql
-		:key #'car))
-  (values))
-
-;;; SEND-CHARACTER-OUT-OF-BAND -- public
-;;;
-;;;   Sends CHAR across FD out of band.
-
-(defun send-character-out-of-band (fd char)
-  (declare (integer fd)
-	   (string-char char))
-  (let ((buffer (make-string 1 :initial-element char)))
-    (declare (simple-string buffer))
-    (multiple-value-bind (value err)
-			 (mach:unix-send fd buffer 1 mach:msg-oob)
-      (unless value
-	(error "Error sending ~S OOB to across ~A: ~A"
-	       char
-	       fd
-	       (mach:get-unix-error-msg err))))))
diff --git a/code/lispinit.lisp b/code/lispinit.lisp
deleted file mode 100644
index 61e9f78f290ee19109dbe4153b4c1a5eeb557ac0..0000000000000000000000000000000000000000
--- a/code/lispinit.lisp
+++ /dev/null
@@ -1,1066 +0,0 @@
-;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; Initialization and low-level interrupt support for the Spice Lisp system.
-;;; Written by Skef Wholey and Rob MacLachlan.
-;;;
-(in-package "LISP" :use '("SYSTEM" "DEBUG"))
-
-(in-package "XLIB")
-
-(in-package "LISP")
-
-(export '(most-positive-fixnum most-negative-fixnum sleep
-			       ++ +++ ** *** // ///))
-
-
-(in-package "SYSTEM" :nicknames '("SYS"))
-(export '(add-port-death-handler remove-port-death-handler sap-int
-	  int-sap sap-ref-8 sap-ref-16 sap-ref-32 without-gcing
-	  *in-the-compiler* compiler-version *pornography-of-death*
-	  *port-receive-rights-handlers* *port-ownership-rights-handlers*
-	  without-interrupts with-reply-port map-port add-port-object
-	  remove-port-object make-object-set object-set-operation
-	  server-message *xwindow-table* map-xwindow add-xwindow-object
-	  remove-xwindow-object server-event coerce-to-key-event
-	  coerce-to-motion-event coerce-to-expose-event
-	  coerece-to-exposecopy-event coerce-to-focuschange-event server
-	  *nameserverport* *usertypescript* *userwindow* *typescriptport*
-	  *task-self* *task-data* *task-notify* *file-input-handlers*
-	  with-interrupts with-enabled-interrupts enable-interrupt
-	  ignore-interrupt default-interrupt))
-
-(in-package "EXTENSIONS")
-(export '(quit *prompt* print-herald save-lisp gc-on gc-off
-	       *before-save-initializations* *after-save-initializations*
-	       *editor-lisp-p* *clx-server-displays*))
-
-(in-package "LISP")
-
-;;; These go here so that we can refer to them in top-level forms.
-
-(defvar *before-save-initializations* ()
-  "This is a list of functions which are called before creating a saved core
-  image.  These functions are executed in the child process which has no ports,
-  so they cannot do anything that tries to talk to the outside world.")
-
-(defvar *after-save-initializations* ()
-  "This is a list of functions which are called when a saved core image starts
-  up.  The system itself should be initialized at this point, but applications
-  might not be.")
-
-;;; Make the error system enable interrupts.
-
-(defconstant most-positive-fixnum 134217727
-  "The fixnum closest in value to positive infinity.")
-
-(defconstant most-negative-fixnum -134217728
-  "The fixnum closest in value to negative infinity.")
-
-
-;;; Random information:
-
-(defvar compiler-version "???")
-(defvar *lisp-implementation-version* "3.0(?)")
-
-(defvar *in-the-compiler* ()
-  "Bound to T while running code inside the compiler.  Macros may test this to
-  see where they are being expanded.")
-
-(defparameter %fasl-code-format 6)
-
-
-;;;; Global ports:
- 
-(defvar *task-self* 1
-  "Port that refers to the current task.")
-
-(defvar *task-data* 2
-  "Port used to receive data for the current task.")
-
-(defvar *nameserverport* ()
-  "Port to the name server.")
-
-
-;;; GC stuff.
-
-(defvar *gc-inhibit* nil)	; Inhibits GC's.
-
-(defvar *already-maybe-gcing* nil) ; Inhibits recursive GC's.
-
-(defvar *need-to-collect-garbage* nil
-  "*Need-to-collect-garbage* is set to T when GC is disabled, but the system
-  needs to do a GC.  When GC is enabled again, the GC is done then.")
-
-
-;;; Software interrupt stuff.
-
-(defvar *in-server* NIL
-  "*In-server* is set to T when the SIGMSG interrupt has been enabled
-  in Server.")
-
-(defvar server-unique-object (cons 1 2))
-
-(defconstant lockout-interrupts (logior (mach:sigmask :sigint)
-					(mach:sigmask :sigquit)
-					(mach:sigmask :sigfpe)
-					(mach:sigmask :sigsys)
-					(mach:sigmask :sigpipe)
-					(mach:sigmask :sigalrm)
-					(mach:sigmask :sigurg)
-					(mach:sigmask :sigstop)
-					(mach:sigmask :sigtstp)
-					(mach:sigmask :sigcont)
-					(mach:sigmask :sigchld)
-					(mach:sigmask :sigttin)
-					(mach:sigmask :sigttou)
-					(mach:sigmask :sigio)
-					(mach:sigmask :sigxcpu)
-					(mach:sigmask :sigxfsz)
-					(mach:sigmask :sigvtalrm)
-					(mach:sigmask :sigprof)
-					(mach:sigmask :sigwinch)
-					(mach:sigmask :sigmsg)
-					(mach:sigmask :sigemsg)))
-
-(defconstant interrupt-stack-size 4096
-  "Size of stack for Unix interrupts.")
-
-(defvar software-interrupt-stack NIL
-  "Address of the stack used by Mach to send signals to Lisp.")
-
-(defvar %sp-interrupts-inhibited nil
-  "True if emergency message interrupts should be inhibited, false otherwise.")
-
-(defvar *software-interrupt-vector*
-  (make-array mach::maximum-interrupts)
-  "A vector that associates Lisp functions with Unix interrupts.")
-
-(defun enable-interrupt (interrupt function &optional character)
-  "Enable one Unix interrupt and associate a Lisp function with it.
-  Interrupt should be the number of the interrupt to enable.  Function
-  should be a funcallable object that will be called with three
-  arguments: the signal code, a subcode, and the context of the
-  interrupt.  The optional character should be an ascii character or
-  an integer that causes the interrupt from the keyboard.  This argument
-  is only used for SIGINT, SIGQUIT, and SIGTSTP interrupts and is ignored
-  for any others.  Returns the old function associated with the interrupt
-  and the character that generates it if the interrupt is one of SIGINT,
-  SIGQUIT, SIGTSTP and character was specified."
-  (unless (< 0 interrupt mach::maximum-interrupts)
-    (error "Interrupt number ~D is not between 1 and ~D."
-	   mach::maximum-interrupts))
-  (let ((old-fun (svref *software-interrupt-vector* interrupt))
-	(old-char ()))
-    (when (and character
-	       (or (eq interrupt mach:sigint)
-		   (eq interrupt mach:sigquit)
-		   (eq interrupt mach:sigtstp)))
-      (when (characterp character)
-	(setq character (char-code character)))
-      (when (mach:unix-isatty 0)
-	(if (or (eq interrupt mach:sigint)
-		(eq interrupt mach:sigquit))
-	    (mach:with-trap-arg-block mach:tchars tc
-	      (multiple-value-bind
-		  (val err)
-		  (mach:unix-ioctl 0 mach:TIOCGETC
-				   (alien-value-sap mach:tchars))
-		(if (null val)
-		    (error "Failed to get tchars information, unix error ~S."
-			   (mach:get-unix-error-msg err))))
-	      (cond ((eq interrupt mach:sigint)
-		     (setq old-char
-			   (alien-access (mach::tchars-intrc (alien-value tc))))
-		     (setf (alien-access (mach::tchars-intrc (alien-value tc)))
-			   character))
-		    (T
-		     (setq old-char
-			   (alien-access (mach::tchars-quitc (alien-value tc))))
-		     (setf (alien-access (mach::tchars-quitc (alien-value tc)))
-			   character)))
-	      (multiple-value-bind
-		  (val err)
-		  (mach:unix-ioctl 0 mach:tiocsetc
-				   (alien-value-sap mach:tchars))
-		(if (null val)
-		    (error "Failed to set tchars information, unix error ~S."
-			   (mach:get-unix-error-msg err)))))
-	    (mach:with-trap-arg-block mach:ltchars tc
-	      (multiple-value-bind
-		  (val err)
-		  (mach:unix-ioctl 0 mach:TIOCGLTC
-				   (alien-value-sap mach:ltchars))
-		(if (null val)
-		    (error "Failed to get ltchars information, unix error ~S."
-			   (mach:get-unix-error-msg err))))
-	      (setq old-char
-		    (alien-access (mach::ltchars-suspc (alien-value tc))))
-	      (setf (alien-access (mach::ltchars-suspc (alien-value tc)))
-		    character)
-	      (multiple-value-bind
-		  (val err)
-		  (mach:unix-ioctl 0 mach:TIOCSLTC
-				   (alien-value-sap mach:ltchars))
-		(if (null val)
-		    (error "Failed to set ltchars information, unix error ~S."
-			   (mach:get-unix-error-msg err))))))))
-    (setf (svref *software-interrupt-vector* interrupt) function)
-    (if (null function)
-	(mach:unix-sigvec interrupt mach:sig_dfl 0 0)
-	(let ((diha (+ (ash clc::romp-data-base 16)
-		       clc::software-interrupt-offset)))
-	  (mach:unix-sigvec interrupt diha lockout-interrupts 1)))
-    (if old-char
-	(values old-fun old-char)
-	old-fun)))
-
-(defun ignore-interrupt (interrupt)
-  "The Unix interrupt handling mechanism is set up so that interrupt is
-  ignored."
-  (unless (< 0 interrupt mach::maximum-interrupts)
-    (error "Interrupt number ~D is not between 1 and 31."))
-  (let ((old-fun (svref *software-interrupt-vector* interrupt)))
-    (mach:unix-sigvec interrupt mach:sig_ign 0 0)
-    (setf (svref *software-interrupt-vector* interrupt) NIL)
-    old-fun))
-
-(defun default-interrupt (interrupt)
-  "The Unix interrupt handling mechanism is set up to do the default action
-  under mach.  Lisp will not get control of the interrupt."
-  (unless (< 0 interrupt mach::maximum-interrupts)
-    (error "Interrupt number ~D is not between 1 and 31."))
-  (let ((old-fun (svref *software-interrupt-vector* interrupt)))
-    (mach:unix-sigvec interrupt mach:sig_dfl 0 0)
-    (setf (svref *software-interrupt-vector* interrupt) NIL)
-    old-fun))
-
-
-;;; %SP-Software-Interrupt-Handler is called by the miscops when a Unix
-;;; signal arrives.  The three arguments correspond to the information
-;;; passed to a normal Unix signal handler, i.e.:
-;;;	signal -- the Unix signal number.
-;;;	code -- a code for those signals which can be caused by more
-;;;		than one kind of event.  This code specifies the sub-event.
-;;;	scp -- a pointer to the context of the signal.
-
-;;; Because of the way %sp-software-interrupt-handler returns, it doesn't
-;;; unwind the binding stack properly.  The only variable affected by this
-;;; is software-interrupt-stack, so it must be handled specially.
-
-(defun %sp-software-interrupt-handler (signal code scp stack)
-  (declare (optimize (speed 3) (safety 0)))
-  (if (and %sp-interrupts-inhibited
-	   (not (memq signal '(#.mach:sigill #.mach:sigbus #.mach:sigsegv))))
-      (progn
-	(let ((iin %sp-interrupts-inhibited))
-	  (setq %sp-interrupts-inhibited
-		(nconc (if (consp iin) iin)
-		       (list `(,signal ,code ,scp))))
-	  (mach:unix-sigsetmask 0)))
-      (let* ((old-stack software-interrupt-stack)
-	     (new-stack ())
-	     (%sp-interrupts-inhibited T))
-	(unwind-protect
-	    (progn
-	      (when *in-server*
-		(mach:unix-sigvec mach:sigmsg mach::sig_dfl 0 0))
-	      (multiple-value-bind (gr addr)
-				   (mach:vm_allocate *task-self* 0
-						     interrupt-stack-size t)
-		(gr-error 'mach:vm_allocate gr '%sp-software-interrupt-handler)
-		(setq software-interrupt-stack
-		      (int-sap (+ addr interrupt-stack-size))))
-	      (setq new-stack software-interrupt-stack)
-	      (mach:unix-sigstack new-stack 0)
-	      (mach:unix-sigsetmask 0)
-	      (funcall (svref *software-interrupt-vector* signal)
-		       signal code scp)
-	      (mach:unix-sigsetmask lockout-interrupts))
-	  (mach:vm_deallocate *task-self*
-			      (- (sap-int new-stack)
-				 interrupt-stack-size)
-			      interrupt-stack-size)
-	  (setq software-interrupt-stack old-stack)
-	  (mach:unix-sigstack old-stack 0)
-	  (when *in-server*
-	    (let ((diha (+ (ash clc::romp-data-base 16)
-			   clc::software-interrupt-offset)))
-	      (mach:unix-sigvec mach:sigmsg diha lockout-interrupts 1)))
-	  (mach:unix-sigsetmask 0))))
-  (%primitive break-return stack))
-
-
-(defun ih-sigint (signal code scp)
-  (declare (ignore signal code scp))
-  (without-hemlock
-   (with-interrupts
-    (break "Software Interrupt" t))))
-
-(defun ih-sigquit (signal code scp)
-  (declare (ignore signal code scp))
-  (throw 'top-level-catcher nil))
-
-(defun ih-sigtstp (signal code scp)
-  (declare (ignore signal code scp))
-  (without-hemlock
-;   (reset-keyboard 0)
-   (mach:unix-kill (mach:unix-getpid) mach:sigstop)))
-
-(defun ih-sigill (signal code scp)
-  (declare (ignore signal code))
-  (alien-bind ((context (make-alien-value scp 0 (record-size 'mach:sigcontext)
-					  'mach:sigcontext)
-			mach:sigcontext T))
-    (error "Illegal instruction encountered at IAR ~X."
-	   (alien-access (mach::sigcontext-iar (alien-value context))))))
-
-(defun ih-sigbus (signal code scp)
-  (declare (ignore signal code))
-  (alien-bind ((context (make-alien-value scp 0 (record-size 'mach:sigcontext)
-					  'mach:sigcontext)
-			mach:sigcontext T))
-    (with-interrupts
-     (error "Bus error encountered at IAR ~X."
-	    (alien-access (mach::sigcontext-iar (alien-value context)))))))
-
-(defun ih-sigsegv (signal code scp)
-  (declare (ignore signal code))
-  (alien-bind ((context (make-alien-value scp 0 (record-size 'mach:sigcontext)
-					  'mach:sigcontext)
-			mach:sigcontext T))
-    (with-interrupts
-     (error "Segment violation encountered at IAR ~X."
-	    (alien-access (mach::sigcontext-iar (alien-value context)))))))
-
-(defun ih-sigfpe (signal code scp)
-  (declare (ignore signal code))
-  (alien-bind ((context (make-alien-value scp 0 (record-size 'mach:sigcontext)
-					  'mach:sigcontext)
-			mach:sigcontext T))
-    (with-interrupts
-     (error "Floating point exception encountered at IAR ~X."
-	    (alien-access (mach::sigcontext-iar (alien-value context)))))))
-
-;;; When we're in server then throw back to server.  If we're not
-;;; in server then just ignore the sigmsg interrupt.  We can't handle
-;;; it and we should never get it anyway.  But of course we do -- it's
-;;; dealing with interrupts and there funny at best.
-(defun ih-sigmsg (signal code scp)
-  (declare (ignore signal code scp))
-  (mach:unix-sigsetmask (mach:sigmask :sigmsg))
-  (default-interrupt mach:sigmsg)
-  (when *in-server*
-    (setq *in-server* nil)
-    (throw 'server-catch server-unique-object)))
-
-(defun ih-sigemsg (signal code scp)
-  (declare (ignore signal code scp))
-  (service-emergency-message-interrupt))
-
-(defun init-mach-signals ()
-  (declare (optimize (speed 3) (safety 0)))
-  (multiple-value-bind (gr addr)
-		       (mach:vm_allocate *task-self* 0 interrupt-stack-size t)
-    (gr-error 'mach:vm_allocate gr 'enable-interrupt)
-    (setq software-interrupt-stack
-	  (int-sap (+ addr interrupt-stack-size))))
-  (let ((iha (get 'clc::interrupt-handler '%loaded-address))
-	(diha (+ (ash clc::romp-data-base 16) clc::software-interrupt-offset)))
-    (%primitive pointer-system-set diha 0 iha))
-  (mach:unix-sigstack software-interrupt-stack 0)
-  (enable-interrupt mach:sigint #'ih-sigint)
-  (enable-interrupt mach:sigquit #'ih-sigquit)
-  (enable-interrupt mach:sigtstp #'ih-sigtstp)
-  (enable-interrupt mach:sigill #'ih-sigill)
-  (enable-interrupt mach:sigbus #'ih-sigbus)
-  (enable-interrupt mach:sigsegv #'ih-sigsegv)
-  (enable-interrupt mach:sigemsg #'ih-sigemsg)
-  (enable-interrupt mach:sigfpe #'ih-sigfpe)
-;  (reset-keyboard 0)
-  )
-
-
-;;;; Reply port allocation.
-;;;
-;;;    We maintain a global stack of reply ports which is shared among
-;;; all matchmaker interfaces, and could be used by other people as well.
-;;;
-;;;    The stack is represented by a vector, and a pointer to the first
-;;; free port.  The stack grows upward.  There is always at least one
-;;; NIL entry in the stack after the last allocated port.
-;;;
-(defvar *reply-port-stack* (make-array 16)) ; Vector of reply ports.
-(defvar *reply-port-pointer* 0)	; Index of first free port.
-(defvar *reply-port-depth* 0)	; Dynamic depth in With-Reply-Port forms.
-
-;;; We use this as the reply port when allocating or deallocating reply
-;;; ports to get around potentially nasty interactions.  Interrupts
-;;; are always off when we are doing this, so we don't have to have
-;;; more than one of these, or worry about unwinding.
-(defvar *allocate-reply-port* (mach:mach-task_data))
-
-;;; Reset-Reply-Port-Stack  --  Internal
-;;;
-;;;    This is a before-save initialization which Nil's out the reply
-;;; port stack and sets *allocate-reply-port* back to DataPort so that
-;;; things initialize right at OS-Init time.
-;;;
-(defun reset-reply-port-stack ()
-  (setq *reply-port-pointer* 0  *reply-port-depth* 0)
-  (fill (the simple-vector *reply-port-stack*) nil)
-  (setq *allocate-reply-port* (mach:mach-task_data)))
-(pushnew 'reset-reply-port-stack *before-save-initializations*)
-
-;;; Allocate-New-Reply-Ports  --  Internal
-;;;
-;;;    If we run out of reply ports, we allocate another one, possibly
-;;; growing the stack.
-;;;
-(defun allocate-new-reply-ports ()
-  (let* ((stack *reply-port-stack*)
-	 (pointer *reply-port-pointer*)
-	 (len (length stack)))
-    (declare (simple-vector stack) (fixnum len))
-    (when (eql pointer (1- len))
-      (let ((new (make-array (* len 2))))
-	(replace new stack :end1 len :end2 len)
-	(setq stack new  *reply-port-stack* new)))
-    (setf (svref stack pointer) *allocate-reply-port*)
-    (let ((port (gr-call* mach:port_allocate (mach:mach-task_self))))
-      (gr-call mach:port_disable (mach:mach-task_self) port)
-      ;;
-      ;; Nil out the allocate reply port so it isn't used for mundane purposes.
-      (setf (svref stack pointer) nil)
-      (setf (svref stack (1- pointer)) port)
-      port)))
-
-;;; Reallocate-Reply-Ports  --  Internal
-;;;
-;;;    This function is called when With-Reply-Port finds the stack pointer
-;;; to be other than what it expected when it finishes.  Reallocates all
-;;; of the ports on the stack from Start to *reply-port-pointer*.  We
-;;; stick the *allocate-reply-port* out at *reply-port-pointer*, and
-;;; bind *reply-port-depth*, so that the allocation functions are happy.
-;;;
-(defun reallocate-reply-ports (start)
-  (let* ((pointer *reply-port-pointer*)
-	 (*reply-port-depth* pointer)
-	 (stack *reply-port-stack*)
-	 (save-port (svref stack pointer)))
-    (when (> start pointer)
-      (error "More ports in use than allocated???"))
-    (setf (svref stack pointer) *allocate-reply-port*)
-    (do ((i start (1+ i)))
-	((= i pointer)
-	 (setf (svref stack pointer) save-port))
-      (let ((port (svref stack i)))
-	(gr-call mach:port_deallocate *task-self* port)
-	(setf (svref stack i)
-	      (gr-call* mach:port_allocate *task-self*))))))
-
-
-;;;; Server stuff:
-;;;
-;;;    There is a fair amount of stuff to support Matchmaker RPC servers
-;;; and asynchonous message service.  RPC message service needs to be
-;;; centralized since a server must receive on all ports, and there is
-;;; no way for a particular server to know about all other servers
-;;; in the same lisp.
-;;;
-;;;    The idea is that you receive the message, and then dispatch off
-;;; of the port received on and the message ID received.  Ports correspond
-;;; to objects that the server manages.  Message ID's correspond to the
-;;; operations on the objects.  Objects are grouped into object sets, which
-;;; are sets of objects having the same operations defined.
-;;; 
-;;;    The same mechanism is used for handling asynchronous messages.
-;;;
-
-;;;    The current implementation uses standard eq[l] hashtables for both
-;;; levels of dispatching.  Special purpose data structures would be more
-;;; efficient, but the ~1ms overhead will probably be lost in the noise.
-
-;;;
-;;;    Hashtable from ports to objects.  Each entry is a cons (object . set).
-;;;
-(defvar *port-table* (make-hash-table :test #'eql))
-
-;;; Hashtable from windows to objects.  Each entry is a cons (object . set).
-;;;
-(defvar *xwindow-table* (make-hash-table :test #'eql))
-
-
-(defstruct (object-set
-	    (:constructor make-object-set
-			  (name &optional
-				(default-handler #'default-default-handler)))
-	    (:print-function
-	     (lambda (s stream d)
-	       (declare (ignore d))
-	       (format stream "#<Object Set ~S>" (object-set-name s)))))
-  name					; Name, for descriptive purposes.
-  (table (make-hash-table :test #'eq))  ; Message-ID or xevent-type --> handler fun.
-  default-handler)
-
-(setf (documentation 'make-object-set 'function)
-      "Make an object set for use by a RPC/xevent server.  Name is for
-      descriptive purposes only.")
-
-
-;;; MAP-XWINDOW and MAP-PORT return as multiple values the object and
-;;; object set mapped to by a xwindow or port in *xwindow-table* or
-;;; *port-table*.
-;;; 
-(macrolet ((defmapper (name table)
-	      `(defun ,(intern (concatenate 'simple-string
-					    "MAP-" (symbol-name name)))
-		      (,name)
-		 ,(format nil "Return as multiple values the object and ~
-		               object-set mapped to by ~A."
-			  (string-downcase (symbol-name name)))
-		 (let ((temp (gethash ,name ,table)))
-		   (if temp
-		       (values (car temp) (cdr temp))
-		       (values nil nil))))))
-  (defmapper port *port-table*)
-  (defmapper xwindow *xwindow-table*))
-
-
-;;; ADD-PORT-OBJECT and ADD-XWINDOW-OBJECT store an object/object-set pair
-;;; mapped to by a port or xwindow in either *port-table* or *xwindow-table*.
-;;; 
-(macrolet ((def-add-object (name table)
-	      `(defun ,(intern (concatenate 'simple-string
-					    "ADD-" (symbol-name name)
-					    "-OBJECT"))
-		      (,name object object-set)
-		 ,(format nil "Add a new ~A/object/object-set association."
-			  (string-downcase (symbol-name name)))
-		 (check-type object-set object-set)
-		 (setf (gethash ,name ,table) (cons object object-set))
-		 object)))
-  (def-add-object port *port-table*)
-  (def-add-object xwindow *xwindow-table*))
-
-
-;;; REMOVE-PORT-OBJECT and REMOVE-XWINDOW-OBJECT remove a port or xwindow and
-;;; its associated object/object-set pair from *port-table* or *xwindow-table*.
-;;; 
-(macrolet ((def-remove-object (name table)
-	      `(defun ,(intern (concatenate 'simple-string
-					    "REMOVE-" (symbol-name name)
-					    "-OBJECT"))
-		      (,name)
-		 ,(format nil
-			  "Remove ~A and its associated object/object-set pair."
-			  (string-downcase (symbol-name name)))
-		 (remhash ,name ,table))))
-  (def-remove-object port *port-table*)
-  (def-remove-object xwindow *xwindow-table*))
-
-
-;;; Object-Set-Operation  --  Public
-;;;
-;;;    Look up the handler function for a given message ID.
-;;;
-(defun object-set-operation (object-set message-id)
-  "Return the handler function in Object-Set for the operation specified by
-  Message-ID, if none, NIL is returned.  The handler function is passed
-  the object.  The received message is in server-Message."
-  (check-type object-set object-set)
-  (check-type message-id fixnum)
-  (values (gethash message-id (object-set-table object-set))))
-
-;;; %Set-Object-Set-Operation  --  Internal
-;;;
-;;;    The setf inverse for Object-Set-Operation.
-;;;
-(defun %set-object-set-operation (object-set message-id new-value)
-  (check-type object-set object-set)
-  (check-type message-id fixnum)
-  (setf (gethash message-id (object-set-table object-set)) new-value))
-;;;
-(defsetf object-set-operation %set-object-set-operation
-  "Sets the handler function for an object set operation.")
-
-;;;; Emergency Message Handling:
-;;;
-;;; We use the same mechanism for asynchronous messages as is used for
-;;; normal server messages.   The only tricky part is that we don't want
-;;; some random server function being called when we really want to
-;;; receive an emergency message, so we can't receive on all ports.
-;;; Instead, we use MessagesWaiting to find the ports with emergency
-;;; messages.
-
-(defalien waiting-ports nil (long-words 128))
-
-;;; Service-Emergency-Message-Interrupt  --  Internal
-;;;
-;;;    This is a lot like the server function, but we only receive on
-;;; ports with one emergency message.  We only receive one message because
-;;; the handler function might have caused any other messages to be received.
-;;; When we re-enable interrupts, if any emergency messages are left, we
-;;; should be interrupted again.
-;;;
-(defun service-emergency-message-interrupt ()
-  (grab-message-loop))
-
-;;;
-;;; This object set is used for DataPort, which is the port various magical
-;;; message from the kernel are received on...
-(defvar *kernel-messages* (make-object-set "Kernel Messages"))
-
-(compiler-let ((*alien-eval-when* '(compile eval)))
-(defrecord port-death-msg
-  (msg mach:msg #.(record-size 'mach:msg))
-  (ex-port-tt pad (long-words 1))
-  (ex-port (signed-byte 32) (long-words 1)))
-
-(defoperator (server-message-port-death-msg port-death-msg)
-	     ((msg server-message))
-  `(alien-index (alien-value ,msg) 0 (record-size 'port-death-msg)))
-); Compiler-Let
-
-
-;;; *Port-Death-Handlers* is an EQ hash table of lists of functions that are
-;;; called upon port death.  If a port dies that is not in the table, we print
-;;; out a message on *Trace-Output* describing its death.  If
-;;; *Pornography-Of-Death* is true, we don't even print that message.
-
-(defvar *port-death-handlers* (make-hash-table :test #'eql)
-  "Don't use this --- use Add-Port-Death-Handler instead.")
-
-;;; Add-Port-Death-Handler, Remove-Port-Death-Handler  --  Public
-;;;
-(defun add-port-death-handler (port function)
-  "Make Function a handler for port death on Port.  When the port dies,
-  Function is called with the port and an argument.  See also
-  Remove-Port-Death-Handler."
-  (pushnew function (gethash port *port-death-handlers*))
-  nil)
-;;;
-(defun remove-port-death-handler (port function)
-  "Undoes the effect of Add-Port-Death-Handler."
-  (setf (gethash port *port-death-handlers*)
-	(delete function (gethash port *port-death-handlers*)))
-  nil)
-
-(setf (object-set-operation *kernel-messages* mach:notify-port-deleted)
-      #'(lambda (obj)
-	  (declare (ignore obj))
-	  (let* ((ex-port (alien-access
-			   (port-death-msg-ex-port
-			    (server-message-port-death-msg server-message))))
-		 (handlers (gethash ex-port *port-death-handlers*)))
-	    (remhash ex-port *port-table*)
-	    (remhash ex-port *port-death-handlers*)
-	    (if (null handlers)
-		(handle-unclaimed-port-death ex-port)
-		(dolist (fun handlers) (funcall fun ex-port))))
-	  mach:kern-success))
-
-(defvar *pornography-of-death* t
-  "If true, nothing is said about port deaths.")
-
-(defun handle-unclaimed-port-death (port)
-  (unless *pornography-of-death*
-    (format *trace-output* "~&[Port ~S just bit the dust.]~%" port)))
-
-;;; Port receive and ownership rights messages are handled simlarly, but
-;;; by default we deallocate the port to make sure it's really dead.  This
-;;; gets around problems with ports being exhausted because some servers
-;;; don't really nuke the port when the deallocate the object.
-;;;
-
-(defvar *port-receive-rights-handlers* (make-hash-table :test #'eql)
-  "This is a hashtable from ports to functions.  The function is called with
-  the port as its argument when a port receive rights message for that port
-  is received from the kernel.")
-
-(defvar *port-ownership-rights-handlers* (make-hash-table :test #'eql)
-  "This is a hashtable from ports to functions.  The function is called with
-  the port as its argument when a port ownership rights message for that port
-  is received from the kernel.")
-
-(setf (object-set-operation *kernel-messages* mach:notify-receive-rights)
-      #'(lambda (obj)
-	  (declare (ignore obj))
-	  (let ((ex-port (alien-access
-			  (port-death-msg-ex-port
-			   (server-message-port-death-msg server-message)))))
-	    (funcall (gethash ex-port *port-receive-rights-handlers*
-			      #'handle-unclaimed-port-rights)
-		     ex-port))
-	  mach:kern-success))
-
-(setf (object-set-operation *kernel-messages* mach:notify-ownership-rights)
-      #'(lambda (obj)
-	  (declare (ignore obj))
-	  (let ((ex-port (alien-access
-			  (port-death-msg-ex-port
-			   (server-message-port-death-msg server-message)))))
-	    (funcall (gethash ex-port *port-ownership-rights-handlers*
-			      #'handle-unclaimed-port-rights)
-		     ex-port))
-	  mach:kern-success))
-
-(defun handle-unclaimed-port-rights (port)
-  (unless *pornography-of-death*
-    (format *trace-output* "~&[Rights received for port ~D, deallocating it.]~%"
-	    port))
-  (mach:port_deallocate *task-self* port)
-  (remhash port *port-receive-rights-handlers*)
-  (remhash port *port-ownership-rights-handlers*)
-  (remhash port *port-table*))
-
-(add-port-object *task-data* nil *kernel-messages*)
-
-;;; Clear-Port-Tables  --  Internal
-;;;
-;;;    A before-save initialization which clears all of the port hashtables.
-;;;
-(defun clear-port-tables ()
-  (clrhash *port-table*)
-  (clrhash *port-death-handlers*)
-  (clrhash *port-receive-rights-handlers*)
-  (clrhash *port-ownership-rights-handlers*))
-
-(pushnew 'clear-port-tables *before-save-initializations*)
-
-
-;;; %Initial-Function is called when a cold system starts up.  First we zoom
-;;; down the *Lisp-Initialization-Functions* doing things that wanted to happen
-;;; at "load time."  Then we initialize the various subsystems and call the
-;;; read-eval-print loop.  The top-level Read-Eval-Print loop is executed until
-;;; someone (most likely the Quit function) throws to the tag
-;;; %End-Of-The-World.  We quit this way so that all outstanding cleanup forms
-;;; in Unwind-Protects will get executed.
-
-(proclaim '(special *lisp-initialization-functions*))
-
-(eval-when (compile)
-  (defmacro print-and-call (name)
-    `(progn
-       (%primitive print ',name)
-       (,name))))
-
-(defun %initial-function ()
-  "Gives the world a shove and hopes it spins."
-  (setq *already-maybe-gcing* t)
-  (setf *gc-inhibit* t)
-  (setf *need-to-collect-garbage* nil)
-  (%primitive print "In initial-function, and running.")
-
-  ;; Many top-level forms call INFO, (SETF INFO).
-  (print-and-call c::globaldb-init)
-
-  ;; Some of the random top-level forms call Make-Array, which calls Subtypep...
-  (print-and-call subtypep-init)
-
-  (setq *lisp-initialization-functions*
-	(nreverse *lisp-initialization-functions*))
-  (%primitive print "Calling top-level forms.")
-  (dolist (fun *lisp-initialization-functions*)
-    (funcall fun))
-  (makunbound '*lisp-initialization-functions*)	; So it gets GC'ed.
-
-  (print-and-call os-init)
-  (print-and-call filesys-init)
-  (print-and-call conditions::error-init)
-
-  (print-and-call reader-init)
-  (print-and-call backq-init)
-  (print-and-call sharp-init)
-  ;; After the various reader subsystems have done their thing to the standard
-  ;; readtable, copy it to *readtable*.
-  (setq *readtable* (copy-readtable std-lisp-readtable))
-
-  (print-and-call stream-init)
-  (print-and-call random-init)
-  (print-and-call format-init)
-  (print-and-call package-init)
-  (print-and-call pprint-init)
-
-  (setq *already-maybe-gcing* nil)
-  (terpri)
-  (princ "CMU Common Lisp kernel core image ")
-  (princ (lisp-implementation-version))
-  (princ ".")
-  (terpri)
-  (princ "[You are in the LISP package.]")
-  (terpri)
-  (catch '%end-of-the-world
-    (loop
-     (%top-level)
-     (write-line "You're certainly a clever child.")))
-  (mach:unix-exit 0))
-
-
-;;;; Initialization functions:
-
-;;; Reinit is called to reinitialize the world when a saved core image
-;;; is resumed.
-(defvar *task-notify* NIL)
-
-(defun reinit ()
-  (without-interrupts
-   (setq *already-maybe-gcing* t)
-   (os-init)
-   (stream-reinit)
-   (setq *already-maybe-gcing* nil))
-  (setq *task-notify* (mach:mach-task_notify))
-  (mach:port_enable (mach:mach-task_self) *task-notify*)
-  (add-port-object *task-notify* nil *kernel-messages*)
-  (init-mach-signals))
-
-
-;;; OS-Init initializes our operating-system interface.  It sets the values
-;;; of the global port variables to what they should be and calls the functions
-;;; that set up the argument blocks for the server interfaces.
-
-(defun os-init ()
-  (setq *task-self* (mach:mach-task_self))
-  (setq *task-data* (mach:mach-task_data)))
-
-
-;;; Setup-path-search-list returns a list of the directories that are
-;;; in the unix path environment variable.  This is so that run-program
-;;; can be smarter about where to find a program to run.
-(defun setup-path-search-list ()
-  (let ((path (cdr (assoc :path ext::*environment-list*))))
-    (when path
-      (do* ((i 0 (1+ p))
-	    (p (position #\: path :start i)
-	       (position #\: path :start i))
-	    (pl ()))
-	   ((null p)
-	    (let ((s (subseq path i)))
-	      (if (string= s "")
-		  (push "default:" pl)
-		  (push (concatenate 'simple-string s "/") pl)))
-	    (nreverse pl))
-	(let ((s (subseq path i p)))
-	  (if (string= s "")
-	      (push "default:" pl)
-	      (push (concatenate 'simple-string s "/") pl)))))))
-
-
-;;;; Miscellaneous external functions:
-
-(defun print-herald ()
-  (write-string "CMU Common Lisp ")
-  (write-line (lisp-implementation-version))
-  (write-string "Hemlock ") (write-string *hemlock-version*)
-  (write-string ", Compiler ") (write-line compiler-version)
-  (write-line "Send bug reports and questions to Gripe.")
-  (values))
-
-(defvar *editor-lisp-p* nil
-  "This is true if and only if the lisp was started with the -edit switch.")
-
-(defun save-lisp (core-file-name &key
-				 (purify t)
-				 (root-structures ())
-				 (init-function
-				  #'(lambda ()
-				      (throw 'top-level-catcher nil)))
-				 (load-init-file t)
-				 (print-herald t)
-				 (process-command-line t))
-  "Saves a Spice Lisp core image in the file of the specified name.  The
-  following keywords are defined:
-  
-  :purify
-      If true, do a purifying GC which moves all dynamically allocated
-  objects into static space so that they stay pure.  This takes somewhat
-  longer than the normal GC which is otherwise done, but GC's will done
-  less often and take less time in the resulting core file.
-
-  :root-structures
-      This should be a list of the main entry points in any newly loaded
-  systems.  This need not be supplied, but locality will be better if it
-  is.  This is meaningless if :purify is Nil.
-  
-  :init-function
-      This is a function which is called when the created core file is
-  resumed.  The default function simply aborts to the top level
-  read-eval-print loop.  If the function returns it will be the value
-  of Save-Lisp.
-  
-  :load-init-file
-      If true, then look for an init.lisp or init.fasl file when the core
-  file is resumed.
-  
-  :print-herald
-      If true, print out the lisp system herald when starting."
-  
-  (if purify
-      (purify :root-structures root-structures)
-      (gc))
-  (unless (save core-file-name)
-    (setf (search-list "default:") (list (default-directory)))
-    (setf (search-list "path:") (setup-path-search-list))
-    (when process-command-line (ext::process-command-strings))
-    (setf *editor-lisp-p* nil)
-    (macrolet ((find-switch (name)
-		 `(find ,name *command-line-switches*
-			:key #'cmd-switch-name
-			:test #'(lambda (x y)
-				  (declare (simple-string x y))
-				  (string-equal x y)))))
-      (when (and process-command-line (find-switch "edit"))
-	(setf *editor-lisp-p* t))
-      (when (and load-init-file
-		 (not (and process-command-line (find-switch "noinit"))))
-	(let* ((cl-switch (find-switch "init"))
-	       (name (or (and cl-switch
-			      (or (cmd-switch-value cl-switch)
-				  (car (cmd-switch-words cl-switch))
-				  "init"))
-			 "init")))
-	  (load (merge-pathnames name (user-homedir-pathname))
-		:if-does-not-exist nil))))
-    (when print-herald
-      (print-herald))
-    (when process-command-line
-      (ext::invoke-switch-demons *command-line-switches*
-				 *command-switch-demons*))
-    (funcall init-function)))
-
-
-;;; Quit gets us out, one way or another.
-
-(defun quit (&optional recklessly-p)
-  "Terminates the current Lisp.  Things are cleaned up unless Recklessly-P is
-  non-Nil."
-;  (reset-keyboard 0)
-  (dolist (x (if (boundp 'extensions::temporary-foreign-files)
-		 extensions::temporary-foreign-files))
-    (mach:unix-unlink x))
-  (if recklessly-p
-      (mach:unix-exit 0)
-      (throw '%end-of-the-world nil)))
-
-
-
-(defalien sleep-msg mach:msg (record-size 'mach:msg))
-(setf (alien-access (mach:msg-simplemsg sleep-msg)) T)
-(setf (alien-access (mach:msg-msgtype sleep-msg)) 0)
-(setf (alien-access (mach:msg-msgsize sleep-msg))
-      (/ (record-size 'mach:msg) 8))
-
-;;; Currently there is a bug in the Mach timeout code that if the timeout
-;;; period is too short the receive never returns.
-
-(defun sleep (n)
-  "This function causes execution to be suspended for N seconds.  N may
-  be any non-negative, non-complex number."
-  (with-reply-port (sleep-port)
-    (let ((m (round (* 1000 n))))
-      (cond ((minusp m)
-	     (error "Argument to Sleep, ~S, is a negative number." n))
-	    ((zerop m))
-	    (t
-	     (setf (alien-access (mach:msg-localport sleep-msg)) sleep-port)
-	     (let ((gr (mach:msg-receive sleep-msg mach:rcv-timeout m)))
-	       (unless (eql gr mach:rcv-timed-out)
-		 (gr-error 'mach:receive gr)))))))
-  nil)
-
-
-;;;; TOP-LEVEL loop.
-
-(defvar / nil
-  "Holds a list of all the values returned by the most recent top-level EVAL.")
-(defvar // nil "Gets the previous value of / when a new value is computed.")
-(defvar /// nil "Gets the previous value of // when a new value is computed.")
-(defvar * nil "Holds the value of the most recent top-level EVAL.")
-(defvar ** nil "Gets the previous value of * when a new value is computed.")
-(defvar *** nil "Gets the previous value of ** when a new value is computed.")
-(defvar + nil "Holds the value of the most recent top-level READ.")
-(defvar ++ nil "Gets the previous value of + when a new value is read.")
-(defvar +++ nil "Gets the previous value of ++ when a new value is read.")
-(defvar - nil "Holds the form curently being evaluated.")
-(defvar *prompt* "* "
-  "The top-level prompt string.  This also may be a function of no arguments
-   that returns a simple-string.")
-(defvar *in-top-level-catcher* nil
-  "True if we are within the Top-Level-Catcher.  This is used by interrupt
-  handlers to see whether it is o.k. to throw.")
-
-(defun interactive-eval (form)
-  "Evaluate FORM, returning whatever it returns but adjust ***, **, *, +++, ++,
-  +, ///, //, /, and -."
-  (setf +++ ++
-	++ +
-	+ -
-	- form)
-  (let ((results (multiple-value-list (eval form))))
-    (setf /// //
-	  // /
-	  / results
-	  *** **
-	  ** *
-	  * (car results)))
-  (unless (boundp '*)
-    ;; The bogon returned an unbound marker.
-    (setf * nil)
-    (cerror "Go on with * set to NIL."
-	    "EVAL returned an unbound marker."))
-  (values-list /))
-
-(defconstant eofs-before-quit 10)
-
-(defun %top-level ()
-  "Top-level READ-EVAL-PRINT loop.  Do not call this."
-  (let  ((* nil) (** nil) (*** nil)
-	 (- nil) (+ nil) (++ nil) (+++ nil)
-	 (/// nil) (// nil) (/ nil)
-	 (magic-eof-cookie (cons :eof nil))
-	 (number-of-eofs 0))
-    (loop
-     (with-simple-restart (abort "Return to Top-Level.")
-       (catch 'top-level-catcher
-	 (let ((*in-top-level-catcher* t))
-	   (loop
-	     (fresh-line)
-	     (princ (if (functionp *prompt*)
-			(funcall *prompt*)
-			*prompt*))
-	     (force-output)
-	     (let ((form (read *standard-input* nil magic-eof-cookie)))
-	       (cond ((not (eq form magic-eof-cookie))
-		      (let ((results
-			     (multiple-value-list (interactive-eval form))))
-			(dolist (result results)
-			  (fresh-line)
-			  (prin1 result)))
-		      (setf number-of-eofs 0))
-		     ((eql (incf number-of-eofs) 1)
-		      (let ((stream (make-synonym-stream '*terminal-io*)))
-			(setf *standard-input* stream)
-			(setf *standard-output* stream)
-			(format t "~&Received EOF on *standard-input*, ~
-			          switching to *terminal-io*.~%")))
-		     ((> number-of-eofs eofs-before-quit)
-		      (format t "~&Received more than ~D EOFs; Aborting.~%"
-			      eofs-before-quit)
-		      (quit))
-		     (t
-		      (format t "~&Received EOF.~%")))))))))))
-
-
-
-;;; %Halt  --  Interface
-;;;
-;;;    A convenient way to get into the assembly level debugger.
-;;;
-(defun %halt ()
-  (%primitive halt))
diff --git a/code/list.lisp b/code/list.lisp
deleted file mode 100644
index 11e987f5e5a17beb18c0155e529404e1979bcf41..0000000000000000000000000000000000000000
--- a/code/list.lisp
+++ /dev/null
@@ -1,915 +0,0 @@
-;;; -*- Log: code.log; Package: Lisp -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; Functions to implement lists for Spice Lisp.
-;;; Written by Joe Ginder and Carl Ebeling.
-;;; Rewritten and currently maintained by Skef Wholey.
-;;; 
-;;; Nsublis, things at the beginning broken.
-;;;
-;;; The list functions are part of the standard Spice Lisp environment.
-;;;
-;;; **********************************************************************
-;;;
-(in-package 'lisp)
-
-(export '(car cdr caar
-	  cadr cdar cddr caaar caadr cadar caddr cdaar cdadr
-	  cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr
-	  caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr
-	  cdddar cddddr cons tree-equal endp list-length nth first
-	  second third fourth fifth sixth seventh eighth
-	  ninth tenth rest nthcdr last list list* make-list
-	  append copy-list copy-alist copy-tree revappend nconc
-	  nreconc butlast nbutlast ldiff rplaca rplacd subst
-	  subst-if subst-if-not nsubst nsubst-if nsubst-if-not sublis nsublis
-	  member member-if member-if-not tailp adjoin union
-	  nunion intersection nintersection set-difference
-	  nset-difference set-exclusive-or nset-exclusive-or subsetp
-	  acons pairlis
-	  assoc assoc-if assoc-if-not
-	  rassoc rassoc-if rassoc-if-not))
-
-
-(proclaim '(maybe-inline
-	    tree-equal list-length nth %setnth nthcdr last make-list append
-	    copy-list copy-alist copy-tree revappend nconc nreconc butlast
-	    nbutlast ldiff member member-if member-if-not tailp adjoin union
-	    nunion intersection nintersection set-difference nset-difference
-	    set-exclusive-or nset-exclusive-or subsetp acons pairlis assoc
-	    assoc-if assoc-if-not rassoc rassoc-if rassoc-if-not subst subst-if
-	    subst-if-not nsubst nsubst-if nsubst-if-not sublis nsublis))
-
-
-(in-package "EXTENSIONS")
-(export '(assq memq delq))
-;; Assq & memq are just interpreter stubs.
-(proclaim '(maybe-inline delq))
-(in-package 'lisp)
-
-
-;;; These functions perform basic list operations:
-
-(defun car (list) "Returns the 1st object in a list." (car list))
-(defun cdr (list) "Returns all but the first object." (cdr list))
-(defun cadr (list) "Returns the 2nd object in a list." (cadr list))
-(defun cdar (list) "Returns the cdr of the 1st sublist." (cdar list))
-(defun caar (list) "Returns the car of the 1st sublist." (caar list))
-(defun cddr (list) "Returns all but the 1st two objects of a list." (cddr list))
-(defun caddr (list) "Returns the 1st object in the cddr of a list." (caddr list))
-(defun caadr (list) "Returns the 1st object in the cadr of a list." (caadr list))
-(defun caaar (list) "Returns the 1st object in the caar of a list." (caaar list))
-(defun cdaar (list) "Returns the cdr of the caar of a list." (cdaar list))
-(defun cddar (list) "Returns the cdr of the cdar of a list." (cddar list))
-(defun cdddr (list) "Returns the cdr of the cddr of a list." (cdddr list))
-(defun cadar (list) "Returns the car of the cdar of a list." (cadar list))
-(defun cdadr (list) "Returns the cdr of the cadr of a list." (cdadr list))
-(defun caaaar (list) "Returns the car of the caaar of a list." (caaaar list))
-(defun caaadr (list) "Returns the car of the caadr of a list." (caaadr list))
-(defun caaddr (list) "Returns the car of the caddr of a list." (caaddr list))
-(defun cadddr (list) "Returns the car of the cdddr of a list." (cadddr list))
-(defun cddddr (list) "Returns the cdr of the cdddr of a list." (cddddr list))
-(defun cdaaar (list) "Returns the cdr of the caaar of a list." (cdaaar list))
-(defun cddaar (list) "Returns the cdr of the cdaar of a list." (cddaar list))
-(defun cdddar (list) "Returns the cdr of the cddar of a list." (cdddar list))
-(defun caadar (list) "Returns the car of the cadar of a list." (caadar list))
-(defun cadaar (list) "Returns the car of the cdaar of a list." (cadaar list))
-(defun cadadr (list) "Returns the car of the cdadr of a list." (cadadr list))
-(defun caddar (list) "Returns the car of the cddar of a list." (caddar list))
-(defun cdaadr (list) "Returns the cdr of the caadr of a list." (cdaadr list))
-(defun cdadar (list) "Returns the cdr of the cadar of a list." (cdadar list))
-(defun cdaddr (list) "Returns the cdr of the caddr of a list." (cdaddr list))
-(defun cddadr (list) "Returns the cdr of the cdadr of a list." (cddadr list))
-(defun cons (se1 se2) "Returns a list with se1 as the car and se2 as the cdr."
-                      (cons se1 se2))
-
-
-(proclaim '(maybe-inline tree-equal-test tree-equal-test-not))
-
-(defun tree-equal-test-not (x y test-not)
-  (cond ((not (funcall test-not x y)) t)
-	((consp x)
-	 (and (consp y)
-	      (tree-equal-test-not (car x) (car y) test-not)
-	      (tree-equal-test-not (cdr x) (cdr y) test-not)))
-	(t ())))
-
-(defun tree-equal-test (x y test)
-  (cond ((funcall test x y) t)
-	((consp x)
-	 (and (consp y)
-	      (tree-equal-test (car x) (car y) test)
-	      (tree-equal-test (cdr x) (cdr y) test)))
-	(t ())))
-
-(defun tree-equal (x y &key (test #'eql) test-not)
-  "Returns T if X and Y are isomorphic trees with identical leaves."
-  (if test-not
-      (tree-equal-test-not x y test-not)
-      (tree-equal-test x y test)))
-
-
-(defun endp (object)
-  "The recommended way to test for the end of a list.  True if Object is nil,
-   false if Object is a cons, and an error for any other types of arguments."
-  (endp object))
-
-(defun list-length (list)
-  "Returns the length of the given List, or Nil if the List is circular."
-  (do ((n 0 (+ n 2))
-       (y list (cddr y))
-       (z list (cdr z)))
-      (())
-    (when (endp y) (return n))
-    (when (endp (cdr y)) (return (+ n 1)))
-    (when (and (eq y z) (> n 0)) (return nil))))
-
-(defun nth (n list)
-  "Returns the nth object in a list where the car is the zero-th element."
-  (car (%primitive nthcdr n list)))
-
-(defun first (list)
-  "Returns the 1st object in a list or NIL if the list is empty."
-  (car list))
-(defun second (list)
-  "Returns the 2nd object in a list or NIL if there is no 2nd object."
-  (cadr list))
-(defun third (list)
-  "Returns the 3rd object in a list or NIL if there is no 3rd object."
-  (caddr list))
-(defun fourth (list)
-  "Returns the 4th object in a list or NIL if there is no 4th object."
-  (cadddr list))
-(defun fifth (list)
-  "Returns the 5th object in a list or NIL if there is no 5th object."
-  (car (cddddr list)))
-(defun sixth (list)
-  "Returns the 6th object in a list or NIL if there is no 6th object."
-  (cadr (cddddr list)))
-(defun seventh (list)
-  "Returns the 7th object in a list or NIL if there is no 7th object."
-  (caddr (cddddr list)))
-(defun eighth (list)
-  "Returns the 8th object in a list or NIL if there is no 8th object."
-  (cadddr (cddddr list)))
-(defun ninth (list)
-  "Returns the 9th object in a list or NIL if there is no 9th object."
-  (car (cddddr (cddddr list))))
-(defun tenth (list)
-  "Returns the 10th object in a list or NIL if there is no 10th object."
-  (cadr (cddddr (cddddr list))))
-(defun rest (list)
-  "Means the same as the cdr of a list."
-  (cdr list))
-
-(defun nthcdr (n list)
-  "Performs the cdr function n times on a list."
-  (%primitive nthcdr n list))
-
-(defun last (list)
-  "Returns the last cons (not the last element!) of a list."
-  (%primitive last list))
-
-(defun list (&rest args)
-  "Returns constructs and returns a list of its arguments."
-  args)
-
-;;; List* is done the same as list, except that the last cons is made a
-;;; dotted pair
-
-(defun list* (arg &rest others)
-  "Returns a list of the arguments with last cons a dotted pair"
-  (cond ((atom others) arg)
-	((atom (cdr others)) (cons arg (car others)))
-	(t (do ((x others (cdr x)))
-	       ((null (cddr x)) (rplacd x (cadr x))))
-	   (cons arg others))))
-
-(defun make-list (size &key initial-element)
-  (declare (fixnum size))
-  "Constructs a list with size elements each set to value"
-  (if (< size 0) (error "~S is an illegal size for MAKE-LIST." size)
-      (do ((count size (1- count))
-	   (result '() (cons initial-element result)))
-	  ((zerop count) result)
-	(declare (fixnum count)))))
-
-;;; The outer loop finds the first non-null list and the result is started.
-;;; The remaining lists in the arguments are tacked to the end of the result
-;;; using splice which cdr's down the end of the new list
-
-(defun append (&rest lists)
-  "Construct a new list by concatenating the list arguments"
-  (do ((top lists (cdr top)))	 ;;Cdr to first non-null list.
-      ((atom top) '())
-    (cond ((null (car top)))				; Nil -> Keep looping
-	  ((not (consp (car top)))			; Non cons
-	   (if (cdr top)
-	       (error "~S is not a list." (car top))
-	       (return (car top))))
-	  (t						; Start appending
-	   (return
-	     (if (atom (cdr top))
-		 (car top)    ;;Special case.
-		 (let* ((result (cons (caar top) '())) 
-			(splice result))
-		   (do ((x (cdar top) (cdr x)))  ;;Copy first list
-		       ((atom x))
-		     (setq splice
-			   (cdr (rplacd splice (cons (car x) ()) ))) )
-		   (do ((y (cdr top) (cdr y)))	 ;;Copy rest of lists.
-		       ((atom (cdr y))
-			(setq splice (rplacd splice (car y)))
-			result)
-		     (if (listp (car y))
-			 (do ((x (car y) (cdr x)))   ;;Inner copy loop.
-			     ((atom x))
-			   (setq
-			    splice
-			    (cdr (rplacd splice (cons (car x) ())))))
-			 (error "~S is not a list." (car y)))))))))))
-  
-
-;;; List Copying Functions
-
-
-;;; The list is copied correctly even if the list is not terminated by ()
-;;; The new list is built by cdr'ing splice which is always at the tail
-;;; of the new list
-
-(defun copy-list (list)
-  "Returns a new list EQUAL but not EQ to list"
-  (if (atom list)
-      (if list
-	  (error "~S is not a list." list))
-      (let ((result (cons (car list) '()) ))
-	(do ((x (cdr list) (cdr x))
-	     (splice result
-		     (cdr (rplacd splice (cons (car x) '() ))) ))
-	    ((atom x) (unless (null x)
-			      (rplacd splice x))
-		      result)))))
-
-(defun copy-alist (alist)
-  "Returns a new association list equal to alist, constructed in space"
-  (if (atom alist)
-      (if alist
-	  (error "~S is not a list." alist))
-      (let ((result
-	     (cons (if (atom (car alist))
-		       (car alist)
-		       (cons (caar alist) (cdar alist)) )
-		   '() )))	      
-	(do ((x (cdr alist) (cdr x))
-	     (splice result
-		     (cdr (rplacd splice
-				  (cons
-				   (if (atom (car x)) 
-				       (car x)
-				       (cons (caar x) (cdar x)))
-				   '() ))) ))
-;;; Non-null terminated alist done here.
-	    ((atom x) (unless (null x)
-			      (rplacd splice x))
-		      result)))))
-
-(defun copy-tree (object)
-  "Copy-Tree recursively copys trees of conses."
-  (cond ((not (consp object)) object)
-	(T (cons (copy-tree (car object)) (copy-tree (cdr object)))) ))
-
-;;; More Commonly-used List Functions
-
-(defun revappend (x y)
-  "Returns (append (reverse x) y)"
-  (do ((top x (cdr top))
-       (result y (cons (car top) result)))
-      ((endp top) result)))
-
-;;; NCONC finds the first non-null list, so it can make splice point to a cons.
-;;; After finding the first cons element, it holds it in a result variable
-;;; while running down successive elements tacking them together.  While
-;;; tacking lists together, if we encounter a null list, we set the previous
-;;; list's last cdr to nil just in case it wasn't already nil, and it could
-;;; have been dotted while the null list was the last argument to NCONC.  The
-;;; manipulation of splice (that is starting it out on a first cons, setting
-;;; LAST of splice, and setting splice to ele) inherently handles (nconc x x),
-;;; and it avoids running down the last argument to NCONC which allows the last
-;;; argument to be circular.
-;;;
-(defun nconc (&rest lists)
-  "Concatenates the lists given as arguments (by changing them)"
-  (do ((top lists (cdr top)))
-      ((null top) nil)
-    (let ((top-of-top (car top)))
-      (typecase top-of-top
-	(cons
-	 (let* ((result top-of-top)
-		(splice result))
-	   (do ((elements (cdr top) (cdr elements)))
-	       ((endp elements))
-	     (let ((ele (car elements)))
-	       (typecase ele
-		 (cons (rplacd (last splice) ele)
-		       (setf splice ele))
-		 (null (rplacd (last splice) nil))
-		 (atom (if (cdr elements)
-			   (error "Argument is not a list -- ~S." ele)
-			   (rplacd (last splice) ele)))
-		 (t (error "Argument is not a list -- ~S." ele)))))
-	   (return result)))
-	(null)
-	(atom (return top-of-top))
-	(t (error "Argument is not a list -- ~S." top-of-top))))))
-
-(defun nreconc (x y)
-  "Returns (nconc (nreverse x) y)"
-  (do ((1st (cdr x) (if (atom 1st) 1st (cdr 1st)))
-       (2nd x 1st)		;2nd follows first down the list.
-       (3rd y 2nd))		;3rd follows 2nd down the list.
-      ((atom 2nd) 3rd)
-    (rplacd 2nd 3rd)))
-
-(defun butlast (list &optional (n 1))
-  "Returns a new list the same as List without the N last elements."
-  (unless (integerp n)
-    (error "Wrong type argument, ~S, should have been of type INTEGER."))
-  (if (< n 0) (setq n 0))
-  (let ((length (1- (length (the list list)))))
-    (declare (fixnum length))
-    (if (< length n)
-	()
-	(do* ((top (cdr list) (cdr top))
-	      (result (list (car list)))
-	      (splice result)
-	      (count length (1- count)))
-	     ((= count n) result)
-	  (setq splice (cdr (rplacd splice (list (car top)))))))))
-
-(defun nbutlast (list &optional (n 1))
-  "Modifies List to remove the last N elements."
-  (unless (integerp n)
-    (error "Wrong type argument, ~S, should have been of type INTEGER."))
-  (if (< n 0) (setq n 0))
-  (let ((length (1- (length (the list list)))))
-    (declare (fixnum length))
-    (if (< length n) ()
-	(do ((1st (cdr list) (cdr 1st))
-	     (2nd list 1st)
-	     (count length (1- count)))
-	    ((= count n)
-	     (rplacd 2nd ())
-	     list)))))
-
-(defun ldiff (list sublist)
-  "Returns a new list, whose elements are those of List that appear before
-   Sublist.  If Sublist is not a tail of List, a copy of List is returned."
-  (do* ((list list (cdr list))
-	(result (list ()))
-	(splice result))
-       ((or (null list) (eq list sublist)) (cdr result))
-    (setq splice (cdr (rplacd splice (list (car list)))))))
-
-;;; Functions to alter list structure
-
-(defun rplaca (x y)
-  "Changes the car of x to y and returns the new x."
-  (rplaca x y))
-
-(defun rplacd (x y)
-  "Changes the cdr of x to y and returns the new x."
-  (rplacd x y))
-
-;;; The following are for use by SETF.
-
-(defun %rplaca (x val) (rplaca x val) val)
-
-(defun %rplacd (x val) (rplacd x val) val)
-
-(defun %setnth (n list newval)
-  (declare (fixnum n))
-  "Sets the Nth element of List (zero based) to Newval."
-  (if (< n 0)
-      (error "~S is an illegal N for SETF of NTH." n)
-      (do ((count n (1- count)))
-	  ((zerop count) (rplaca list newval) newval)
-	(declare (fixnum count))
-	(if (endp (cdr list))
-	    (error "~S is too large an index for SETF of NTH." n)
-	    (setq list (cdr list))))))
-
-;;;; Macros for (&key (key #'identity) (test #'eql testp) (test-not nil notp)).
-;;; Use these with the following keyword args:
-;;;
-(defmacro with-set-keys (funcall)
-  `(cond ((and testp notp) (error "Test and test-not both supplied."))
-	 (notp ,(append funcall '(:key key :test-not test-not)))
-	 (t ,(append funcall '(:key key :test test)))))
-
-(defmacro satisfies-the-test (item elt)
-  `(cond (testp
-	  (funcall test ,item (funcall key ,elt)))
-	 (notp
-	  (not (funcall test-not ,item (funcall key ,elt))))
-	 (t (funcall test ,item (funcall key ,elt)))))
-
-
-;;; Substitution of expressions
-
-
-
-(defun subst (new old tree &key (key #'identity)
-		  (test #'eql testp) (test-not nil notp))
-  "Substitutes new for subtrees matching old."
-  (labels ((s (subtree)
-	      (cond ((satisfies-the-test old subtree) new)
-		    ((atom subtree) subtree)
-		    (t (let ((car (s (car subtree)))
-			     (cdr (s (cdr subtree))))
-			 (if (and (eq car (car subtree))
-				  (eq cdr (cdr subtree)))
-			     subtree
-			     (cons car cdr)))))))
-    (s tree)))
-
-(defun subst-if (new test tree &key (key #'identity))
-  "Substitutes new for subtrees for which test is true."
-  (labels ((s (subtree)
-	      (cond ((funcall test (funcall key subtree)) new)
-		    ((atom subtree) subtree)
-		    (t (let ((car (s (car subtree)))
-			     (cdr (s (cdr subtree))))
-			 (if (and (eq car (car subtree))
-				  (eq cdr (cdr subtree)))
-			     subtree
-			     (cons car cdr)))))))
-    (s tree)))
-
-(defun subst-if-not (new test tree &key (key #'identity))
-  "Substitutes new for subtrees for which test is false."
-  (labels ((s (subtree)
-	      (cond ((not (funcall test (funcall key subtree))) new)
-		    ((atom subtree) subtree)
-		    (t (let ((car (s (car subtree)))
-			     (cdr (s (cdr subtree))))
-			 (if (and (eq car (car subtree))
-				  (eq cdr (cdr subtree)))
-			     subtree
-			     (cons car cdr)))))))
-    (s tree)))
-
-(defun nsubst (new old tree &key (key #'identity)
-		  (test #'eql testp) (test-not nil notp))
-  "Substitutes new for subtrees matching old."
-  (labels ((s (subtree)
-	      (cond ((satisfies-the-test old subtree) new)
-		    ((atom subtree) subtree)
-		    (t (do* ((last nil subtree)
-			     (subtree subtree (Cdr subtree)))
-			    ((atom subtree)
-			     (if (satisfies-the-test old subtree)
-				 (setf (cdr last) new)))
-			 (if (satisfies-the-test old subtree)
-			     (return (setf (cdr last) new))
-			     (setf (car subtree) (s (car subtree)))))
-		       subtree))))
-    (s tree)))
-
-(defun nsubst-if (new test tree &key (key #'identity))
-  "Substitutes new for subtrees of tree for which test is true."
-  (labels ((s (subtree)
-	      (cond ((funcall test (funcall key subtree)) new)
-		    ((atom subtree) subtree)
-		    (t (do* ((last nil subtree)
-			     (subtree subtree (Cdr subtree)))
-			    ((atom subtree)
-			     (if (funcall test (funcall key subtree))
-				 (setf (cdr last) new)))
-			 (if (funcall test (funcall key subtree))
-			     (return (setf (cdr last) new))
-			     (setf (car subtree) (s (car subtree)))))
-		       subtree))))
-    (s tree)))
-
-(defun nsubst-if-not (new test tree &key (key #'identity))
-  "Substitutes new for subtrees of tree for which test is false."
-  (labels ((s (subtree)
-	      (cond ((not (funcall test (funcall key subtree))) new)
-		    ((atom subtree) subtree)
-		    (t (do* ((last nil subtree)
-			     (subtree subtree (Cdr subtree)))
-			    ((atom subtree)
-			     (if (not (funcall test (funcall key subtree)))
-				 (setf (cdr last) new)))
-			 (if (not (funcall test (funcall key subtree)))
-			     (return (setf (cdr last) new))
-			     (setf (car subtree) (s (car subtree)))))
-		       subtree))))
-    (s tree)))
-
-
-
-
-(defun sublis (alist tree &key (key #'identity)
-		     (test #'eql) (test-not nil notp))
-  "Substitutes from alist into tree nondestructively."
-  (labels ((s (subtree)
-	      (let ((assoc
-		     (if notp
-			 (assoc (funcall key subtree) alist :test-not test-not)
-			 (assoc (funcall key subtree) alist :test test))))
-		(cond (assoc (cdr assoc))
-		      ((atom subtree) subtree)
-		      (t (let ((car (s (car subtree)))
-			       (cdr (s (cdr subtree))))
-			   (if (and (eq car (car subtreE))
-				    (eq cdr (cdr subtree)))
-			       subtree
-			       (cons car cdr))))))))
-    (s tree)))
-
-;;; In run-time env, since can be referenced in line expansions.
-(defmacro nsublis-macro ()
-  '(if notp
-       (assoc (funcall key subtree) alist :test-not test-not)
-       (assoc (funcall key subtree) alist :test test)))
-
-(defun nsublis (alist tree &key (key #'identity)
-		  (test #'eql) (test-not nil notp))
-  "Substitutes new for subtrees matching old."
-  (let (temp)
-    (labels ((s (subtree)
-		(cond ((Setq temp (nsublis-macro))
-		       (cdr temp))
-		      ((atom subtree) subtree)
-		      (t (do* ((last nil subtree)
-			       (subtree subtree (Cdr subtree)))
-			      ((atom subtree)
-			       (if (setq temp (nsublis-macro))
-				   (setf (cdr last) (cdr temp))))
-			   (if (setq temp (nsublis-macro))
-			       (return (setf (Cdr last) (Cdr temp)))
-			       (setf (car subtree) (s (car subtree)))))
-			 subtree))))
-      (s tree))))
-
-
-;;;; Functions for using lists as sets
-
-(defun member (item list &key (key #'identity) (test #'eql testp)
-		    (test-not nil notp))
-  "Returns tail of list beginning with first element satisfying EQLity,
-   :test, or :test-not with a given item."
-  (do ((list list (cdr list)))
-      ((null list) nil)
-    (let ((car (car list)))
-      (if (satisfies-the-test item car)
-	  (return list)))))
-
-(defun member-if (test list &key (key #'identity))
-  "Returns tail of list beginning with first element satisfying test(element)"
-  (unless (listp list)
-    (error "~S is not a list." list))
-  (do ((list list (Cdr list)))
-      ((endp list) nil)
-    (if (funcall test (funcall key (car list)))
-	(return list))))
-
-(defun member-if-not (test list &key (key #'identity))
-  "Returns tail of list beginning with first element not satisfying test(el)"
-  (unless (listp list)
-    (error "~S is not a list." list))
-  (do ((list list (cdr list)))
-      ((endp list) ())
-    (if (not (funcall test (funcall key (car list))))
-	(return list)))))
-
-(defun tailp (sublist list)
-  "Returns T if sublist is one of the cons'es in list"
-  (do ((x list (cdr x)))
-      ((endp x) '())
-    (if (eq x sublist) (return T))))
-
-(defun adjoin (item list &key (key #'identity) (test #'eql) (test-not nil notp))
-  "Add item to list unless it is already a member"
-  (if (if notp (member (funcall key item) list :test-not test-not :key key)
-	  (member (funcall key item) list :test test :key key))
-      list
-      (cons item list)))
-
-
-;;; UNION -- Public.
-;;;
-;;; This function assumes list2 is the result, adding to it from list1 as
-;;; necessary.  List2 must initialize the result value, so the call to MEMBER
-;;; will apply the test to the elements from list1 and list2 in the correct
-;;; order.
-;;;
-(defun union (list1 list2 &key
-		    (key #'identity) (test #'eql testp) (test-not nil notp))
-  "Returns the union of list1 and list2."
-  (when (and testp notp) (error "Test and test-not both supplied."))
-  (let ((res list2))
-    (dolist (elt list1)
-      (unless (with-set-keys (member (funcall key elt) list2))
-	(push elt res)))
-    res))
-
-;;; Destination and source are setf-able and many-evaluable.  Sets the source
-;;; to the cdr, and "conses" the 1st elt of source to destination.
-;;;
-(defmacro steve-splice (source destination)
-  `(let ((temp ,source))
-     (setf ,source (cdr ,source)
-	   (cdr temp) ,destination
-	   ,destination temp)))
-
-(defun nunion (list1 list2 &key (key #'identity)
-		     (test #'eql testp) (test-not nil notp))
-  "Destructively returns the union list1 and list2."
-  (if (and testp notp)
-      (error "Test and test-not both supplied."))
-  (let ((res list2))
-    (do ()
-	((endp list1))
-      (if (not (with-set-keys (member (funcall key (car list1)) list2)))
-	  (steve-splice list1 res)
-	  (setf list1 (cdr list1))))
-    res))
-  
-
-(defun intersection (list1 list2  &key (key #'identity)
-			       (test #'eql testp) (test-not nil notp))
-  "Returns the intersection of list1 and list2."
-  (if (and testp notp)
-      (error "Test and test-not both supplied."))
-  (let ((res nil))
-    (dolist (elt list1)
-      (if (with-set-keys (member (funcall key elt) list2))
-	  (push elt res)))
-    res))
-
-(Defun nintersection (list1 list2 &key (key #'identity)
-		     (test #'eql testp) (test-not nil notp))
-  "Destructively returns the intersection of list1 and list2."
-  (if (and testp notp)
-      (error "Test and test-not both supplied."))
-  (let ((res nil))
-    (do () ((endp list1))
-      (if (with-set-keys (member (funcall key (car list1)) list2))
-	  (steve-splice list1 res)
-	  (setq list1 (Cdr list1))))
-    res))
-
-(Defun set-difference (list1 list2 &key (key #'identity)
-			     (test #'eql testp) (test-not nil notp))
-  "Returns the elements of list1 which are not in list2."
-  (if (and testp notp)
-      (error "Test and test-not both supplied."))
-  (if (null list2)
-      list1
-      (let ((res nil))
-	(dolist (elt list1)
-	  (if (not (with-set-keys (member (funcall key elt) list2)))
-	      (push elt res)))
-	res)))
-
-
-(Defun nset-difference (list1 list2 &key (key #'identity)
-			      (test #'eql testp) (test-not nil notp))
-  "Destructively returns the elements of list1 which are not in list2."
-  (if (and testp notp)
-      (error "Test and test-not both supplied."))
-  (let ((res nil))
-    (do () ((endp list1))
-      (if (not (with-set-keys (member (funcall key (car list1)) list2)))
-	  (steve-splice list1 res)
-	  (setq list1 (cdr list1))))
-    res))
-
-
-(defun set-exclusive-or (list1 list2 &key (key #'identity)
-			       (test #'eql testp) (test-not nil notp))
-  "Returns new list of elements appearing exactly once in list1 and list2."
-  (let ((result nil))
-    (dolist (elt list1)
-      (unless (with-set-keys (member (funcall key elt) list2))
-	(setq result (cons elt result))))
-    (dolist (elt list2)
-      (unless (with-set-keys (member (funcall key elt) list1))
-	(setq result (cons elt result))))
-    result))
-
-
-;;; The outer loop examines list1 while the inner loop examines list2. If an
-;;; element is found in list2 "equal" to the element in list1, both are
-;;; spliced out. When the end of list1 is reached, what is left of list2 is
-;;; tacked onto what is left of list1.  The splicing operation ensures that
-;;; the correct operation is performed depending on whether splice is at the
-;;; top of the list or not
-
-(defun nset-exclusive-or (list1 list2 &key (test #'eql) (test-not nil notp)
-				(key #'identity))
-  "Destructively return a list with elements which appear but once in list1
-   and list2."
-  (do ((x list1 (cdr x))
-       (splicex ()))
-      ((endp x)
-       (if (null splicex)
-	   (setq list1 list2)
-	   (rplacd splicex list2))
-       list1)
-    (do ((y list2 (cdr y))
-	 (splicey ()))
-	((endp y) (setq splicex x))
-      (cond ((if notp
-		 (not (funcall test-not (funcall key (car x))
-			       (funcall key (Car y))))
-		 (funcall test (funcall key (car x)) (funcall key (Car y))))
-	     (if (null splicex)
-		 (setq list1 (cdr x))
-		 (rplacd splicex (cdr x)))
-	     (if (null splicey) 
-		 (setq list2 (cdr y))
-		 (rplacd splicey (cdr y)))
-	     (return ()))			; assume lists are really sets
-	    (t (setq splicey y)))))))
-
-(defun subsetp (list1 list2 &key (key #'identity)
-		      (test #'eql testp) (test-not nil notp))
-  "Returns T if every element in list1 is also in list2."
-  (dolist (elt list1)
-    (unless (with-set-keys (member (funcall key elt) list2))
-      (return-from subsetp nil)))
-  T)
-
-
-
-;;;; :key arg optimization to save funcall of IDENTITY.
-
-;;; We should move this earlier in this file and make other functions use it as
-;;; well.
-;;;
-
-;;; APPLY-KEY saves us a function call sometimes.
-;;;    This is not in and (eval-when (compile eval) ...
-;;;    because this is used in seq.lisp and sort.lisp.
-;;;
-(defmacro apply-key (key element)
-  `(if ,key
-       (funcall ,key ,element)
-       ,element))
-
-(defun identity (thing)
-  "Returns what was passed to it."
-  thing)
-
-
-
-;;; Functions that operate on association lists
-
-(defun acons (key datum alist)
-  "Construct a new alist by adding the pair (key . datum) to alist"
-  (cons (cons key datum) alist))
-
-(defun pairlis (keys data &optional (alist '()))
-  "Construct an association list from keys and data (adding to alist)"
-  (do ((x keys (cdr x))
-       (y data (cdr y)))
-      ((and (endp x) (endp y)) alist)
-    (if (or (endp x) (endp y)) 
-	(error "The lists of keys and data are of unequal length."))
-    (setq alist (acons (car x) (car y) alist))))
-
-;;; In run-time environment, since these guys can be inline expanded.
-(defmacro assoc-guts (test-guy)
-  `(do ((alist alist (cdr alist)))
-       ((endp alist))
-     (if (car alist)
-	 (if ,test-guy (return (car alist))))))
-) ;eval-when
-
-
-(defun assoc (item alist &key key test test-not)
-  "Returns the cons in alist whose car is equal (by a given test or EQL) to
-   the Item."
-  (cond (test (assoc-guts (funcall test item (apply-key key (caar alist)))))
-	(test-not (assoc-guts (not (funcall test-not item
-					    (apply-key key (caar alist))))))
-	(t (assoc-guts (eql item (apply-key key (caar alist)))))))
-
-(defun assoc-if (predicate alist &key key)
-  "Returns the first cons in alist whose car satisfies the Predicate.  If
-   key is supplied, apply it to the car of each cons before testing."
-  (assoc-guts (funcall predicate (apply-key key (caar alist)))))
-
-(defun assoc-if-not (predicate alist &key key)
-  "Returns the first cons in alist whose car does not satisfiy the Predicate.
-  If key is supplied, apply it to the car of each cons before testing."
-  (assoc-guts (not (funcall predicate (apply-key key (caar alist))))))
-
-
-(defun rassoc (item alist &key key test test-not)
-  (declare (list alist))
-  "Returns the cons in alist whose cdr is equal (by a given test or EQL) to
-   the Item."
-  (cond (test (assoc-guts (funcall test item (apply-key key (cdar alist)))))
-	(test-not (assoc-guts (not (funcall test-not item
-					    (apply-key key (cdar alist))))))
-	(t (assoc-guts (eql item (apply-key key (cdar alist)))))))
-
-(defun rassoc-if (predicate alist &key key)
-  "Returns the first cons in alist whose cdr satisfies the Predicate.  If key
-  is supplied, apply it to the cdr of each cons before testing."
-  (assoc-guts (funcall predicate (apply-key key (cdar alist)))))
-
-(defun rassoc-if-not (predicate alist &key key)
-  "Returns the first cons in alist whose cdr does not satisfy the Predicate.
-  If key is supplied, apply it to the cdr of each cons before testing."
-  (assoc-guts (not (funcall predicate (apply-key key (cdar alist))))))
-
-
-
-;;;; Mapping functions.
-
-(defun map1 (function original-arglists accumulate take-car)
-  "This function is called by mapc, mapcar, mapcan, mapl, maplist, and mapcon.
-  It Maps function over the arglists in the appropriate way. It is done when any
-  of the arglists runs out.  Until then, it CDRs down the arglists calling the
-  function and accumulating results as desired."
-
-  (let* ((arglists (copy-list original-arglists))
-	 (ret-list (list nil)) 
-	 (temp ret-list))
-    (do ((res nil)
-	 (args '() '()))
-	((dolist (x arglists nil) (if (null x) (return t)))
-	 (if accumulate
-	     (cdr ret-list)
-	     (car original-arglists)))
-      (do ((l arglists (cdr l)))
-	  ((null l))
-	(push (if take-car (caar l) (car l)) args)
-	(setf (car l) (cdar l)))
-      (setq res (apply function (nreverse args)))
-      (case accumulate
-	(:nconc (setq temp (last (nconc temp res))))
-	(:list (rplacd temp (list res))
-	       (setq temp (cdr temp)))))))
-
-
-(defun mapc (function list &rest more-lists)
-  "Applies fn to successive elements of lists, returns its second argument."
-  (map1 function (cons list more-lists) nil t))
-
-(defun mapcar (function list &rest more-lists)
-  "Applies fn to successive elements of list, returns list of results."
-  (map1 function (cons list more-lists) :list t))
-
-(defun mapcan (function list &rest more-lists)
-  "Applies fn to successive elements of list, returns NCONC of results."
-  (map1 function (cons list more-lists) :nconc t))
-
-(defun mapl (function list &rest more-lists)
-  "Applies fn to successive CDRs of list, returns ()."
-  (map1 function (cons list more-lists) nil nil))
-
-(defun maplist (function list &rest more-lists)
-  "Applies fn to successive CDRs of list, returns list of results."
-  (map1 function (cons list more-lists) :list nil))
-
-(defun mapcon (function list &rest more-lists)
-  "Applies fn to successive CDRs of lists, returns NCONC of results."
-  (map1 function (cons list more-lists) :nconc nil))
-
-
-;;; Functions for compatibility sake:
-
-(defun memq (item list)
-  "Returns tail of list beginning with first element eq to item"
-  (memq item list))
-
-(defun assq (item alist)
-  "Return the first pair of alist where item EQ the key of pair"
-  (assq item alist))
-
-(defun delq (item list &optional (n 0 np))
-  (declare (fixnum n))
-  "Returns list with all (up to n) elements with all elements EQ to ITEM
-   deleted"
-  (do ((x list (cdr x))
-       (splice '()))
-      ((or (endp x)
-	   (and np (zerop n))) list)
-    (cond ((eq item (car x))
-	   (setq n (1- n))
-	   (if (null splice) 
-	       (setq list (cdr x))
-	       (rplacd splice (cdr x))))
-	  (T (setq splice x)))))	; move splice along to include element
diff --git a/code/load.lisp b/code/load.lisp
deleted file mode 100644
index 5154c157f8829e78903f1af311a44604bd0508ee..0000000000000000000000000000000000000000
--- a/code/load.lisp
+++ /dev/null
@@ -1,1023 +0,0 @@
-;;; -*- Log: code.log; Package: Lisp -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; Loader for Spice Lisp.
-;;; Written by Skef Wholey and Rob MacLachlan.
-;;;
-(in-package "LISP")
-(export '(load *load-verbose*))
-
-(in-package "SYSTEM")
-(export 'resolve-loaded-assembler-references)
-
-(in-package "EXTENSIONS")
-(export '*load-if-source-newer*)
-
-(in-package "LISP")
-
-
-;;;; Random state variables:
-
-(defvar *load-verbose* ()
-  "The default for the :Verbose argument to Load.")
-(defvar *load-print-stuff* ()
-  "True if we're gonna mumble about what we're loading.")
-(defvar *fasl-file* () "The fasl file we're reading from.")
-(defvar *current-code-format* "The code format that we think we are loading.")
-
-(defvar *in-cold-load* nil)	; True if we are in the cold loader.
-
-(defvar *load-if-source-newer* :load-object
-  "The value of *load-if-source-newer* determines what happens when the
-  source file is newer than the object file.  The possible values are:
-  :load-object - load object file (default), :load-source - load the source
-  file, :compile - compile the source and then load the object file, or
-  :query - ask the user if he wants to load the source or object file.")
-
-(proclaim '(special cold-fop-functions))
-
-;;;; The Fop-Table:
-;;;
-;;;    The table is implemented as a simple-vector indexed by the table
-;;; offset.  We may need to have several, since load can be called recursively.
-
-(defvar *free-fop-tables* (list (make-array 1000))
-  "List of free fop tables for the fasloader.")
-
-(defvar *current-fop-table* ()
-  "The current fop table.")
-
-(defvar *current-fop-table-size* ()
-  "The length of the current fop table.")
-
-(defvar *current-fop-table-index* ()
-  "Index in the fop-table of the next entry to be used.")
-
-(defun grow-fop-table ()
-  (let* ((new-size (* *current-fop-table-size* 2))
-	 (new-table (make-array new-size)))
-    (declare (fixnum new-size) (simple-vector new-table))
-    (replace new-table (the simple-vector *current-fop-table*))
-    (setq *current-fop-table* new-table)
-    (setq *current-fop-table-size* new-size)))
-
-(defmacro push-table (thing)
-  (let ((n-index (gensym)))
-    `(let ((,n-index *current-fop-table-index*))
-       (declare (fixnum ,n-index))
-       (when (= ,n-index (the fixnum *current-fop-table-size*))
-	 (grow-fop-table))
-       (setq *current-fop-table-index* (1+ ,n-index))
-       (setf (svref *current-fop-table* ,n-index) ,thing))))
-
-;;;; The Fop-Stack:
-;;;
-;;;  The is also in a simple-vector, but it grows down, since it is somewhat 
-;;; cheaper to test for overflow that way.
-;;;
-(defvar *fop-stack* (make-array 100)
-  "The fop stack (we only need one!).")
-
-(defvar *fop-stack-pointer* 100
-  "The index of the most recently pushed item on the fop-stack.")
-
-(defvar *fop-stack-pointer-on-entry* ()
-  "The current index into the fop stack when we last recursively entered LOAD.")
-
-
-(defun grow-fop-stack ()
-  (let* ((size (length (the simple-vector *fop-stack*)))
-	 (new-size (* size 2))
-	 (new-stack (make-array new-size)))
-    (declare (fixnum size new-size) (simple-vector new-stack))
-    (replace new-stack (the simple-vector *fop-stack*) :start1 size)
-    (incf *fop-stack-pointer-on-entry* size)
-    (setq *fop-stack-pointer* size)
-    (setq *fop-stack* new-stack)))
-
-;;; With-Fop-Stack  --  Internal
-;;;
-;;;    Cache information about the fop-stack in local variables.  Define
-;;; a local macro to pop from the stack.  Push the result of evaluation if
-;;; specified.
-;;;
-(defmacro with-fop-stack (pushp &body forms)
-  (let ((n-stack (gensym))
-	(n-index (gensym))
-	(n-res (gensym)))
-    `(let ((,n-stack *fop-stack*)
-	   (,n-index *fop-stack-pointer*))
-       (declare (simple-vector ,n-stack) (fixnum ,n-index))
-       (macrolet ((pop-stack ()
-		    `(prog1
-		      (svref ,',n-stack ,',n-index)
-		      (setq ,',n-index (1+ ,',n-index))))
-		  (call-with-popped-things (fun n)
-		    (let ((n-start (gensym)))
-		      `(let ((,n-start (+ ,',n-index ,n)))
-			 (setq ,',n-index ,n-start)
-			 (,fun ,@(make-list n :initial-element
-					    `(svref ,',n-stack
-						    (decf ,n-start))))))))
-	 ,(if pushp
-	      `(let ((,n-res (progn ,@forms)))
-		 (when (zerop ,n-index)
-		   (grow-fop-stack)
-		   (setq ,n-index *fop-stack-pointer*
-			 ,n-stack *fop-stack*))
-		 (decf ,n-index)
-		 (setq *fop-stack-pointer* ,n-index)
-		 (setf (svref ,n-stack ,n-index) ,n-res))
-	      `(prog1
-		(progn ,@forms)
-		(setq *fop-stack-pointer* ,n-index)))))))
-
-;;; FOP database:
-
-(defvar fop-codes (make-array 256)
-  "Vector indexed by a FaslOP that yields the FOP's name.")
-
-(defvar fop-functions
-  (make-array 256 :initial-element #'(lambda () (error "Losing FOP!")))
-  "Vector indexed by a FaslOP that yields a function of 0 arguments which
-  will perform the operation.")
-
-
-;;; Define-FOP  --  Internal
-;;;
-;;;    Defines Name as a fasl operation, with op-code op.  If pushp is :nope,
-;;; the the body neither pushes or pops the fop stack.  If it is nil, then
-;;; the body may pop, but the result is ignored.  If it is true, the the result
-;;; is pushed on the stack.
-;;;
-(defmacro define-fop ((name op &optional (pushp t)) &rest forms)
-  `(progn
-    (defun ,name ()
-      ,(if (eq pushp :nope)
-	   `(progn ,@forms)
-	   `(with-fop-stack ,pushp ,@forms)))
-    (setf (svref fop-codes ,op) ',name)
-    (setf (get ',name 'fop-code) ,op)
-    (setf (svref fop-functions ,op) #',name)))
-
-;;; Clone-Fop  --  Internal
-;;;
-;;;    Defines a pair of fops which are identical except in that one reads
-;;; a four byte argument and the other reads a one byte argument.  The
-;;; argument can be accessed by using the Clone-Arg macro.
-;;;
-(defmacro clone-fop ((name op &optional (pushp t))
-		      (small-name small-op) &rest forms)
-  `(progn
-    (macrolet ((clone-arg () '(read-arg 4)))
-      (define-fop (,name ,op ,pushp) ,@forms))
-    (macrolet ((clone-arg () '(read-arg 1)))
-      (define-fop (,small-name ,small-op ,pushp) ,@forms))))
-
-;;;; Utilities for reading from the fasl file.
-
-(proclaim '(inline read-byte))
-
-;;; Fast-Read-U-Integer  --  Internal
-;;;
-;;;    Expands into code to read an N-byte unsigned integer using
-;;; fast-read-byte.
-;;;
-(defmacro fast-read-u-integer (n)
-  (do ((res '(fast-read-byte)
-	    `(logior (fast-read-byte)
-		     (ash ,res 8)))
-       (cnt 1 (1+ cnt)))
-      ((>= cnt n) res)))
-
-;;; Fast-Read-Variable-U-Integer  --  Internal
-;;;
-;;;    Like Fast-Read-U-Integer, but the size may be determined at run time.
-;;;
-(defmacro fast-read-variable-u-integer (n)
-  (let ((n-pos (gensym))
-	(n-res (gensym))
-	(n-cnt (gensym)))
-    `(do ((,n-pos 8 (+ ,n-pos 8))
-	  (,n-cnt (1- ,n) (1- ,n-cnt))
-	  (,n-res
-	   (fast-read-byte)
-	   (dpb (fast-read-byte) (byte 8 ,n-pos) ,n-res)))
-	 ((zerop ,n-cnt) ,n-res))))
-
-;;; Fast-Read-S-Integer  --  Internal
-;;;
-;;;    Read a signed integer.
-;;;
-(defmacro fast-read-s-integer (n)
-  (let ((n-last (gensym)))
-    (do ((res `(let ((,n-last (fast-read-byte)))
-		 (if (zerop (logand ,n-last #x80))
-		     ,n-last
-		     (logior ,n-last #x-100)))
-	      `(logior (fast-read-byte)
-		       (ash ,res 8)))
-	 (cnt 1 (1+ cnt)))
-	((>= cnt n) res))))
-
-;;; Read-Arg  --  Internal
-;;;
-;;;    Read an N-byte unsigned integer from the *fasl-file*
-;;;
-(defmacro read-arg (n)
-  (if (= n 1)
-      `(read-byte *fasl-file*)
-      `(prepare-for-fast-read-byte *fasl-file*
-	 (prog1
-	  (fast-read-u-integer ,n)
-	  (done-with-fast-read-byte)))))
-
-;;; Fasload:
-
-(defun fasload (stream)
-  (when *load-verbose*
-    (format t "~&; Loading stuff from ~S.~%" stream))
-  (let* ((*fasl-file* stream)
-	 (*current-fop-table* (pop *free-fop-tables*))
-	 (*current-fop-table-size* ())
-	 (*current-fop-table-index* 0)
-	 (*fop-stack-pointer-on-entry* *fop-stack-pointer*))
-    (if (null *current-fop-table*)
-	(setq *current-fop-table* (make-array 1000)))
-    (setq *current-fop-table-size*
-	  (length (the simple-vector *current-fop-table*)))
-    (unwind-protect 
-      (do ((loaded-group (load-group stream) (load-group stream)))
-	  ((not loaded-group)))
-      (setq *fop-stack-pointer* *fop-stack-pointer-on-entry*)
-      ;;
-      ;; Nil out the table, so we don't hold onto garbage.
-      (let ((tab *current-fop-table*))
-	(dotimes (i *current-fop-table-index*)
-	  (declare (fixnum i))
-	  (setf (svref tab i) nil))
-	(push tab *free-fop-tables*))
-      ;;
-      ;; Ditto for the stack...
-      (dotimes (i *fop-stack-pointer-on-entry*)
-	(declare (fixnum i))
-	(setf (svref *fop-stack* i) nil))))
-  t)
-
-#|
-
-(defvar *fop-counts* (make-array 256 :initial-element 0))
-(defvar *fop-times* (make-array 256 :initial-element 0))
-(defvar *print-fops* nil)
-
-(defun clear-counts ()
-  (fill (the simple-vector *fop-counts*) 0)
-  (fill (the simple-vector *fop-times*) 0)
-  t)
-
-(defun analyze-counts ()
-  (let ((counts ())
-	(total-count 0)
-	(times ())
-	(total-time 0))
-    (macrolet ((breakdown (lvar tvar vec)
-		 `(progn
-		   (dotimes (i 255)
-		     (declare (fixnum i))
-		     (let ((n (svref ,vec i)))
-		       (push (cons (svref fop-codes i) n) ,lvar)
-		       (incf ,tvar n)))
-		   (setq ,lvar (subseq (sort ,lvar #'(lambda (x y)
-						       (> (cdr x) (cdr y))))
-				       0 10)))))
-		 
-      (breakdown counts total-count *fop-counts*)
-      (breakdown times total-time *fop-times*)
-      (format t "Total fop count is ~D~%" total-count)
-      (dolist (c counts)
-	(format t "~30S: ~4D~%" (car c) (cdr c)))
-      (format t "~%Total fop time is ~D~%" (/ (float total-time) 60.0))
-      (dolist (m times)
-	(format t "~30S: ~6,2F~%" (car m) (/ (float (cdr m)) 60.0))))))
-|#
-
-;;; Load-Group  --  Internal
-;;;
-;;; Load-Group returns t if it successfully loads a group from the file,
-;;; or () if EOF was encountered while trying to read from the file.
-;;; Dispatch to the right function for each fop.  Special-case fop-byte-push
-;;; since it is real common.
-;;;
-(defun load-group (file)
-  (when (check-header file)
-    (catch 'group-end
-      (let ((*current-code-format* 'uninitialized-code-format))
-	(loop
-	 (let ((byte (read-byte file)))
-	   (if (eql byte 3)
-	       (let ((index *fop-stack-pointer*))
-		 (when (zerop index)
-		   (grow-fop-stack)
-		   (setq index *fop-stack-pointer*))
-		 (decf index)
-		 (setq *fop-stack-pointer* index)
-		 (setf (svref *fop-stack* index)
-		       (svref *current-fop-table* (read-byte file))))
-	       (funcall (svref fop-functions byte)))))))))
-
-;;; Check-Header returns t if t succesfully read a header from the file,
-;;; or () if EOF was hit before anything was read.  An error is signaled
-;;; if garbage is encountered.
-
-(defun check-header (file)
-  (let ((byte (read-byte file NIL '*eof*)))
-    (cond ((eq byte '*eof*) ())
-	  ((eq byte (char-int #\F))
-	   (do ((byte (read-byte file) (read-byte file))
-		(count 1 (1+ count)))
-	       ((= byte 255) t)
-	     (declare (fixnum byte))
-	     (if (and (< count 9)
-		      (not (eql byte (char-int (schar "FASL FILE" count)))))
-		 (error "Bad FASL file format."))))
-	  (t (error "Bad FASL file format.")))))
-
-
-;;; Load-S-Integer loads a signed integer Length bytes long from the File.
-
-(defun load-s-integer (length)  
-  (declare (fixnum length))
-  (do* ((index length (1- index))
-	(byte 0 (read-byte *fasl-file*))
-	(result 0 (+ result (ash byte bits)))
-	(bits 0 (+ bits 8)))
-       ((= index 0)
-	(if (logbitp 7 byte)	; look at sign bit
-	    (- result (ash 1 bits))
-	    result))
-    (declare (fixnum index byte bits))))
-
-;;; Sloload:
-
-;;; Something not EQ to anything read from a file:
-
-(defconstant load-eof-value '(()))
-
-;;; Sloload loads a text file into the given Load-Package.
-
-(defun sloload (stream)
-  (when *load-verbose*
-    (format t "~&; Loading stuff from ~S.~%" stream))
-  (do ((sexpr (read stream nil load-eof-value)
-	      (read stream nil load-eof-value)))
-      ((eq sexpr load-eof-value))
-    (if *load-print-stuff*
-	(format t "~&; ~S~%" (eval sexpr))
-	(eval sexpr))))))
-
-;;; Load:
-
-(defun load (filename &key ((:verbose *load-verbose*) *load-verbose*)
-		      ((:print *load-print-stuff*) *load-print-stuff*)
-		      (if-does-not-exist :error))
-  "Loads the file named by Filename into the Lisp environment.  See manual
-   for details."
-  (let ((*package* *package*))
-    (if (streamp filename)
-	(if (equal (stream-element-type filename) '(unsigned-byte 8))
-	    (fasload filename)
-	    (sloload filename))
-	(let* ((pn (merge-pathnames (pathname filename)
-				    *default-pathname-defaults*))
-	       (tn (probe-file pn)))
-	  (cond
-	   (tn
-	    (if (or (string-equal (pathname-type tn) "nfasl")
-		    (string-equal (pathname-type tn) "fasl"))
-		(with-open-file (file tn
-				      :direction :input
-				      :element-type '(unsigned-byte 8))
-		  (fasload file))
-		(with-open-file (file tn :direction :input)
-		  (sloload file)))
-	    t)
-	   ((pathname-type pn)
-	    (let ((stream (open pn :direction :input
-				:if-does-not-exist if-does-not-exist)))
-	      (when stream
-		(sloload stream)
-		(close stream)
-		t)))
-	   (t
-	    (let* ((srcn (make-pathname :type "lisp" :defaults pn))
-		   (src (probe-file srcn))
-		   (objn (make-pathname :type "nfasl" :defaults pn))
-		   (obj (probe-file objn)))
-	      (cond
-	       (obj
-		(cond ((and src (> (file-write-date src)
-				   (file-write-date obj)))
-		       (case *load-if-source-newer*
-			 (:load-object
-			  (warn "Loading object file ~A, which is~%  ~
-			         older than the presumed source, ~A."
-				(namestring obj)
-				(namestring src))
-			  (load obj))
-			 (:load-source
-			  (warn "Loading source file ~A, which is~%  ~
-			         newer than the presumed object file, ~A."
-				(namestring src)
-				(namestring obj))
-			  (load src))
-			 (:compile
-			  (compile-file (namestring src))
-			  (load obj))
-			 (:query
-			  (if (y-or-n-p "Load source file ~A which is newer~%  ~
-					 than presumed object file ~A? "
-					(namestring src)
-					(namestring obj))
-			      (load src)
-			      (load obj)))
-			 (T (error "*Load-if-source-newer* contains ~A which is not one of:~%  ~
-			            :load-object, :load-source, :compile, or :query."
-				   *load-if-source-newer*))))
-		      (T (load obj))))
-	       (t
-		(load srcn :if-does-not-exist if-does-not-exist))))))))))
-
-
-;;;; Actual FOP definitions:
-
-(define-fop (fop-nop 0 :nope))
-(define-fop (fop-pop 1 nil) (push-table (pop-stack)))
-(define-fop (fop-pop-for-effect 65 nil) (pop-stack))
-(define-fop (fop-push 2) (svref *current-fop-table* (read-arg 4)))
-(define-fop (fop-byte-push 3) (svref *current-fop-table* (read-arg 1)))
-
-(define-fop (fop-empty-list 4) ())
-(define-fop (fop-truth 5) t)
-(define-fop (fop-misc-trap 66)
-	    (%primitive make-immediate-type 0 lisp::%trap-type))
-
-(define-fop (fop-character 68)
-  (int-char (read-arg 3)))
-(define-fop (fop-short-character 69)
-  (code-char (read-arg 1)))
-
-(define-fop (fop-structure 79)
-  (%primitive set-vector-subtype (pop-stack) 1))
-
-(define-fop (fop-end-group 64 :nope) (throw 'group-end t))
-(define-fop (fop-end-header 255)
-  (error "Fop-End-Header was executed???"))
-
-(define-fop (fop-normal-load 81 :nope))
-(define-fop (fop-maybe-cold-load 82 :nope)
-  (when *in-cold-load*
-    (setq fop-functions cold-fop-functions)))
-
-(define-fop (fop-static-heap 60 :nope))
-(define-fop (fop-dynamic-heap 61 :nope))
-(define-fop (fop-read-only-heap 67 :nope))
-
-(define-fop (fop-verify-table-size 62 :nope)
-  (if (/= *current-fop-table-index* (read-arg 4))
-      (error "Fasl table of improper size.  Bug!")))
-(define-fop (fop-verify-empty-stack 63 :nope)
-  (if (/= *fop-stack-pointer* *fop-stack-pointer-on-entry*)
-      (error "Fasl stack not empty.  Bug!")))
-
-;;;; Loading symbols:
-
-(defvar *load-symbol-buffer* (make-string 100))
-(defvar *load-symbol-buffer-size* 100)
-   
-(macrolet ((frob (name code name-size package)
-	     (let ((n-package (gensym))
-		   (n-size (gensym))
-		   (n-buffer (gensym)))
-	       `(define-fop (,name ,code)
-		  (prepare-for-fast-read-byte *fasl-file*
-		    (let ((,n-package ,package)
-			  (,n-size (fast-read-u-integer ,name-size)))
-		      (when (> ,n-size *load-symbol-buffer-size*)
-			(setq *load-symbol-buffer*
-			      (make-string (setq *load-symbol-buffer-size*
-						 (* ,n-size 2)))))
-		      (done-with-fast-read-byte)
-		      (let ((,n-buffer *load-symbol-buffer*))
-			(read-n-bytes *fasl-file* ,n-buffer 0 ,n-size)
-			(push-table (intern* ,n-buffer ,n-size ,n-package)))))))))
-  (frob fop-symbol-save 6 4 *package*)
-  (frob fop-small-symbol-save 7 1 *package*)
-  (frob fop-lisp-symbol-save 75 4 *lisp-package*)
-  (frob fop-lisp-small-symbol-save 76 1 *lisp-package*)
-  (frob fop-keyword-symbol-save 77 4 *keyword-package*)
-  (frob fop-keyword-small-symbol-save 78 1 *keyword-package*)
-
-  (frob fop-symbol-in-package-save 8 4
-    (svref *current-fop-table* (fast-read-u-integer 4)))
-  (frob fop-small-symbol-in-package-save 9 1
-    (svref *current-fop-table* (fast-read-u-integer 4)))
-  (frob fop-symbol-in-byte-package-save 10 4
-    (svref *current-fop-table* (fast-read-u-integer 1)))
-  (frob fop-small-symbol-in-byte-package-save 11 1
-    (svref *current-fop-table* (fast-read-u-integer 1))))
-
-(clone-fop (fop-uninterned-symbol-save 12)
-	   (fop-uninterned-small-symbol-save 13)
-  (let* ((arg (clone-arg))
-	 (res (make-string arg)))
-    (read-n-bytes *fasl-file* res 0 arg)
-    (push-table (make-symbol res))))
-
-(define-fop (fop-package 14)
-  (let ((name (pop-stack)))
-    (or (find-package name)
-	(error "The package ~S does not exist." name))))
-
-;;;; Loading numbers:
-
-(clone-fop (fop-integer 33)
-	   (fop-small-integer 34)
-  (load-s-integer (clone-arg)))
-
-(define-fop (fop-word-integer 35)
-  (prepare-for-fast-read-byte *fasl-file*
-    (prog1
-     (fast-read-s-integer 4)
-     (done-with-fast-read-byte))))
-(define-fop (fop-byte-integer 36)
-  (prepare-for-fast-read-byte *fasl-file*
-    (prog1
-     (fast-read-s-integer 1)
-     (done-with-fast-read-byte))))
-
-(define-fop (fop-ratio 70)
-  (let ((den (pop-stack)))
-    (%primitive make-ratio (pop-stack) den)))
-
-(define-fop (fop-complex 71)
-  (let ((im (pop-stack)))
-    (%primitive make-complex (pop-stack) im)))
-
-(define-fop (fop-float 45)
-  (let* ((n (read-arg 1))
-	 (exponent (load-s-integer (ceiling n 8)))
-	 (m (read-arg 1))
-	 (mantissa (load-s-integer (ceiling m 8)))
-	 (number (cond ((or (> n 9) (> m 32))
-			(coerce mantissa 'long-float))
-		       ((> m 21)
-			(coerce mantissa 'single-float))
-		       (T (coerce mantissa 'short-float)))))
-    (multiple-value-bind (f ex s) (decode-float number)
-      (declare (ignore ex))
-      (* s (scale-float f exponent)))))
-
-;;;; Loading lists:
-
-(define-fop (fop-list 15)
-  (do ((res () (cons (pop-stack) res))
-       (n (read-arg 1) (1- n)))
-      ((zerop n) res)))
-
-(define-fop (fop-list* 16)
-  (do ((res (pop-stack) (cons (pop-stack) res))
-       (n (read-arg 1) (1- n)))
-      ((zerop n) res)))
-
-(macrolet ((frob (name op fun n)
-	     `(define-fop (,name ,op)
-		(call-with-popped-things ,fun ,n))))
-
-  (frob fop-list-1 17 list 1)
-  (frob fop-list-2 18 list 2)
-  (frob fop-list-3 19 list 3)
-  (frob fop-list-4 20 list 4)
-  (frob fop-list-5 21 list 5)
-  (frob fop-list-6 22 list 6)
-  (frob fop-list-7 23 list 7)
-  (frob fop-list-8 24 list 8)
-
-  (frob fop-list*-1 25 list* 2)
-  (frob fop-list*-2 26 list* 3)
-  (frob fop-list*-3 27 list* 4)
-  (frob fop-list*-4 28 list* 5)
-  (frob fop-list*-5 29 list* 6)
-  (frob fop-list*-6 30 list* 7)
-  (frob fop-list*-7 31 list* 8)
-  (frob fop-list*-8 32 list* 9))
-
-
-;;;; Loading arrays:
-;;;
-
-(clone-fop (fop-string 37)
-	   (fop-small-string 38)
-  (let* ((arg (clone-arg))
-	 (res (make-string arg)))
-    (read-n-bytes *fasl-file* res 0 arg)
-    res))
-
-(clone-fop (fop-vector 39)
-	   (fop-small-vector 40)
-  (let* ((size (clone-arg))
-	 (res (make-array size)))
-    (declare (fixnum size))
-    (do ((n (1- size) (1- n)))
-	((minusp n))
-      (setf (svref res n) (pop-stack)))
-    res))
-
-(clone-fop (fop-uniform-vector 41)
-	   (fop-small-uniform-vector 42)
-  (make-array (clone-arg) :initial-element (pop-stack)))
-
-(define-fop (fop-array 83)
-  (let* ((rank (read-arg 4))
-	 (vec (pop-stack))
-	 (size (+ rank %array-first-dim-slot))
-	 (length (length vec))
-	 (res (%primitive alloc-array rank)))
-    (declare (simple-array vec))
-    (set-array-header res vec length length 0
-		      (do ((i (1- size) (1- i))
-			   (dimensions () (cons (pop-stack) dimensions)))
-			  ((< i %array-first-dim-slot) dimensions))
-		      nil)
-    res))
-
-
-;;; Fop-Int-Vector  --  Internal
-;;;
-;;;    Load an I-Vector using the Guy Steele memorial faslop.  If there
-;;; is no space at the end of a group, then we can read it using
-;;; Read-N-Bytes.  All vectors dumped by our compiler should be loadable
-;;; in this way.  If the other cases don't work, we may never know...
-;;;
-(define-fop (fop-int-vector 43)
-  (prepare-for-fast-read-byte *fasl-file*
-    (let* ((n (fast-read-u-integer 4))
-	   (size (fast-read-byte))
-	   (count (fast-read-byte))
-	   (res (make-array n :element-type `(unsigned-byte ,size))))
-      (multiple-value-bind (ints-per-entry extra)
-			   (truncate (* count 8) size)
-	(cond ((and (zerop extra) (<= size 16))
-	       (done-with-fast-read-byte)
-	       (read-n-bytes *fasl-file* res 0
-			     (* count (ceiling n ints-per-entry))))
-	      ((= ints-per-entry 1)
-	       (dotimes (i n)
-		 (setf (aref res i) (fast-read-variable-u-integer count)))
-	       (done-with-fast-read-byte))
-	      (t
-	       (let ((i 0))
-		 (loop
-		   (when (= i n) (return))
-		   (let ((byte (fast-read-byte)))
-		     (dotimes (j ints-per-entry)
-		       (setf (aref res i) (ldb (byte size (* size j)) byte))
-		       (incf i)
-		       (when (= i n) (return))))))
-	       (done-with-fast-read-byte))))
-      res)))
-
-(define-fop (fop-uniform-int-vector 44)
-  (prepare-for-fast-read-byte *fasl-file*
-    (let* ((n (fast-read-u-integer 4))
-	   (size (fast-read-byte))
-	   (value (fast-read-variable-u-integer (ceiling size 8))))
-      (done-with-fast-read-byte)
-      (make-array n :element-type `(unsigned-byte ,size)
-		  :initial-element value))))
-
-(define-fop (fop-alter 52 nil)
-  (let ((index (read-arg 1))
-	(newval (pop-stack))
-	(object (pop-stack)))
-    (declare (fixnum index))
-    (typecase object
-      (list (case index
-	      (0 (rplaca object newval))
-	      (1 (rplacd object newval))
-	      (t (error "~S: Bad index for FaslOP Alter.  Bug!"))))
-      (symbol (case index
-		(0 (set object newval))
-		(1 (setf (symbol-function object) newval))
-		(2 (setf (symbol-plist object) newval))
-		(t (error "~S: Bad index for FaslOP Alter.  Bug!"))))
-      (array (setf (aref object index) newval))
-      (t (error "~S: Bad object for FaslOP Alter.  Bug!")))))
-
-(define-fop (fop-eval 53)
-  (let ((result (eval (pop-stack))))
-    (when *load-print-stuff*
-      (format t "~&; ~S~%" result))
-    result))
-
-(define-fop (fop-eval-for-effect 54 nil)
-  (let ((result (eval (pop-stack))))
-    (when *load-print-stuff*
-      (format t "~&; ~S~%" result))))
-
-(define-fop (fop-funcall 55)
-  (let ((arg (read-arg 1)))
-    (if (zerop arg)
-	(funcall (pop-stack))
-	(do ((args () (cons (pop-stack) args))
-	     (n arg (1- n)))
-	    ((zerop n) (apply (pop-stack) args))))))
-
-(define-fop (fop-funcall-for-effect 56 nil)
-  (let ((arg (read-arg 1)))
-    (if (zerop arg)
-	(funcall (pop-stack))
-	(do ((args () (cons (pop-stack) args))
-	     (n arg (1- n)))
-	    ((zerop n) (apply (pop-stack) args))))))
-
-;;;; Fixing up circularities.
-(define-fop (fop-rplaca 200 nil)
-  (let ((obj (svref *current-fop-table* (read-arg 4)))
-	(idx (read-arg 4))
-	(val (pop-stack)))
-    (setf (car (nthcdr idx obj)) val)))
-
-
-(define-fop (fop-rplacd 201 nil)
-  (let ((obj (svref *current-fop-table* (read-arg 4)))
-	(idx (read-arg 4))
-	(val (pop-stack)))
-    (setf (cdr (nthcdr idx obj)) val)))
-
-(define-fop (fop-svset 202 nil)
-  (let* ((obi (read-arg 4))
-	 (obj (svref *current-fop-table* obi))
-	 (idx (read-arg 4))
-	 (val (pop-stack)))
-    (setf (svref obj idx) val)))
-
-(define-fop (fop-nthcdr 203 t)
-  (nthcdr (read-arg 4) (pop-stack)))
-
-;;;; Loading functions:
-
-(define-fop (fop-code-format 57 :nope)
-  (setq *current-code-format* (read-arg 1)))
-
-
-;;; Load-Code loads a code object.  NItems objects are popped off the stack for
-;;; the boxed storage section, then Size bytes of code are read in.  This must
-;;; be done WITHOUT-GCING, since GC only recognizes code object references that
-;;; appear in a function object.  If a GC happened before we stored the code
-;;; object, the code would disappear.
-;;;
-(defmacro load-code (nitems size)
-  `(without-gcing
-     (let ((box-num ,nitems)
-	   (code-length ,size))
-       (declare (fixnum box-num code-length))
-       (let ((function (%primitive alloc-function box-num)))
-	 (%primitive set-vector-subtype function %function-constants-subtype)
-	 (do ((index (1- box-num) (1- index)))
-	     ((minusp index))
-	   (declare (fixnum index))
-	   (%primitive header-set function index (pop-stack)))
-	 (let ((code (%primitive alloc-code code-length)))
-	   (read-n-bytes *fasl-file* code 0 code-length)
-	   (%primitive header-set function %function-code-slot code))
-	 (when *load-print-stuff*
-	   (format t "~&; ~S~%" function))
-	 function))))
-
-(define-fop (fop-code 58)
-  (if (eql *current-code-format* %fasl-code-format)
-      (load-code (read-arg 4) (read-arg 4))
-      (error "~A has an incompatible fasl file format.~@
-               You must recompile the source code."
-	     *fasl-file*)))
-
-
-(define-fop (fop-small-code 59)
-  (if (eql *current-code-format* %fasl-code-format)
-      (load-code (read-arg 1) (read-arg 2))
-      (error "~A has an incompatible fasl file format.~@
-               You must recompile the source code."
-	     *fasl-file*)))
-
-
-;;; Now a NOOP except in cold load... 
-(define-fop (fop-fset 74 nil)
-  (pop-stack)
-  (pop-stack))
-
-
-;;; Modify a slot in a Constants object.
-;;;
-(clone-fop (fop-alter-code 140 nil) (fop-byte-alter-code 141)
-  (let ((value (pop-stack))
-	(code (pop-stack))
-	(index (clone-arg)))
-    (%primitive header-set code index value)))
-
-
-;;; Kind of like Load-Code, except that we set the Code and Constants
-;;; slots from the Constants object that is our first stack argument.  The
-;;; subtype is set to the second stack argument.
-;;;
-(define-fop (fop-function-entry 142)
-  (let* ((box-num (read-arg 1))
-	 (function (%primitive alloc-function box-num)))
-    ;;
-    ;; Pop boxed things, storing them in the allocated entry object.
-    (do ((index (1- box-num) (1- index)))
-	((minusp index))
-      (%primitive header-set function index (pop-stack)))
-    ;;
-    ;; Set the subtype of the entry object.
-    (%primitive set-vector-subtype function (pop-stack))
-    ;;
-    ;; Set code and constants slots in the entry.
-    (let* ((constants (pop-stack))
-	   (code (%primitive header-ref constants %function-code-slot)))
-      (%primitive header-set function %function-code-slot code)
-      (%primitive header-set function %function-entry-constants-slot
-		  constants))
-
-    function))
-
-
-
-(define-fop (fop-user-miscop-fixup 134)
-  (let* ((miscop-name (pop-stack))
-	 (function-object (pop-stack))
-	 (code (%primitive header-ref function-object %function-code-slot))
-	 (offset (read-arg 4))
-	 (loaded-addr (get miscop-name '%loaded-address)))
-    (unless loaded-addr
-      (error "Miscop ~A is undefined." miscop-name))
-    
-    (let ((hi-addr (logior (ash clc::type-assembler-code
-				clc::type-shift-16)
-			   (logand (ash loaded-addr -16) #xFFFF))))
-      (setf (aref code (+ offset 1)) (logand hi-addr #xFF))
-      (setf (aref code (+ offset 2))
-	    (logand (ash loaded-addr -8) #xFF))
-      (setf (aref code (+ offset 3))
-	    (logand loaded-addr #xFF)))
-
-    function-object))
-
-
-;;;; Loading assembler routines:
-;;;
-
-;;; Allocate-Assembler-Code  --  Internal
-;;;
-;;;    Allocate some stuff out of assembler code space.
-;;;
-(defun allocate-assembler-code (bytes)
-  (let* ((idx (ash %assembler-code-type %alloc-ref-type-shift))
-	 (free (alloc-ref idx))
-	 (new (+ free bytes)))
-    (prog1
-      (%primitive make-immediate-type free %assembler-code-type)
-      (%primitive 16bit-system-set alloctable-address idx (ash new -16))
-      (%primitive 16bit-system-set alloctable-address (1+ idx)
-		  (logand new #xFFFF)))))
-
-(define-fop (fop-assembler-routine 130)
-  (let* ((code-length (read-arg 4))
-	 (buffer (make-array code-length :element-type '(unsigned-byte 8)))
-	 (code (allocate-assembler-code code-length)))
-    (declare (fixnum code-length))
-    (read-n-bytes *fasl-file* buffer 0 code-length)
-    (%primitive byte-blt buffer 0 code 0 code-length)
-    code))
-
-;;; A list of the miscop definitions which have been loaded but not
-;;; resolved.  Each element is a cons (name . code-ptr).
-;;;
-(defvar *miscop-definitions* ())
-
-
-;;; Recall that the format of a reference is (How Label Location),
-;;; where How is one of JI, BI, BA, or L, Label is the label's name, and
-;;; Location is the location of the reference.  These things are stored on
-;;; the list *external-references* as (Name . References), where Name is
-;;; the name of the referencing routine, and References is a list of references
-;;; in the above format.
-;;;
-(defvar *external-references* ())
-(defvar *user-defined-miscops* ())
-
-(define-fop (fop-fixup-miscop-routine 131 nil)
-  (let* ((external-references (pop-stack))
-	 (external-labels (pop-stack))
-	 (name (pop-stack))
-	 (code (pop-stack))
-	 (start (%primitive make-immediate-type code %+-fixnum-type)))
-    (dolist (lab external-labels)
-      (setf (get (car lab) '%loaded-address) (+ (ash (cdr lab) 1) start)))
-    (push (cons name external-references) *external-references*)
-    (push (cons name code) *miscop-definitions*)))
-
-(define-fop (fop-fixup-user-miscop-routine 133 nil)
-  (let* ((external-references (pop-stack))
-	 (external-labels (pop-stack))
-	 (name (pop-stack))
-	 (code (pop-stack))
-	 (start (%primitive make-immediate-type code %+-fixnum-type)))
-    (dolist (lab external-labels)
-      (setf (get (car lab) '%loaded-address) (+ (ash (cdr lab) 1) start)))
-    (push (cons name external-references) *external-references*)
-    (pushnew name *user-defined-miscops*)
-    (setf (get name 'user-miscop) t)))
-
-(define-fop (fop-fixup-assembler-routine 132 nil)
-  (let* ((external-references (pop-stack))
-	 (external-labels (pop-stack))
-	 (name (pop-stack))
-	 (code (pop-stack))
-	 (start (%primitive make-immediate-type code %+-fixnum-type)))
-    (dolist (lab external-labels)
-      (setf (get (car lab) '%loaded-address) (+ (ash (cdr lab) 1) start)))
-    (push (cons name external-references) *external-references*)))
-
-;;; Resolving all the assembler routines' references.
-
-;;; Patch-Instruction  --  Internal
-;;;
-;;;    Used to patch an assembler code object.  Hi-var and lo-var are
-;;; bound to the values of the high and low halfwords in the instruction.
-;;; The values may by changed by setting the variables.
-;;;
-(defmacro patch-instruction ((hi-var lo-var code offset) &body body)
-  `(let ((,hi-var (%primitive 16bit-system-ref ,code ,offset))
-	 (,lo-var (%primitive 16bit-system-ref ,code (1+ ,offset))))
-     (multiple-value-prog1
-      (progn ,@body)
-      (%primitive 16bit-system-set ,code ,offset ,hi-var)
-      (%primitive 16bit-system-set ,code (1+ ,offset) ,lo-var))))
-
-;;; Resolve-Loaded-Assembler-References  --  Public
-;;;
-;;;    Fix up the recorded external references and define the miscops.
-;;;
-(defun resolve-loaded-assembler-references ()
-  "This function resolves external label references in loaded assembler
-  routines.  It should be called after assembler files have been loaded.
-  Miscop definitions do not take effect until this function is called."
-  (dolist (reflist *external-references*)
-    (let* ((code-byte-offset (get (car reflist) '%loaded-address))
-	   (code-halfword-offset (ash code-byte-offset -1))
-	   (address (%primitive make-immediate-type code-byte-offset
-				%assembler-code-type)))
-      (dolist (refs (cdr reflist))
-	(let ((how (car refs))
-	      (label (get (cadr refs) '%loaded-address))
-	      (location (caddr refs)))
-	  (unless label
-	    (error "~A references ~A, which has not been defined.~%"
-		   (car reflist) (cadr refs)))
-	  (let ((offset (- (- (ash label -1) code-halfword-offset) location)))
-	    (ecase how
-	      (clc::ji
-	       (unless (<= #x-80 offset #x7F)
-		 (error "Offset #X~X out of JI range for ~A to reference ~A.~%"
-			offset (car reflist) (cadr refs)))
-	       (patch-instruction (hi lo address location)
-		 (setf (ldb (byte 8 0) hi) offset)))
-	      (clc::bi
-	       (unless (<= #x-80000 offset #x7FFFF)
-		 (error "Offset #X~X out of BI range for ~A to reference ~A.~%"
-			offset (car reflist) (cadr refs)))
-	       (patch-instruction (hi lo address location)
-		 (setf (ldb (byte 4 0) hi) (ash offset -16))
-		 (setq lo (logand offset #xFFFF))))
-	      (clc::ba (error "I can't resolve a BA reference yet.~%"))
-	      (clc::l (error "I can't resolve an L reference yet.~%"))))))))
-  (setq *external-references* ())
-
-  (dolist (mo *miscop-definitions*)
-    (let* ((name (intern (symbol-name (car mo)) (find-package "COMPILER")))
-	   (index (get name 'clc::transfer-vector-index)))
-      (if index
-	  (%primitive write-control-stack
-		      (%primitive make-immediate-type (ash index 2)
-				  %assembler-code-type)
-		      (cdr mo))
-	  (pushnew name *user-defined-miscops*))))
-  (setq *miscop-definitions* ()))
-
-(proclaim '(notinline read-byte))
diff --git a/code/machdef.lisp b/code/machdef.lisp
deleted file mode 100644
index 2d3471e46ee06571de4a520d407b654a9bf3300d..0000000000000000000000000000000000000000
--- a/code/machdef.lisp
+++ /dev/null
@@ -1,105 +0,0 @@
-;;; -*- Log: code.log; Package: Mach -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; Record definitions needed for the interface to Mach.
-;;;
-(in-package 'mach)
-(export '(msg-simplemsg msg-msgsize msg-msgtype msg-localport msg-remoteport
-			msg-id sigmask with-trap-arg-block))
-
-(defrecord Msg
-  (Reserved1 (unsigned-byte 8) 8)
-  (Reserved2 (unsigned-byte 8) 8)
-  (Reserved3 (unsigned-byte 8) 8)
-  (Reserved4 (unsigned-byte 7) 7)
-  (SimpleMsg boolean 1)
-  (MsgSize (signed-byte 32) 32)
-  (MsgType (signed-byte 32) 32)
-  (LocalPort port 32)
-  (RemotePort port 32)
-  (ID (signed-byte 32) 32))
-
-(defrecord timeval
-  (seconds (unsigned-byte 32) (long-words 1))
-  (useconds (signed-byte 32) (long-words 1)))
-
-(defalien timeval timeval (record-size 'timeval))
-
-(defrecord timezone
-  (minuteswest (signed-byte 32) (long-words 1))
-  (dsttime (signed-byte 32) (long-words 1)))
-
-(defalien timezone timezone (record-size 'timezone))
-
-(eval-when (compile load eval)
-(defrecord int1
-  (int (signed-byte 32) (long-words 1)))
-
-(defalien int1 int1 (record-size 'int1))
-
-(defrecord int2
-  (int (signed-byte 32) (long-words 1)))
-
-(defalien int2 int2 (record-size 'int2))
-
-(defrecord int3
-  (int (signed-byte 32) (long-words 1)))
-
-(defalien int3 int3 (record-size 'int3))
-
-(defrecord sigcontext
-  (onstack (unsigned-byte 32) (long-words 1))
-  (mask (unsigned-byte 32) (long-words 1))
-  (sctx-fpa (unsgined-byte 32) (long-words 1))
-  (sp (unsigned-byte 32) (long-words 1))
-  (fp (unsigned-byte 32) (long-words 1))
-  (ap (unsigned-byte 32) (long-words 1))
-  (iar (unsigned-byte 32) (long-words 1))
-  (icscs (unsigned-byte 32) (long-words 1)))
-(defalien sigcontext sigcontext (record-size 'sigcontext))
-
-
-(defrecord tchars
-  (intrc (signed-byte 8) (bytes 1))
-  (quitc (signed-byte 8) (bytes 1))
-  (startc (signed-byte 8) (bytes 1))
-  (stopc (signed-byte 8) (bytes 1))
-  (eofc (signed-byte 8) (bytes 1))
-  (brkc (signed-byte 8) (bytes 1)))
-(defalien tchars tchars (record-size 'tchars))
-
-(defrecord ltchars
-  (suspc (signed-byte 8) (bytes 1))
-  (dsuspc (signed-byte 8) (bytes 1))
-  (rprntc (signed-byte 8) (bytes 1))
-  (flushc (signed-byte 8) (bytes 1))
-  (werasc (signed-byte 8) (bytes 1))
-  (lnextc (signed-byte 8) (bytes 1)))
-(defalien ltchars ltchars (record-size 'ltchars))
-
-); eval-when (compile load eval)
-
-
-#-new-compiler
-(eval-when (compile)
-  (setq lisp::*bootstrap-defmacro* t))
-
-(defmacro sigmask (signal)
-  "Returns a mask given a signal." 
-  `(ash 1 (1- ,(unix-signal-number signal))))
-
-(defmacro with-trap-arg-block (arg-var alien-var &body forms)
-  `(progn (unless *free-trap-arg-blocks* (alloc-trap-arg-block))
-	  (let ((*free-trap-arg-blocks* (cdr *free-trap-arg-blocks*))
-		(,arg-var (car *free-trap-arg-blocks*)))
-	    (alien-bind ((,alien-var ,arg-var ,arg-var T))
-			,@forms))))
-#-new-compiler
-(eval-when (compile)
-  (setq lisp::*bootstrap-defmacro* nil))
diff --git a/code/misc.lisp b/code/misc.lisp
deleted file mode 100644
index f6b13dffd571703acf2b129c7f1ce3d74c11439c..0000000000000000000000000000000000000000
--- a/code/misc.lisp
+++ /dev/null
@@ -1,136 +0,0 @@
-;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; Assorted miscellaneous functions for Spice Lisp.
-;;;
-;;; Written and maintained mostly by Skef Wholey and Rob MacLachlan.
-;;; Scott Fahlman, Dan Aronson, and Steve Handerson did stuff here, too.
-;;;
-(in-package "LISP")
-(export '(documentation *features* common variable room
-	  lisp-implementation-type lisp-implementation-version machine-type
-	  machine-version machine-instance software-type software-version
-	  short-site-name long-site-name dribble))
-
-
-(defun documentation (name doc-type)
-  "Returns the documentation string of Doc-Type for Name, or NIL if
-  none exists.  System doc-types are VARIABLE, FUNCTION, STRUCTURE, TYPE,
-  and SETF."
-  (case doc-type
-    (variable (info variable documentation name))
-    (function (info function documentation name))
-    (structure
-     (when (eq (info type kind name) :structure)
-       (info type documentation name)))
-    (type
-     (info type documentation name))
-    (setf (info setf documentation name))
-    (t
-     (cdr (assoc doc-type (info random-documentation stuff name))))))
-
-(defun %set-documentation (name doc-type string)
-  (case doc-type
-    (variable (setf (info variable documentation name) string))
-    (function (setf (info function documentation name) string))
-    (structure
-     (unless (eq (info type kind name) :structure)
-       (error "~S is not the name of a structure type." name))
-     (setf (info type documentation name) string))
-    (type (setf (info type documentation name) string))
-    (setf (setf (info setf documentation name) string))
-    (t
-     (let ((pair (assoc doc-type (info random-documentation stuff name))))
-       (if pair
-	   (setf (cdr pair) string)
-	   (push (cons doc-type string)
-		 (info random-documentation stuff name))))))
-  string)
-
-(defvar *features* '(:common :cmu :mach :ibm-rt-pc :new-compiler)
-  "Holds a list of symbols that describe features provided by the
-   implementation.")
-
-(defun featurep (x)
-  "If X is an atom, see if it is present in *FEATURES*.  Also
-  handle arbitrary combinations of atoms using NOT, AND, OR."
-  (cond ((atom x) (memq x *features*))
-	((eq (car x) ':not) (not (featurep (cadr x))))
-	((eq (car x) ':and)
-	 (every #'featurep (cdr x)))
-	((eq (car x) ':or)
-	 (some #'featurep (cdr x)))
-	(t nil)))
-
-
-
-;;; Other Environment Inquiries.
-
-(defun lisp-implementation-type ()
-  "Returns a string describing the implementation type."
-  "CMU Common Lisp")
-
-(defun lisp-implementation-version ()
-  "Returns a string describing the implementation version."
-  *lisp-implementation-version*)
-
-(defun machine-type ()
-  "Returns a string describing the type of the local machine."
-  "IBM RT PC")
-
-(defun machine-version ()
-  "Returns a string describing the version of the local machine."
-  (let ((version (system:%primitive 16bit-system-ref
-				    (int-sap
-				     (+ (ash clc::romp-data-base 16)
-					clc::floating-point-hardware-available))
-				    1)))
-    (if (or (not (= (logand version clc::float-mc68881) 0))
-	    (not (= (logand version clc::float-afpa) 0)))
-	"IBM RT PC/APC"
-	"IBM RT PC")))
-
-(defun machine-instance ()
-  "Returns a string giving the name of the local machine."
-  (mach::unix-gethostname))
-
-(defun software-type ()
-  "Returns a string describing the supporting software."
-  "MACH/4.3BSD")
-
-(defun software-version ()
-  "Returns a string describing version of the supporting software."
-  NIL)
-
-(defun short-site-name ()
-  "Returns a string with the abbreviated site name."
-  "CMU-CSD")
-
-(defun long-site-name ()
-  "Returns a string with the long form of the site name."
-  "Carnegie-Mellon University Computer Science Department")
-
-
-
-;;;; Dribble stuff:
-
-(defun dribble (&optional pathname &key (if-exists :append))
-  "With a file name as an argument, dribble opens the file and
-   sends a record of the output to that file.  Without an
-   argument, it closes the open dribble file."
-  (if pathname
-      (with-open-file (f pathname :direction :output  :if-exists if-exists
-			 :if-does-not-exist :create)
-	(catch 'dribble-punt
-	  (let ((*terminal-io*
-		 (make-two-way-stream
-		  (make-echo-stream *terminal-io* f)
-		  (make-broadcast-stream *terminal-io* f))))
-	    (%top-level))))
-      (throw 'dribble-punt nil)))
diff --git a/code/package.lisp b/code/package.lisp
deleted file mode 100644
index d175370caf0d8da2cf015363b878dbf2cc11a419..0000000000000000000000000000000000000000
--- a/code/package.lisp
+++ /dev/null
@@ -1,1101 +0,0 @@
-;;; -*- Log: code.log; Package: Lisp -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;     Package stuff and stuff like that.
-;;;
-;;; Re-Written by Rob MacLachlan.  Earlier version written by
-;;; Lee Schumacher.  Apropos & iteration macros courtesy of Skef Wholey.
-;;;
-(in-package 'lisp)
-(export '(package packagep *package* make-package in-package find-package
-	  package-name package-nicknames rename-package
-	  package-use-list package-used-by-list package-shadowing-symbols
-	  list-all-packages intern find-symbol unintern export
-	  unexport import shadowing-import shadow use-package
-	  unuse-package find-all-symbols do-symbols
-	  do-external-symbols do-all-symbols apropos apropos-list))
-
-
-(in-package "EXTENSIONS")
-(export '(*keyword-package* *lisp-package*))
-(in-package 'lisp)
-
-
-(defstruct (package
-	    (:constructor internal-make-package)
-	    (:predicate packagep)
-	    (:print-function
-	     (lambda (s stream d)
-	       (declare (ignore d) (stream stream))
-	       (multiple-value-bind (iu it) (internal-symbol-count s)
-		 (multiple-value-bind (eu et) (external-symbol-count s)
-		   (format stream
-			   "#<The ~A package, ~D/~D internal, ~D/~D external>"
-			   (package-name s) iu it eu et))))))
-  "Standard structure for the description of a package.  Consists of 
-   a list of all hash tables, the name of the package, the nicknames of
-   the package, the use-list for the package, the used-by- list, hash-
-   tables for the internal and external symbols, and a list of the
-   shadowing symbols."
-  (tables (list nil))	; A list of all the hashtables for inherited symbols.
-  name			; The string name of the package.
-  nicknames		; List of nickname strings.
-  (use-list ())		; List of packages we use.
-  (used-by-list ())	; List of packages that use this package.
-  internal-symbols	; Hashtable of internal symbols.
-  external-symbols	; Hashtable of external symbols.
-  (shadowing-symbols ())) ; List of shadowing symbols.
-
-(defvar *package* () "The current package.")
-
-;;; An equal hashtable from package names to packages.
-;;;
-(defvar *package-names* (make-hash-table :test #'equal))
-
-
-;;; Lots of people want the keyword package and Lisp package without a lot
-;;; of fuss, so we give them their own variables.
-;;;
-(defvar *lisp-package*)
-(defvar *keyword-package*)
-
-
-;;; This magical variable is T during initialization so Use-Package's of packages
-;;; that don't yet exist quietly win.  Such packages are thrown onto the list
-;;; *Deferred-Use-Packages* so that this can be fixed up later.
-
-(defvar *in-package-init* nil)
-(defvar *deferred-use-packages* nil)
-
-;;; Find-Package  --  Public
-;;;
-;;;
-(defun find-package (name)
-  "Find the package having the specified name."
-  (values (gethash (string name) *package-names*)))
-
-;;; Package-Listify  --  Internal
-;;;
-;;;    Return a list of packages given a package-or-string-or-symbol or
-;;; list thereof, or die trying.
-;;;
-(defun package-listify (thing)
-  (let ((res ()))
-    (dolist (thing (if (listp thing) thing (list thing)) res)
-      (push (package-or-lose thing) res))))
-
-;;; Package-Or-Lose  --  Internal
-;;;
-;;;    Take a package-or-string-or-symbol and return a package.
-;;;
-(defun package-or-lose (thing)
-  (if (packagep thing)
-      thing
-      (let ((thing (string thing)))
-	(cond ((gethash thing *package-names*))
-	      (t
-	       (cerror "Make this package."
-		       "~S is not the name of a package." thing)
-	       (make-package thing))))))  
-
-;;;; Package-Hashtables
-;;;
-;;;    Packages are implemented using a special kind of hashtable.  It is
-;;; an open hashtable with a parallel 8-bit I-vector of hash-codes.  The
-;;; primary purpose of the hash for each entry is to reduce paging by
-;;; allowing collisions and misses to be detected without paging in the
-;;; symbol and pname for an entry.  If the hash for an entry doesn't
-;;; match that for the symbol that we are looking for, then we can
-;;; go on without touching the symbol, pname, or even hastable vector.
-;;;    It turns out that, contrary to my expectations, paging is a very
-;;; important consideration the design of the package representation.
-;;; Using a similar scheme without the entry hash, the fasloader was
-;;; spending more than half its time paging in INTERN.
-;;;    The hash code also indicates the status of an entry.  If it zero,
-;;; the the entry is unused.  If it is one, then it is deleted.
-;;; Double-hashing is used for collision resolution.
-
-(defstruct (package-hashtable
-	    (:constructor internal-make-package-hashtable ())
-	    (:copier nil)
-	    (:print-function
-	     (lambda (table stream d)
-	       (declare (ignore d))
-	       (format stream
-		       "#<Package-Hashtable: Size = ~D, Free = ~D, Deleted = ~D>"
-		       (package-hashtable-size table)
-		       (package-hashtable-free table)
-		       (package-hashtable-deleted table)))))
-  table		; The g-vector of symbols.
-  hash		; The i-vector of pname hash values.
-  size		; The maximum number of entries allowed.
-  free		; The entries that can be made before we have to rehash.
-  deleted)	; The number of deleted entries.
-
-
-;;; The maximum density we allow in a package hashtable.
-;;;
-(defparameter package-rehash-threshold 3/4)
-
-;;; Entry-Hash  --  Internal
-;;;
-;;;    Compute a number from the sxhash of the pname and the length which
-;;; must be between 2 and 255.
-;;;
-(defmacro entry-hash (length sxhash)
-  `(the fixnum (+ (the fixnum (rem (the fixnum (logxor ,length
-						       ,sxhash
-						       (the fixnum (ash ,sxhash -8))
-						       (the fixnum (ash ,sxhash -16))
-						       (the fixnum (ash ,sxhash -19))))
-				   254))
-		  2)))
-
-;;; Make-Package-Hashtable  --  Internal
-;;;
-;;;    Make a package hashtable having a prime number of entries at least
-;;; as great as (/ size package-rehash-threshold).  If Res is supplied,
-;;; then it is destructively modified to produce the result.  This is
-;;; useful when changing the size, since there are many pointers to
-;;; the hashtable.
-;;;
-(defun make-package-hashtable (size &optional
-				    (res (internal-make-package-hashtable)))
-  (do ((n (logior (truncate size package-rehash-threshold) 1)
-	  (+ n 2)))
-      ((primep n)
-       (setf (package-hashtable-table res)
-	     (make-array n))
-       (setf (package-hashtable-hash res)
-	     (make-array n :element-type '(unsigned-byte 8) :initial-element 0))
-       (let ((size (truncate (* n package-rehash-threshold))))
-	 (setf (package-hashtable-size res) size)
-	 (setf (package-hashtable-free res) size))
-       (setf (package-hashtable-deleted res) 0)
-       res)
-    (declare (fixnum n))))
-
-
-;;; Internal-Symbol-Count, External-Symbols-Count  --  Internal
-;;;
-;;;    Return internal and external symbols.  Used by Genesis and stuff.
-;;;
-(flet ((stuff (table)
-	      (let ((size (the fixnum (- (the fixnum (package-hashtable-size table))
-					 (the fixnum (package-hashtable-deleted table))))))
-		(declare (fixnum size))
-		(values (the fixnum (- size (the fixnum (package-hashtable-free table)))) size))))
-
-  (defun internal-symbol-count (package)
-    (stuff (package-internal-symbols package)))
-
-  (defun external-symbol-count (package)
-    (stuff (package-external-symbols package))))
-
-
-;;; Add-Symbol  --  Internal
-;;;
-;;;    Add a symbol to a package hashtable.  The symbol is assumed
-;;; not to be present.
-;;;
-(defun add-symbol (table symbol)
-  (let* ((vec (package-hashtable-table table))
-	 (hash (package-hashtable-hash table))
-	 (len (length vec))
-	 (sxhash (%primitive sxhash-simple-string (symbol-name symbol)))
-	 (h2 (the fixnum (1+ (the fixnum (rem sxhash
-					      (the fixnum (- len 2))))))))
-    (declare (simple-vector vec)
-	     (type (simple-array (unsigned-byte 8)) hash)
-	     (fixnum len sxhash h2))
-    (cond ((zerop (the fixnum (package-hashtable-free table)))
-	   (make-package-hashtable (the fixnum
-					(* (the fixnum
-						(package-hashtable-size table))
-					   2))
-				   table)
-	   (add-symbol table symbol)
-	   (dotimes (i len)
-	     (declare (fixnum i))
-	     (when (> (the fixnum (aref hash i)) 1)
-	       (add-symbol table (svref vec i)))))
-	  (t
-	   (do ((i (rem sxhash len) (rem (+ i h2) len)))
-	       ((< (the fixnum (aref hash i)) 2)
-		(if (zerop (the fixnum (aref hash i)))
-		    (decf (the fixnum (package-hashtable-free table)))
-		    (decf (the fixnum (package-hashtable-deleted table))))
-		(setf (svref vec i) symbol)
-		(setf (aref hash i)
-		      (entry-hash (length (the simple-string (symbol-name symbol)))
-				  sxhash)))
-	     (declare (fixnum i)))))))
-
-;;; With-Symbol  --  Internal
-;;;
-;;;    Find where the symbol named String is stored in Table.  Index-Var
-;;; is bound to the index, or NIL if it is not present.  Symbol-Var
-;;; is bound to the symbol.  Length and Hash are the length and sxhash
-;;; of String.  Entry-Hash is the entry-hash of the string and length.
-;;;
-(defmacro with-symbol ((index-var symbol-var table string length sxhash
-				  entry-hash)
-		       &body forms)
-  (let ((vec (gensym)) (hash (gensym)) (len (gensym)) (h2 (gensym))
-	(name (gensym)) (name-len (gensym)) (ehash (gensym)))
-    `(let* ((,vec (package-hashtable-table ,table))
-	    (,hash (package-hashtable-hash ,table))
-	    (,len (length ,vec))
-	    (,h2 (1+ (the fixnum (rem (the fixnum ,sxhash)
-				      (the fixnum (- ,len 2)))))))
-       (declare (type (simple-array (unsigned-byte 8)) ,hash)
-		(simple-vector ,vec)
-		(fixnum ,len ,h2))
-       (prog ((,index-var (rem (the fixnum ,sxhash) ,len))
-	      ,symbol-var ,ehash)
-	 (declare (type (or fixnum null) ,index-var))
-	 LOOP
-	 (setq ,ehash (aref ,hash ,index-var))
-	 (cond ((eql ,ehash ,entry-hash)
-		(setq ,symbol-var (svref ,vec ,index-var))
-		(let* ((,name (symbol-name ,symbol-var))
-		       (,name-len (length ,name)))
-		  (declare (simple-string ,name)
-			   (fixnum ,name-len))
-		  (when (and (= ,name-len ,length)
-			     (string= ,string ,name  :end1 ,length
-				      :end2 ,name-len))
-		    (go DOIT))))
-	       ((zerop ,ehash)
-		(setq ,index-var nil)
-		(go DOIT)))
-	 (setq ,index-var (rem (+ ,index-var ,h2) ,len))
-	 (go LOOP)
-	 DOIT
-	 (return (progn ,@forms))))))
-
-;;; Nuke-Symbol  --  Internal
-;;;
-;;;    Delete the entry for String in Table.  The entry must exist.
-;;;
-(defun nuke-symbol (table string)
-  (declare (simple-string string))
-  (let* ((length (length string))
-	 (hash (%primitive sxhash-simple-string string))
-	 (ehash (entry-hash length hash)))
-    (declare (fixnum length hash))
-    (with-symbol (index symbol table string length hash ehash)
-      (setf (aref (package-hashtable-hash table) index) 1)
-      (setf (aref (package-hashtable-table table) index) nil)
-      (incf (package-hashtable-deleted table)))))
-
-;;;; Iteration macros.
-
-;;; Instead of using slow, silly successor functions, we make the iteration
-;;; guys be big PROG's.  Yea!
-
-(eval-when (compile load eval)
-
-(defun make-do-symbols-vars ()
-  `(,(gensym)					; index
-    ,(gensym)					; hash
-    ,(gensym)					; hash-vector
-    ,(gensym)))					; terminus
-
-(defun make-do-symbols-code (vars var hash-table exit-form forms)
-  (let ((index (first vars))
-	(hash-vector (second vars))
-	(hash (third vars))
-	(terminus (fourth vars))
-	(TOP (gensym)))
-    `((setq ,index 0)
-      (setq ,hash-vector (package-hashtable-table ,hash-table))
-      (setq ,hash (package-hashtable-hash ,hash-table))
-      (setq ,terminus (length (the simple-vector ,hash-vector)))
-      ,TOP
-      (if (= (the fixnum ,index) (the fixnum ,terminus))
-	  ,exit-form)
-      (when (> (the fixnum (aref (the (simple-array (unsigned-byte 8)) ,hash)
-				 ,index))
-	       1)
-	(setq ,var (svref ,hash-vector ,index))
-	,@forms)
-      (incf ,index)
-      (go ,TOP))))
-
-); eval-when (compile load eval)
-
-(defmacro do-symbols ((var &optional (package '*package*) result-form)
-		      &body (code decls))
-  "Do-Symbols (Var [Package [Result-Form]]) {Declaration}* {Tag | Statement}*
-  Executes the Forms at least once for each symbol accessible in the given
-  Package with Var bound to the current symbol."
-  (let* ((DONE-INTERNAL (gensym))
-	 (DONE-EXTERNAL (gensym))
-	 (NEXT-INHERIT (gensym))
-	 (vars (make-do-symbols-vars))
-	 (n-package (gensym))
-	 (shadowed (gensym))
-	 (inherits (gensym))
-	 (this-inherit (gensym)))
-    `(prog* ((,n-package (package-or-lose ,package))
-	     (,shadowed (package-shadowing-symbols ,n-package))
-	     (,inherits (package-use-list ,n-package))
-	     ,var ,@vars ,this-inherit)
-       ,@decls
-       ,@(make-do-symbols-code
-	  vars var `(package-internal-symbols ,n-package)
-	  `(go ,DONE-INTERNAL)
-	  code)
-       ,DONE-INTERNAL
-
-       ,@(make-do-symbols-code
-	  vars var `(package-external-symbols ,n-package)
-	  `(go ,DONE-EXTERNAL)
-	  code)
-       ,DONE-EXTERNAL
-
-       ,NEXT-INHERIT
-       (when (null ,inherits)
-	 (setq ,var nil)
-	 (return ,result-form))
-
-       (setq ,this-inherit (package-external-symbols (car ,inherits)))
-       ,@(make-do-symbols-code
-	  vars var this-inherit
-	  `(progn
-	    (setq ,inherits (cdr ,inherits))
-	    (go ,NEXT-INHERIT))
-	  `((when (or (not ,shadowed)
-		      (eq (find-symbol (symbol-name ,var) ,n-package) ,var))
-	      ,@code))))))
-
-(defmacro do-external-symbols ((var &optional (package '*package*) result-form)
-			       &body (code decls))
-  "Do-External-Symbols (Var [Package [Result-Form]])
-                       {Declaration}* {Tag | Statement}*
-  Executes the Forms once for each external symbol in the given Package with
-  Var bound to the current symbol."
-  (let ((vars (make-do-symbols-vars))
-	(n-package (gensym)))
-    `(prog ((,n-package (package-or-lose ,package))
-	    ,var ,@vars)
-       ,@decls
-       ,@(make-do-symbols-code
-	  vars var `(package-external-symbols ,n-package)
-	  `(return (progn (setq ,var nil) ,result-form))
-	  code))))
-
-(defmacro do-all-symbols ((var &optional result-form)
-			  &body (code decls))
-  "Do-All-Symbols (Var [Result-Form]) {Declaration}* {Tag | Statement}*
-  Executes the Forms once for each symbol in each package with Var bound
-  to the current symbol."
-  (let* ((PACKAGE-LOOP (gensym))
-	 (TAG (gensym))
-	 (package-list (gensym))
-	 (vars (make-do-symbols-vars))
-	 (internal-code (make-do-symbols-code
-			 vars var `(package-internal-symbols (car ,package-list))
-			 `(go ,TAG)
-			 code))
-	 (external-code (make-do-symbols-code
-			 vars var `(package-external-symbols (car ,package-list))
-			 `(progn (setq ,package-list (cdr ,package-list))
-				 (go ,PACKAGE-LOOP))
-			 code)))
-    `(prog (,package-list ,var ,@vars)
-       ,@decls
-       (setq ,package-list (list-all-packages))
-      ,PACKAGE-LOOP
-       (when (null ,package-list)
-	 (setq ,var nil)
-	 (return ,result-form))
-       ,@internal-code
-      ,TAG
-       ,@external-code)))
-
-;;; Enter-New-Nicknames  --  Internal
-;;;
-;;;    Enter any new Nicknames for Package into *package-names*.
-;;; If there is a conflict then give the user a chance to do
-;;; something about it.
-;;;
-(defun enter-new-nicknames (package nicknames)
-  (check-type nicknames list)
-  (dolist (n nicknames)
-    (let* ((n (string n))
-	   (found (gethash n *package-names*)))
-      (cond ((not found)
-	     (setf (gethash n *package-names*) package)
-	     (push n (package-nicknames package)))
-	    ((eq found package))
-	    ((string= (package-name found) n)
-	     (cerror "Ignore this nickname."
-		     "~S is a package name, so it cannot be a nickname for ~S."
-		     n (package-name package)))
-	    (t
-	     (cerror "Redefine this nickname."
-		     "~S is already a nickname for ~S."
-		     n (package-name found))
-	     (setf (gethash n *package-names*) package)
-	     (push n (package-nicknames package)))))))
-
-
-;;; Make-Package  --  Public
-;;;
-;;;    Check for package name conflicts in name and nicknames, then
-;;; make the package.  Do a use-package for each thing in the use list
-;;; so that checking for conflicting exports among used packages is done.
-;;;
-(defun make-package (name &key (use '("LISP")) nicknames
-			  (internal-symbols 10) (external-symbols 10))
-  "Makes a new package having the specified Name and Nicknames.  The
-  package will inherit all external symbols from each package in
-  the use list.  :Internal-Symbols and :External-Symbols are
-  estimates for the number of internal and external symbols which
-  will ultimately be present in the package."
-  (when (find-package name)
-    (error "A package named ~S already exists" name))
-  (let* ((name (string name))
-	 (package (internal-make-package
-		   :name name
-		   :internal-symbols (make-package-hashtable internal-symbols)
-		   :external-symbols (make-package-hashtable external-symbols))))
-    (if *in-package-init*
-	(push (list use package) *deferred-use-packages*)
-	(use-package use package))
-    (enter-new-nicknames package nicknames)
-    (setf (gethash name *package-names*) package)))
-
-;;; In-Package  --  Public
-;;;
-;;;    Like Make-Package, only different.
-;;;
-(defun in-package (name &rest keys &key nicknames use)
-  "Sets *package* to package with given name, creating the package if
-  it does not exist.  If the package already exists then it is modified
-  to agree with the :Use and :Nicknames arguments.  Any new nicknames
-  are added without removing any old ones not specified.  If any package
-  in the :Use list is not currently used, then it is added to the use
-  list."
-  (let ((package (find-package name)))
-    (cond
-     (package
-      (if *in-package-init*
-	  (push (list use package) *deferred-use-packages*)
-	  (use-package use package))
-      (enter-new-nicknames package nicknames)
-      (setq *package* package))
-     (t
-      (setq *package* (apply #'make-package name keys))))))
-
-;;; Rename-Package  --  Public
-;;;
-;;;    Change the name if we can, blast any old nicknames and then
-;;; add in any new ones.
-;;;
-(defun rename-package (package name &optional (nicknames ()))
-  "Changes the name and nicknames for a package."
-  (check-type package package)
-  (let* ((package (package-or-lose package))
-	 (name (string name))
-	 (found (find-package name)))
-    (unless (or (not found) (eq found package))
-      (error "A package named ~S already exists." name))
-    (remhash (package-name package) *package-names*)
-    (setf (package-name package) name)
-    (setf (gethash name *package-names*) package)
-    (dolist (n (package-nicknames package))
-      (remhash n *package-names*))
-    (setf (package-nicknames package) ())
-    (enter-new-nicknames package nicknames)
-    package))
-
-;;; List-All-Packages  --  Public
-;;;
-;;;
-(defun list-all-packages ()
-  "Returns a list of all existing packages."
-  (let ((res ()))
-    (maphash #'(lambda (k v)
-		 (declare (ignore k))
-		 (pushnew v res))
-	     *package-names*)
-    res))
-
-;;; Intern  --  Public
-;;;
-;;;    Simple-stringify the name and call intern*.
-;;;
-(defun intern (name &optional package)
-  "Returns a symbol having the specified name, creating it if necessary."
-  (let ((name (if (simple-string-p name) name (coerce name 'simple-string))))
-    (declare (simple-string name))
-    (intern* name (length name)
-	     (if package (package-or-lose package) *package*))))
-
-;;; Find-Symbol  --  Public
-;;;
-;;;    Ditto.
-;;;
-(defun find-symbol (name &optional package)
-  "Returns the symbol named String in Package.  If such a symbol is found
-  then the second value is :internal, :external or :inherited to indicate
-  how the symbol is accessible.  If no symbol is found then both values
-  are NIL."
-  (let ((name (if (simple-string-p name) name (coerce name 'simple-string))))
-    (declare (simple-string name))
-    (find-symbol* name (length name)
-		  (if package (package-or-lose package) *package*))))
-
-;;; Intern*  --  Internal
-;;;
-;;;    If the symbol doesn't exist then create it, special-casing
-;;; the keyword package.
-;;;
-(defun intern* (name length package)
-  (declare (simple-string name))
-  (multiple-value-bind (symbol where) (find-symbol* name length package)
-    (if where
-	(values symbol where)
-	(let ((symbol (%primitive alloc-symbol (subseq name 0 length))))
-	  (%primitive set-package symbol package)
-	  (cond ((eq package *keyword-package*)
-		 (add-symbol (package-external-symbols package) symbol)
-		 (set symbol symbol))
-		(t
-		 (add-symbol (package-internal-symbols package) symbol)))
-	  (values symbol nil)))))
-
-;;; Find-Symbol*  --  Internal
-;;;
-;;;    Check internal and external symbols, then scan down the list
-;;; of hashtables for inherited symbols.  When an inherited symbol
-;;; is found pull that table to the beginning of the list.
-;;;
-(defun find-symbol* (string length package)
-  (declare (simple-string string)
-	   (fixnum length))
-  (let* ((hash (%primitive sxhash-simple-substring string length))
-	 (ehash (entry-hash length hash)))
-    (declare (fixnum hash ehash))
-    (with-symbol (found symbol (package-internal-symbols package)
-			string length hash ehash)
-      (when found
-	(return-from find-symbol* (values symbol :internal))))
-    (with-symbol (found symbol (package-external-symbols package)
-			string length hash ehash)
-      (when found
-	(return-from find-symbol* (values symbol :external))))
-    (let ((head (package-tables package)))
-      (do ((prev head table)
-	   (table (cdr head) (cdr table)))
-	  ((null table) (values nil nil))
-	(with-symbol (found symbol (car table) string length hash ehash)
-	  (when found
-	    (unless (eq prev head)
-	      (shiftf (cdr prev) (cdr table) (cdr head) table))
-	    (return-from find-symbol* (values symbol :inherited))))))))
-
-;;; Find-External-Symbol  --  Internal
-;;;
-;;;    Similar to Find-Symbol, but only looks for an external symbol.
-;;; This is used for fast name-conflict checking in this file and symbol
-;;; printing in the printer.
-;;;
-(defun find-external-symbol (string package)
-  (declare (simple-string string))
-  (let* ((length (length string))
-	 (hash (%primitive sxhash-simple-string string))
-	 (ehash (entry-hash length hash)))
-    (declare (fixnum length hash))
-    (with-symbol (found symbol (package-external-symbols package)
-			string length hash ehash)
-      (values symbol found))))
-
-;;; Unintern  --  Public
-;;;
-;;;    If we are uninterning a shadowing symbol, then a name conflict can
-;;; result, otherwise just nuke the symbol.
-;;;
-(defun unintern (symbol &optional (package *package*))
-  "Makes Symbol no longer present in Package.  If Symbol was present
-  then T is returned, otherwise NIL.  If Package is Symbol's home
-  package, then it is made uninterned."
-  (let* ((package (package-or-lose package))
-	 (name (symbol-name symbol))
-	 (shadowing-symbols (package-shadowing-symbols package)))
-    (declare (list shadowing-symbols) (simple-string name))
-    ;;
-    ;; If a name conflict is revealed, give use a chance to shadowing-import
-    ;; one of the accessible symbols.
-    (when (member symbol shadowing-symbols)
-      (let ((cset ()))
-	(dolist (p (package-use-list package))
-	  (multiple-value-bind (s w) (find-external-symbol name p)
-	    (when w (pushnew s cset))))
-	(when (cdr cset)
-	  (loop
-	   (cerror
-	    "prompt for a symbol to shadowing-import."
-	    "Uninterning symbol ~S causes name conflict among these symbols:~%~S"
-	    symbol cset)
-	   (write-string "Symbol to shadowing-import: " *query-io*)
-	   (let ((sym (read *query-io*)))
-	     (cond
-	      ((not (symbolp sym))
-	       (format *query-io* "~S is not a symbol."))
-	      ((not (member sym cset))
-	       (format *query-io* "~S is not one of the conflicting symbols."))
-	      (t
-	       (shadowing-import sym package)
-	       (return-from unintern t)))))))
-      (setf (package-shadowing-symbols package)
-	    (delete symbol shadowing-symbols)))
-
-    (multiple-value-bind (s w) (find-symbol name package)
-      (declare (ignore s))
-      (cond ((or (eq w :internal) (eq w :external))
-	     (nuke-symbol (if (eq w :internal)
-			      (package-internal-symbols package)
-			      (package-external-symbols package))
-			  name)
-	     (if (eq (symbol-package symbol) package)
-		 (%primitive set-package symbol nil))
-	     t)
-	    (t nil)))))
-
-;;; Symbol-Listify  --  Internal
-;;;
-;;;    Take a symbol-or-list-of-symbols and return a list, checking types.
-;;;
-(defun symbol-listify (thing)
-  (cond ((listp thing)
-	 (dolist (s thing)
-	   (unless (symbolp s) (error "~S is not a symbol." s)))
-	 thing)
-	((symbolp thing) (list thing))
-	(t
-	 (error "~S is neither a symbol nor a list of symbols." thing))))
-
-;;; Moby-Unintern  --  Internal
-;;;
-;;;    Like Unintern, but if symbol is inherited chases down the
-;;; package it is inherited from and uninterns it there.  Used
-;;; for name-conflict resolution.  Shadowing symbols are not
-;;; uninterned since they do not cause conflicts.
-;;;
-(defun moby-unintern (symbol package)
-  (unless (member symbol (package-shadowing-symbols package))
-    (or (unintern symbol package)
-	(let ((name (symbol-name symbol)))
-	  (multiple-value-bind (s w) (find-symbol name package)
-	    (declare (ignore s))
-	    (when (eq w :inherited)
-	      (dolist (q (package-use-list package))
-		(multiple-value-bind (u x) (find-external-symbol name q)
-		  (declare (ignore u))
-		  (when x
-		    (unintern symbol q)
-		    (return t))))))))))
-
-;;; Export  --  Public
-;;;
-;;;    Do more stuff.
-;;;
-(defun export (symbols &optional (package *package*))
-  "Exports Symbols from Package, checking that no name conflicts result."
-  (let ((package (package-or-lose package))
-	(syms ()))
-    ;;
-    ;; Punt any symbols that are already external.
-    (dolist (sym (symbol-listify symbols))
-      (multiple-value-bind (s w)
-			   (find-external-symbol (symbol-name sym) package)
-	(declare (ignore s))
-	(unless (or w (member sym syms)) (push sym syms))))
-    ;;
-    ;; Find symbols and packages with conflicts.
-    (let ((used-by (package-used-by-list package))
-	  (cpackages ())
-	  (cset ()))
-      (dolist (sym syms)
-	(let ((name (symbol-name sym)))
-	  (dolist (p used-by)
-	    (multiple-value-bind (s w) (find-symbol name p)
-	      (when (and w (not (eq s sym))
-			 (not (member s (package-shadowing-symbols p))))
-		(pushnew sym cset)
-		(pushnew p cpackages))))))
-      (when cset
-	(restart-case
-	    (error "Exporting these symbols from the ~A package:~%~S~%~
-		    results in name conflicts with these packages:~%~{~A ~}"
-		   (package-name package) cset (mapcar #'package-name cpackages))
-	  (unintern-conflicting-symbols ()
-	   :report "Unintern conflicting symbols."
-	   (dolist (p cpackages)
-	     (dolist (sym cset)
-	       (moby-unintern sym p))))
-	  (skip-exporting-these-symbols ()
-	   :report "Skip exporting conflicting symbols."
-	   (setq syms (nset-difference syms cset))))))
-    ;;
-    ;; Check that all symbols are accessible.  If not, ask to import them.
-    (let ((missing ())
-	  (imports ()))
-      (dolist (sym syms)
-	(multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
-	  (cond ((not (and w (eq s sym))) (push sym missing))
-		((eq w :inherited) (push sym imports)))))
-      (when missing
-	(cerror "Import these symbols into the ~A package."
-		"These symbols are not accessible in the ~A package:~%~S"
-		(package-name package) missing)
-	(import missing package))
-      (import imports package))
-    ;;
-    ;; And now, three pages later, we export the suckers.
-    (let ((internal (package-internal-symbols package))
-	  (external (package-external-symbols package)))
-      (dolist (sym syms)
-	(nuke-symbol internal (symbol-name sym))
-	(add-symbol external sym)))
-    t))
-
-;;; Unexport  --  Public
-;;;
-;;;    Check that all symbols are accessible, then move from external to
-;;; internal.
-;;;
-(defun unexport (symbols &optional (package *package*))
-  "Makes Symbols no longer exported from Package."
-  (let ((package (package-or-lose package))
-	(syms ()))
-    (dolist (sym (symbol-listify symbols))
-      (multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
-	(cond ((or (not w) (not (eq s sym)))
-	       (error "~S is not accessible in the ~A package."
-		      sym (package-name package)))
-	      ((eq w :external) (pushnew sym syms)))))
-
-    (let ((internal (package-internal-symbols package))
-	  (external (package-external-symbols package)))
-      (dolist (sym syms)
-	(add-symbol internal sym)
-	(nuke-symbol external (symbol-name sym))))
-    t))
-
-;;; Import  --  Public
-;;;
-;;;    Check for name conflic caused by the import and let the user 
-;;; shadowing-import if there is.
-;;;
-(defun import (symbols &optional (package *package*))
-  "Make Symbols accessible as internal symbols in Package.  If a symbol
-  is already accessible then it has no effect.  If a name conflict
-  would result from the importation, then a correctable error is signalled."
-  (let ((package (package-or-lose package))
-	(symbols (symbol-listify symbols))
-	(syms ())
-	(cset ()))
-    (dolist (sym symbols)
-      (multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
-	(cond ((not w)
-	       (let ((found (member sym syms :test #'string=)))
-		 (if found
-		     (when (not (eq (car found) sym))
-		       (push sym cset))
-		     (push sym syms))))
-	      ((not (eq s sym)) (push sym cset))
-	      ((eq w :inherited) (push sym syms)))))
-    (when cset
-      (cerror
-       "Import these symbols with Shadowing-Import."
-       "Importing these symbols into the ~A package causes a name conflict:~%~S"
-       (package-name package) cset))
-    ;;
-    ;; Add the new symbols to the internal hashtable.
-    (let ((internal (package-internal-symbols package)))
-      (dolist (sym syms)
-	(add-symbol internal sym)))
-    ;;
-    ;; If any of the symbols are uninterned, make them be owned by Package.
-    (dolist (sym symbols)
-      (unless (symbol-package sym) (%primitive set-package sym package)))
-    (shadowing-import cset package)))
-
-;;; Shadowing-Import  --  Public
-;;;
-;;;    If a conflicting symbol is present, unintern it, otherwise just
-;;; stick the symbol in.
-;;;
-(defun shadowing-import (symbols &optional (package *package*))
-  "Import Symbols into package, disregarding any name conflict.  If
-  a symbol of the same name is present, then it is uninterned.
-  The symbols are added to the Package-Shadowing-Symbols."
-  (let* ((package (package-or-lose package))
-	 (internal (package-internal-symbols package)))
-    (dolist (sym (symbol-listify symbols))
-      (multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
-	(unless (and w (not (eq w :inherited)) (eq s sym))
-	  (when (or (eq w :internal) (eq w :external))
-	    ;;
-	    ;; If it was shadowed, we don't want Unintern to flame out...
-	    (setf (package-shadowing-symbols package)
-		  (delete s (the list (package-shadowing-symbols package))))
-	    (unintern s package))
-	  (add-symbol internal sym))
-	(pushnew sym (package-shadowing-symbols package)))))
-  t)
-
-
-;;; Shadow  --  Public
-;;;
-;;;
-(defun shadow (symbols &optional (package *package*))
-  "Make an internal symbol in Package with the same name as each of the
-  specified symbols, adding the new symbols to the Package-Shadowing-Symbols.
-  If a symbol with the given name is already present in Package, then
-  the existing symbol is placed in the shadowing symbols list if it is
-  not already present."
-  (let* ((package (package-or-lose package))
-	 (internal (package-internal-symbols package)))
-    (dolist (sym (symbol-listify symbols))
-      (let ((name (symbol-name sym)))
-	(multiple-value-bind (s w) (find-symbol name package)
-	  (when (or (not w) (eq w :inherited))
-	    (setq s (%primitive alloc-symbol name))
-	    (%primitive set-package s package)
-	    (add-symbol internal s))
-	  (pushnew s (package-shadowing-symbols package))))))
-  t)
-
-;;; Use-Package  --  Public
-;;;
-;;;    Do stuff to use a package, with all kinds of fun name-conflict
-;;; checking.
-;;;
-(defun use-package (packages-to-use &optional (package *package*))
-  "Add all the Package-To-Use to the use list for Package so that
-  the external symbols of the used packages are accessible as internal
-  symbols in Package."
-  (let ((packages (package-listify packages-to-use))
-	(package (package-or-lose package)))
-    ;;
-    ;; Loop over each package, use'ing one at a time...
-    (dolist (pkg packages)
-      (unless (member pkg (package-use-list package))
-	(let ((cset ())
-	      (shadowing-symbols (package-shadowing-symbols package))
-	      (use-list (package-use-list package)))
-	  ;;
-	  ;;   If the number of symbols already accessible is less than the
-	  ;; number to be inherited then it is faster to run the test the
-	  ;; other way.  This is particularly valuable in the case of
-	  ;; a new package use'ing Lisp.
-	  (cond
-	   ((< (+ (internal-symbol-count package)
-		  (external-symbol-count package)
-		  (let ((res 0))
-		    (dolist (p use-list res)
-		      (incf res (external-symbol-count p)))))
-	       (external-symbol-count pkg))
-	    (do-symbols (sym package)
-	      (multiple-value-bind (s w)
-				   (find-external-symbol (symbol-name sym) pkg)
-		(when (and w (not (eq s sym))
-			   (not (member sym shadowing-symbols)))
-		  (push sym cset))))
-	    (dolist (p use-list)
-	      (do-external-symbols (sym p)
-		(multiple-value-bind (s w)
-				     (find-external-symbol (symbol-name sym)
-							   pkg)
-		  (when (and w (not (eq s sym))
-			     (not (member (find-symbol (symbol-name sym)
-						       package)
-					  shadowing-symbols)))
-		    (push sym cset))))))
-	   (t
-	    (do-external-symbols (sym pkg)
-	      (multiple-value-bind (s w)
-				   (find-symbol (symbol-name sym) package)
-		(when (and w (not (eq s sym))
-			   (not (member s shadowing-symbols)))
-		  (push s cset))))))
-	  
-	  (when cset
-	    (cerror
-	     "unintern the conflicting symbols in the ~2*~A package."
-	     "Use'ing package ~A results in name conflicts for these symbols:~%~S"
-	     (package-name pkg) cset (package-name package))
-	    (dolist (s cset) (moby-unintern s package))))
-
-	(push pkg (package-use-list package))
-	(push (package-external-symbols pkg) (cdr (package-tables package)))
-	(push package (package-used-by-list pkg)))))
-  t)
-
-;;; Unuse-Package  --  Public
-;;;
-;;;
-(defun unuse-package (packages-to-unuse &optional (package *package*))
-  "Remove Packages-To-Unuse from the use list for Package."
-  (let ((package (package-or-lose package)))
-    (dolist (p (package-listify packages-to-unuse))
-      (setf (package-use-list package)
-	    (delete p (the list (package-use-list package))))
-      (setf (package-tables package)
-	    (delete (package-external-symbols p)
-		    (the list (package-tables package))))
-      (setf (package-used-by-list p)
-	    (delete package (the list (package-used-by-list p)))))
-    t))
-
-;;; Find-All-Symbols --  Public
-;;;
-;;;
-(defun find-all-symbols (string-or-symbol)
-  "Return a list of all symbols in the system having the specified name."
-  (let ((string (string string-or-symbol))
-	(res ()))
-    (maphash #'(lambda (k v)
-		 (declare (ignore k))
-		 (multiple-value-bind (s w) (find-symbol string v)
-		   (when w (pushnew s res))))
-	     *package-names*)
-    res))
-
-
-;;; Apropos and Apropos-List.
-
-(defun briefly-describe-symbol (symbol)
-  (fresh-line)
-  (prin1 symbol)
-  (when (boundp symbol)
-    (write-string ", value: ")
-    (prin1 (symbol-value symbol)))
-  (if (fboundp symbol)
-      (write-string " (defined)")))
-
-(defun apropos-search (symbol string)
-  (declare (simple-string string))
-  (do* ((index 0 (1+ index))
-	(name (symbol-name symbol))
-	(length (length string))
-	(terminus (- (length name) length)))
-       ((> index terminus)
-	nil)
-    (declare (simple-string name)
-	     (fixnum index terminus length))
-    (if (do ((jndex 0 (1+ jndex))
-	     (kndex index (1+ kndex)))
-	    ((= jndex length)
-	     t)
-	  (declare (fixnum jndex kndex))
-	  (let ((char (schar name kndex)))
-	    (unless (char= (schar string jndex) (char-upcase char))
-	      (return nil))))
-	(return t))))
-
-(defun apropos (string &optional package external-only)
-  "Briefly describe all symbols which contain the specified String.
-  If Package is supplied then only describe symbols present in
-  that package.  If External-Only is true then only describe
-  external symbols in the specified package."
-  (let ((string (string-upcase string)))
-    (declare (simple-string string))
-    (if (null package)
-	(do-all-symbols (symbol)
-	   (if (apropos-search symbol string)
-	       (briefly-describe-symbol symbol)))
-	(let ((package (package-or-lose package)))
-	  (if external-only
-	      (do-external-symbols (symbol package)
-		(if (apropos-search symbol string)
-		    (briefly-describe-symbol symbol)))
-	      (do-symbols (symbol package)
-		(if (apropos-search symbol string)
-		    (briefly-describe-symbol symbol))))))
-    (values)))
-
-(defun apropos-list (string &optional package external-only)
-  "Identical to Apropos, except that it returns a list of the symbols
-  found instead of describing them."
-  (let ((string (string-upcase string))
-	(list '()))
-    (declare (simple-string string))
-    (if (null package)
-	(do-all-symbols (symbol)
-	   (if (apropos-search symbol string)
-	       (push symbol list)))
-	(let ((package (package-or-lose package)))
-	  (if external-only
-	      (do-external-symbols (symbol package)
-		(if (apropos-search symbol string)
-		    (push symbol list)))
-	      (do-symbols (symbol package)
-		(if (apropos-search symbol string)
-		    (push symbol list))))))
-    list))
-
-;;; Initialization.
-
-;;; The cold loader (Genesis) makes the data structure in *initial-symbols*.
-;;; We grovel over it, making the specified packages and interning the
-;;; symbols.  For a description of the format of *initial-symbols* see
-;;; the Genesis source.
-
-(defvar *initial-symbols*)
-
-(defun package-init ()
-  (let ((*in-package-init* t))
-    (dolist (spec *initial-symbols*)
-      (let* ((pkg (apply #'make-package (first spec)))
-	     (internal (package-internal-symbols pkg))
-	     (external (package-external-symbols pkg)))
-	;;
-	;; Put internal symbols in the internal hashtable and set package.
-	(dolist (symbol (second spec))
-	  (add-symbol internal symbol)
-	  (%primitive set-package symbol pkg))
-	;;
-	;; External symbols same, only go in external table.
-	(dolist (symbol (third spec))
-	  (add-symbol external symbol)
-	  (%primitive set-package symbol pkg))
-	;;
-	;; Don't set package for Imported symbols.
-	(dolist (symbol (fourth spec))
-	  (add-symbol internal symbol))
-	(dolist (symbol (fifth spec))
-	  (add-symbol external symbol))
-	;;
-	;; Put shadowing symbols in the shadowing symbols list.
-	(setf (package-shadowing-symbols pkg) (sixth spec))))
-
-    (makunbound '*initial-symbols*) ; So it gets GC'ed.
-    
-    ;; Make some other packages that should be around in the cold load:
-    (in-package "SYSTEM")
-    (in-package "USER")
-    (in-package "DEBUG")
-
-    ;; Now do the *deferred-use-packages*:
-    (dolist (args *deferred-use-packages*)
-      (apply #'use-package args))
-    (makunbound '*deferred-use-packages*)
-
-    (setq *lisp-package* (find-package "LISP"))
-    (setq *keyword-package* (find-package "KEYWORD"))
-
-    ;; For the kernel core image wizards, set the package to *Lisp-Package*.
-    (setq *package* *lisp-package*)))
diff --git a/code/parse-time.lisp b/code/parse-time.lisp
deleted file mode 100644
index 50db34cc69fa6846915a35b18423b7104a4be9fc..0000000000000000000000000000000000000000
--- a/code/parse-time.lisp
+++ /dev/null
@@ -1,574 +0,0 @@
-;;;  -*- Mode: Lisp; Package: Extensions; Log: code.log -*-
-
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-
-;;; Parsing routines for time and date strings. Parse-time returns the
-;;; universal time integer for the time and/or date given in the string.
-
-;;; Written by Jim Healy, June 1987.
-
-;;; **********************************************************************
-
-(in-package "EXTENSIONS" :use "LISP")
-
-(export 'parse-time)
-
-(defconstant whitespace-chars '(#\space #\tab #\newline #\, #\' #\`))
-(defconstant time-dividers '(#\: #\.))
-(defconstant date-dividers '(#\- #\\ #\/))
-
-(defvar *error-on-mismatch* nil
-  "If t, an error will be signalled if parse-time is unable
-   to determine the time/date format of the string.")
-
-;;; Set up hash tables for month, weekday, zone, and special strings.
-;;; Provides quick, easy access to associated information for these items.
-
-;;; Hashlist takes an association list and hashes each pair into the
-;;; specified tables using the car of the pair as the key and the cdr as
-;;; the data object.
-
-(defmacro hashlist (list table)
-  `(dolist (item ,list)
-     (setf (gethash (car item) ,table) (cdr item))))
-
-(defparameter weekday-table-size 20)
-(defparameter month-table-size 30)
-(defparameter zone-table-size 10)
-(defparameter special-table-size 10)
-
-(defvar *weekday-strings* (make-hash-table :test #'equal
-					 :size weekday-table-size))
-
-(defvar *month-strings* (make-hash-table :test #'equal
-				       :size month-table-size))
-
-(defvar *zone-strings* (make-hash-table :test #'equal
-				      :size zone-table-size))
-
-(defvar *special-strings* (make-hash-table :test #'equal
-					 :size special-table-size))
-
-;;; Load-time creation of the hash tables.
-
-(hashlist '(("monday" . 0)    ("mon" . 0)
-	    ("tuesday" . 1)   ("tues" . 1)   ("tue" . 1)
-	    ("wednesday" . 2) ("wednes" . 2) ("wed" . 2)
-	    ("thursday" . 3)  ("thurs" . 3)  ("thu" . 3)
-	    ("friday" . 4)    ("fri" . 4)
-	    ("saturday" . 5)  ("sat" . 5)
-	    ("sunday" . 6)    ("sun" . 6))
-	  *weekday-strings*)
-
-(hashlist '(("january" . 1)   ("jan" . 1)
-	    ("february" . 2)  ("feb" . 2)
-	    ("march" . 3)     ("mar" . 3)
-	    ("april" . 4)     ("apr" . 4)
-	    ("may" . 5)       ("june" . 6)
-	    ("jun" . 6)       ("july" . 7)
-	    ("jul" . 7)	      ("august" . 8)
-	    ("aug" . 8)       ("september" . 9)
-	    ("sept" . 9)      ("sep" . 9)
-	    ("october" . 10)  ("oct" . 10)
-	    ("november" . 11) ("nov" . 11)
-	    ("december" . 12) ("dec" . 12))
-	  *month-strings*)
-
-(hashlist '(("gmt" . 0) ("est" . 5)
-	    ("edt" . 5) ("cst" . 6)
-	    ("cdt" . 6) ("mst" . 7)
-	    ("mdt" . 7)	("pst" . 8)
-	    ("pdt" . 8)) 
-	  *zone-strings*)
-
-(hashlist '(("yesterday" . yesterday)  ("today" . today)
-	    ("tomorrow" . tomorrow)   ("now" . now))
-	  *special-strings*)
-
-;;; Time/date format patterns are specified as lists of symbols repre-
-;;; senting the elements.  Optional elements can be specified by
-;;; enclosing them in parentheses.  Note that the order in which the
-;;; patterns are specified below determines the order of search.
-
-;;; Choices of pattern symbols are: second, minute, hour, day, month,
-;;; year, time-divider, date-divider, am-pm, zone, weekday, noon-midn,
-;;; and any special symbol.
-
-(defparameter patterns
-  '( 
-     ;; Date formats.
-    ((weekday) month (date-divider) day (date-divider) year (noon-midn))
-    ((weekday) day (date-divider) month (date-divider) year (noon-midn))
-    ((weekday) month (date-divider) day (noon-midn))
-    (year (date-divider) month (date-divider) day (noon-midn))
-    (month (date-divider) year (noon-midn))
-    (year (date-divider) month (noon-midn))
-
-    ((noon-midn) (weekday) month (date-divider) day (date-divider) year)
-    ((noon-midn) (weekday) day (date-divider) month (date-divider) year)
-    ((noon-midn) (weekday) month (date-divider) day)
-    ((noon-midn) year (date-divider) month (date-divider) day)
-    ((noon-midn) month (date-divider) year)
-    ((noon-midn) year (date-divider) month)
-
-     ;; Time formats.
-    (hour (time-divider) (minute) (time-divider) (secondp) (am-pm) 
-	  (date-divider) (zone))
-    (noon-midn)
-    (hour (noon-midn))
-
-     ;; Time/date combined formats.
-    ((weekday) month (date-divider) day (date-divider) year
-	   hour (time-divider) (minute) (time-divider) (secondp)
-	   (am-pm) (date-divider) (zone))
-    ((weekday) day (date-divider) month (date-divider) year
-	 hour (time-divider) (minute) (time-divider) (secondp)
-	 (am-pm) (date-divider) (zone))
-    ((weekday) month (date-divider) day
-	   hour (time-divider) (minute) (time-divider) (secondp)
-	   (am-pm) (date-divider) (zone))
-    (year (date-divider) month (date-divider) day
-	  hour (time-divider) (minute) (time-divider) (secondp)
-	  (am-pm) (date-divider) (zone))
-    (month (date-divider) year
-	   hour (time-divider) (minute) (time-divider) (secondp)
-	   (am-pm) (date-divider) (zone))
-    (year (date-divider) month
-	  hour (time-divider) (minute) (time-divider) (secondp)
-	  (am-pm) (date-divider) (zone))
-
-    (hour (time-divider) (minute) (time-divider) (secondp) (am-pm)
-	  (date-divider) (zone) (weekday) month (date-divider)
-	  day (date-divider) year)
-    (hour (time-divider) (minute) (time-divider) (secondp) (am-pm)
-	  (date-divider) (zone) (weekday) day (date-divider)
-	  month (date-divider) year)
-    (hour (time-divider) (minute) (time-divider) (secondp) (am-pm)
-	  (date-divider) (zone) (weekday) month (date-divider)
-	  day)
-    (hour (time-divider) (minute) (time-divider) (secondp) (am-pm)
-	  (date-divider) (zone) year (date-divider) month
-	  (date-divider) day)
-    (hour (time-divider) (minute) (time-divider) (secondp) (am-pm)
-	  (date-divider) (zone) month (date-divider) year)
-    (hour (time-divider) (minute) (time-divider) (secondp) (am-pm)
-	  (date-divider) (zone) year (date-divider) month)
-
-     ;; Weird, non-standard formats.
-    (weekday month day hour (time-divider) minute (time-divider)
-	     secondp (am-pm)
-	     (zone) year)
-    ((weekday) day (date-divider) month (date-divider) year hour
-     (time-divider) minute (time-divider) (secondp) (am-pm)
-     (date-divider) (zone))
-    ((weekday) month (date-divider) day (date-divider) year hour
-     (time-divider) minute (time-divider) (secondp) (am-pm)
-     (date-divider) (zone))
-
-    ;; Special-string formats.
-    (now (yesterday))
-    ((yesterday) now)
-    (now (today))
-    ((today) now)
-    (now (tomorrow))
-    ((tomorrow) now)
-    (yesterday (noon-midn))
-    ((noon-midn) yesterday)
-    (today (noon-midn))
-    ((noon-midn) today)
-    (tomorrow (noon-midn))
-    ((noon-midn) tomorrow)
-))
-
-;;; The decoded-time structure holds the time/date values which are
-;;; eventually passed to 'encode-universal-time' after parsing.
-
-;;; Note: Currently nothing is done with the day of the week.  It might
-;;; be appropriate to add a function to see if it matches the date.
-
-(defstruct decoded-time
-  (second 0    :type integer)    ; Value between 0 and 59.
-  (minute 0    :type integer)    ; Value between 0 and 59.
-  (hour   0    :type integer)    ; Value between 0 and 23.
-  (day    1    :type integer)    ; Value between 1 and 31.
-  (month  1    :type integer)    ; Value between 1 and 12.
-  (year   1900 :type integer)    ; Value above 1899 or between 0 and 99.
-  (zone   0    :type integer)    ; Value between 0 and 23.
-  (dotw   0    :type integer))   ; Value between 0 and 6.
-
-;;; Make-default-time returns a decoded-time structure with the default
-;;; time values already set.  The default time is currently 00:00 on
-;;; the current day, current month, current year, and current time-zone.
-
-(defun make-default-time (def-sec def-min def-hour def-day
-			   def-mon def-year def-zone def-dotw)
-  (let ((default-time (make-decoded-time)))
-    (multiple-value-bind (sec min hour day mon year dotw dst zone)
-			 (get-decoded-time)
-      (declare (ignore dst))
-      (if def-sec
-	  (if (eq def-sec :current)
-	      (setf (decoded-time-second default-time) sec)
-	      (setf (decoded-time-second default-time) def-sec))
-	  (setf (decoded-time-second default-time) 0))
-      (if def-min
-	  (if (eq def-min :current)
-	      (setf (decoded-time-minute default-time) min)
-	      (setf (decoded-time-minute default-time) def-min))
-	  (setf (decoded-time-minute default-time) 0))
-      (if def-hour
-	  (if (eq def-hour :current)
-	      (setf (decoded-time-hour default-time) hour)
-	      (setf (decoded-time-hour default-time) def-hour))
-	  (setf (decoded-time-hour default-time) 0))
-      (if def-day
-	  (if (eq def-day :current)
-	      (setf (decoded-time-day default-time) day)
-	      (setf (decoded-time-day default-time) def-day))
-	  (setf (decoded-time-day default-time) day))
-      (if def-mon
-	  (if (eq def-mon :current)
-	      (setf (decoded-time-month default-time) mon)
-	      (setf (decoded-time-month default-time) def-mon))
-	  (setf (decoded-time-month default-time) mon))
-      (if def-year
-	  (if (eq def-year :current)
-	      (setf (decoded-time-year default-time) year)
-	      (setf (decoded-time-year default-time) def-year))
-	  (setf (decoded-time-year default-time) year))
-      (if def-zone
-	  (if (eq def-zone :current)
-	      (setf (decoded-time-zone default-time) zone)
-	      (setf (decoded-time-zone default-time) def-zone))
-	  (setf (decoded-time-zone default-time) zone))
-      (if def-dotw
-	  (if (eq def-dotw :current)
-	      (setf (decoded-time-dotw default-time) dotw)
-	      (setf (decoded-time-dotw default-time) def-dotw))
-	  (setf (decoded-time-dotw default-time) dotw))
-      default-time)))
-
-;;; Converts the values in the decoded-time structure to universal time
-;;; by calling extensions:encode-universal-time.
-
-(defun convert-to-unitime (parsed-values)
-  (encode-universal-time (decoded-time-second parsed-values)
-			 (decoded-time-minute parsed-values)
-			 (decoded-time-hour parsed-values)
-			 (decoded-time-day parsed-values)
-			 (decoded-time-month parsed-values)
-			 (decoded-time-year parsed-values)
-			 (decoded-time-zone parsed-values)))
-
-;;; Sets the current values for the time and/or date parts of the 
-;;; decoded time structure.
-
-(defun set-current-value (values-structure &key (time nil) (date nil) (zone nil))
-  (multiple-value-bind (sec min hour day mon year dotw dst tz)
-		       (get-decoded-time)
-    (declare (ignore dst))
-    (when time
-      (setf (decoded-time-second values-structure) sec)
-      (setf (decoded-time-minute values-structure) min)
-      (setf (decoded-time-hour values-structure) hour))
-    (when date
-      (setf (decoded-time-day values-structure) day)
-      (setf (decoded-time-month values-structure) mon)
-      (setf (decoded-time-year values-structure) year)
-      (setf (decoded-time-dotw values-structure) dotw))
-    (when zone
-      (setf (decoded-time-zone values-structure) tz))))
-
-;;; Special function definitions.  To define a special substring, add
-;;; a dotted pair consisting of the substring and a symbol in the
-;;; *special-strings* hashlist statement above.  Then define a function
-;;; here which takes one argument- the decoded time structure- and
-;;; sets the values of the structure to whatever is necessary.  Also,
-;;; add a some patterns to the patterns list using whatever combinations
-;;; of special and pre-existing symbols desired.
-
-(defun yesterday (parsed-values)
-  (set-current-value parsed-values :date t :zone t)
-  (setf (decoded-time-day parsed-values)
-	(1- (decoded-time-day parsed-values))))
-
-(defun today (parsed-values)
-  (set-current-value parsed-values :date t :zone t))
-
-(defun tomorrow (parsed-values)
-  (set-current-value parsed-values :date t :zone t)
-  (setf (decoded-time-day parsed-values)
-	(1+ (decoded-time-day parsed-values))))
-
-(defun now (parsed-values)
-  (set-current-value parsed-values :time t))
-
-;;; Predicates for symbols.  Each symbol has a corresponding function
-;;; defined here which is applied to a part of the datum to see if
-;;; it matches the qualifications.
-
-(defun am-pm (string)
-  (and (simple-string-p string)
-       (cond ((string= string "am") 'am)
-	     ((string= string "pm") 'pm)
-	     (t nil))))
-
-(defun noon-midn (string)
-  (and (simple-string-p string)
-       (cond ((string= string "noon") 'noon)
-	     ((string= string "midnight") 'midn)
-	     (t nil))))
-
-(defun weekday (string)
-  (and (simple-string-p string) (gethash string *weekday-strings*)))
-
-(defun month (thing)
-  (or (and (simple-string-p thing) (gethash thing *month-strings*))
-      (and (integerp thing) (<= 1 thing 12))))
-
-(defun zone (string)
-  (and (simple-string-p string) (gethash string *zone-strings*)))
-
-(defun special (string)
-  (and (simple-string-p string) (gethash string *special-strings*)))
-
-(defun secondp (number)
-  (and (integerp number) (<= 0 number 59)))
-
-(defun minute (number)
-  (and (integerp number) (<= 0 number 59)))
-
-(defun hour (number)
-  (and (integerp number) (<= 0 number 23)))
-
-(defun day (number)
-  (and (integerp number) (<= 1 number 31)))
-
-(defun year (number)
-  (and (integerp number)
-       (or (<= 0 number 99)
-	   (<= 1900 number))))
-
-(defun time-divider (character)
-  (and (characterp character)
-       (member character time-dividers :test #'char=)))
-
-(defun date-divider (character)
-  (and (characterp character)
-       (member character date-dividers :test #'char=)))
-
-;;; Match-substring takes a string argument and tries to match it with
-;;; the strings in one of the four hash tables: *weekday-strings*, *month-
-;;; strings*, *zone-strings*, *special-strings*.  It returns a specific
-;;; keyword and/or the object it finds in the hash table.  If no match
-;;; is made then it immediately signals an error.
-
-(defun match-substring (substring)
-  (let ((substring (nstring-downcase substring)))
-    (or (let ((test-value (month substring)))
-	  (if test-value (cons 'month test-value)))
-	(let ((test-value (weekday substring)))
-	  (if test-value (cons 'weekday test-value)))
-	(let ((test-value (am-pm substring)))
-	  (if test-value (cons 'am-pm test-value)))
-	(let ((test-value (noon-midn substring)))
-	  (if test-value (cons 'noon-midn test-value)))
-	(let ((test-value (zone substring)))
-	  (if test-value (cons 'zone test-value)))
-	(let ((test-value (special substring)))
-	  (if test-value  (cons 'special test-value)))
-	(if *error-on-mismatch*
-	    (error "\"~A\" is not a recognized word or abbreviation."
-		   substring)
-	    (return-from match-substring nil)))))
-
-;;; Decompose-string takes the time/date string and decomposes it into a
-;;; list of alphabetic substrings, numbers, and special divider characters.
-;;; It matches whatever strings it can and replaces them with a dotted pair
-;;; containing a symbol and value.
-
-(defun decompose-string (string &key (start 0) (end (length string)) (radix 10))
-  (do ((string-index start)
-       (parts-list nil))
-      ((eq string-index end) (nreverse parts-list))
-    (let ((next-char (char string string-index)))
-      (cond ((alpha-char-p next-char)
-	     ;; Alphabetic character - scan to the end of the substring.
-	     (do ((scan-index (1+ string-index) (1+ scan-index)))
-		 ((or (eq scan-index end)
-		      (not (alpha-char-p (char string scan-index))))
-		  (let ((match-symbol (match-substring
-				       (subseq string string-index scan-index))))
-		    (if match-symbol
-			(push match-symbol parts-list)
-			(return-from decompose-string nil)))
-		  (setf string-index scan-index))))
-	    ((digit-char-p next-char radix)
-	     ;; Numeric digit - convert digit-string to a decimal value.
-	     (do ((scan-index string-index (1+ scan-index))
-		  (numeric-value 0 (+ (* numeric-value radix)
-				      (digit-char-p (char string scan-index) radix))))
-		 ((or (eq scan-index end)
-		      (not (digit-char-p (char string scan-index) radix)))
-		  (push numeric-value parts-list)
-		  (setf string-index scan-index))))
-	    ((member next-char time-dividers :test #'char=)
- 	     ;; Time-divider - add it to the parts-list with symbol.
-	     (push (cons 'time-divider next-char) parts-list)
-	     (incf string-index))
-	    ((member next-char date-dividers :test #'char=)
-	     ;; Date-divider - add it to the parts-list with symbol.
-	     (push (cons 'date-divider next-char) parts-list)
-	     (incf string-index))
-	    ((member next-char whitespace-chars :test #'char=)
-	     ;; Whitespace character - ignore it completely.
-	     (incf string-index))
-	    ((char= next-char #\()
-	     ;; Parenthesized string - scan to the end and ignore it.
-	     (do ((scan-index string-index (1+ scan-index)))
-		 ((or (eq scan-index end)
-		      (char= (char string scan-index) #\)))
- 		  (setf string-index (1+ scan-index)))))
-	    (t
-	     ;; Unrecognized character - barf voraciously.
-	     (if *error-on-mismatch*
-		 (error (concatenate 'simple-string ">>> " string
-				     "~%~VT^-- Bogus character encountered here.")
-			(+ string-index 4))
-		 (return-from decompose-string nil)))))))
-
-;;; Match-pattern-element tries to match a pattern element with a datum
-;;; element and returns the symbol associated with the datum element if
-;;; successful.  Otherwise nil is returned.
-
-(defun match-pattern-element (pattern-element datum-element)
-  (cond ((listp datum-element)
-	 (let ((datum-type (if (eq (car datum-element) 'special)
-			       (cdr datum-element)
-			       (car datum-element))))
-	   (if (eq datum-type pattern-element) datum-element)))
-	((funcall pattern-element datum-element)
-	 (cons pattern-element datum-element))
-	(t nil)))
-
-;;; Match-pattern matches a pattern against a datum, returning the
-;;; pattern if successful and nil otherwise.
-
-(defun match-pattern (pattern datum datum-length)
-  (if (>= (length pattern) datum-length)
-      (let ((form-list nil))
-	(do ((pattern pattern (cdr pattern))
-	     (datum datum (cdr datum)))
-	    ((or (null pattern) (null datum))
-	     (cond ((and (null pattern) (null datum))
-		    (nreverse form-list))
-		   ((null pattern) nil)
-		   ((null datum) (dolist (element pattern
-						  (nreverse form-list))
-				   (if (not (listp element))
-				       (return nil))))))
-	(let* ((pattern-element (car pattern))
-	       (datum-element (car datum))
-	       (optional (listp pattern-element))
-	       (matching (match-pattern-element (if optional
-						    (car pattern-element)
-						    pattern-element)
-						datum-element)))
-	  (cond (matching (let ((form-type (car matching)))
-			    (unless (or (eq form-type 'time-divider)
-					(eq form-type 'date-divider))
-			      (push matching form-list))))
-		(optional (push datum-element datum))
-		(t (return-from match-pattern nil))))))))
-
-;;; Deal-with-noon-midn sets the decoded-time values to either noon
-;;; or midnight depending on the argument form-value.  Form-value
-;;; can be either 'noon or 'midn.
-
-(defun deal-with-noon-midn (form-value parsed-values)
-  (cond ((eq form-value 'noon)
-	 (setf (decoded-time-hour parsed-values) 12))
-	((eq form-value 'midn)
-	 (setf (decoded-time-hour parsed-values) 0))
-	(t (error "Unrecognized symbol: ~A" form-value)))
-  (setf (decoded-time-minute parsed-values) 0)
-  (setf (decoded-time-second parsed-values) 0))
-
-;;; Deal-with-am-pm sets the decoded-time values to be in the am
-;;; or pm depending on the argument form-value.  Form-value can
-;;; be either 'am or 'pm.
-
-(defun deal-with-am-pm (form-value parsed-values)
-  (let ((hour (decoded-time-hour parsed-values)))
-    (cond ((eq form-value 'am)
-	   (cond ((eq hour 12)
-		  (setf (decoded-time-hour parsed-values) 0))
-		 ((not (<= 0 hour 12))
-		  (if *error-on-mismatch*
-		      (error "~D is not an AM hour, dummy." hour)))))
-	  ((eq form-value 'pm)
-	   (if (<= 0 hour 11)
-	       (setf (decoded-time-hour parsed-values)
-		     (mod (+ hour 12) 24))))
-	  (t (error "~A isn't AM/PM - this shouldn't happen.")))))
-
-;;; Set-time-values uses the association list of symbols and values
-;;; to set the time in the decoded-time structure.
-
-(defun set-time-values (string-form parsed-values)
-  (dolist (form-part string-form t)
-    (let ((form-type (car form-part))
-	  (form-value (cdr form-part)))
-      (case form-type
-	(secondp (setf (decoded-time-second parsed-values) form-value))
-	(minute (setf (decoded-time-minute parsed-values) form-value))
-	(hour (setf (decoded-time-hour parsed-values) form-value))
-	(day (setf (decoded-time-day parsed-values) form-value))
-	(month (setf (decoded-time-month parsed-values) form-value))
-	(year (setf (decoded-time-year parsed-values) form-value))
-	(zone (setf (decoded-time-zone parsed-values) form-value))
-	(weekday (setf (decoded-time-dotw parsed-values) form-value))
-	(am-pm (deal-with-am-pm form-value parsed-values))
-	(noon-midn (deal-with-noon-midn form-value parsed-values))
-	(special (funcall form-value parsed-values))
-	(t (error "Unrecognized symbol in form list: ~A." form-type))))))
-
-(defun parse-time (time-string &key (error-on-mismatch nil)
-			       (default-seconds nil) (default-minutes nil)
-			       (default-hours nil) (default-day nil)
-			       (default-month nil) (default-year nil)
-			       (default-zone nil) (default-weekday nil))
-  "Tries very hard to make sense out of the argument time-string and
-   returns a single integer representing the universal time if
-   successful.  If not, it returns nil.  If the :error-on-mismatch
-   keyword is true, parse-time will signal an error instead of
-   returning nil.  Default values for each part of the time/date
-   can be specified by the appropriate :default- keyword.  These
-   keywords can be given a numeric value or the keyword :current
-   to set them to the current value.  The default-default values
-   are 00:00:00 on the current date, current time-zone."
-  (setq *error-on-mismatch* error-on-mismatch)
-  (let* ((string-parts (decompose-string time-string))
-	 (parts-length (length string-parts))
-	 (string-form (dolist (pattern patterns)
-			(let ((match-result (match-pattern pattern
-							   string-parts
-							   parts-length)))
-			  (if match-result (return match-result))))))
-    (if string-form
-	(let ((parsed-values (make-default-time default-seconds default-minutes
-						default-hours default-day
-						default-month default-year
-						default-zone default-weekday)))
-	  (set-time-values string-form parsed-values)
-	  (convert-to-unitime parsed-values))
-	(if *error-on-mismatch*
-	  (error "\"~A\" is not a recognized time/date format." time-string)
-	  nil))))
-
-
diff --git a/code/pmax-disassem.lisp b/code/pmax-disassem.lisp
deleted file mode 100644
index ca3ab2184360892efd2ed8534794d513ffe248ac..0000000000000000000000000000000000000000
--- a/code/pmax-disassem.lisp
+++ /dev/null
@@ -1,473 +0,0 @@
-;;; -*- Mode: Lisp; Package: MIPS -*-
-;;; 
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pmax-disassem.lisp,v 1.11 1990/02/24 17:07:35 wlott Exp $
-;;;
-;;; A simple dissambler for the MIPS R2000.
-;;;
-;;; Written by Christopher Hoover.
-;;; 
-
-(in-package "MIPS" :use '("LISP"))
-
-(export '(register-name disassemble-code-vector))
-
-
-;;;; Instruction Layout
-
-;;;
-;;; Each instrunction on the MIPS R2000 consists of a single word (32
-;;; bits) aligned on a single word boundaray.  There are three
-;;; instrunction formats:
-;;; 
-;;; 	I-Type (Immediate)
-;;;
-;;; 	3 3 2 2 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0
-;;; 	1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0
-;;;     ---------------------------------------------------------------
-;;;	[   op    ] [  rs   ] [  rt   ] [         immediate           ]
-;;;     ---------------------------------------------------------------
-;;;
-;;; 
-;;;	J-Type (Jump)
-;;;
-;;; 	3 3 2 2 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0
-;;; 	1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0
-;;;     ---------------------------------------------------------------
-;;;	[   op    ] [                target                           ]
-;;;     ---------------------------------------------------------------
-;;;
-;;;
-;;; 	R-Type (Register)
-;;;
-;;; 	3 3 2 2 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0
-;;; 	1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0
-;;;     ---------------------------------------------------------------
-;;;	[   op    ] [  rs   ] [  rt   ] [  rd   ] [ shmat ] [  funct  ]
-;;;     ---------------------------------------------------------------
-;;;
-;;; These instructions fall into 5 categories: Load/Store,
-;;; Computational, Jump/Branch, Coprocessor, and Special.
-;;;
-
-
-;;;; Register Names
-
-(defparameter register-name-style :lisp
-  "The register name style: :c, :lisp, :raw")
-
-(defvar *c-register-names*
-  '#("ZERO" "$AT" "$V0" "$V1" "$A0" "$A1" "$A2" "$A3"
-     "$T0" "$T1" "$T2" "$T3" "$T4" "$T5" "$T6" "$T7"
-     "$S0" "$S1" "$S2" "$S3" "$S4" "$S5" "$S6" "$S7"
-     "$T8" "$T9" "$K0" "$K1" "$GP" "$SP" "$S8" "$RA"))
-
-(defvar *lisp-register-names*
-  '#("$ZERO" "$LIP" "$NL0" "$NL1" "$NL2" "$NL3" "$NL4" "$NARGS"
-     "$A0" "$A1" "$A2" "$A3" "$A4" "$A5" "$CNAME" "$LEXENV"
-     "$ARGS" "$OLDCONT" "$LRA" "$L0" "$NULL" "$BSP" "$CONT" "$CSP"
-     "$FLAGS" "$ALLOC" "$K0" "$K1" "$L1" "$NSP" "$CODE" "$L2"))
-
-(defvar *raw-register-names*
-  '#("$R0" "$R1" "$R2" "$R3" "$R4" "$R5" "$R6" "$R7"
-     "$R8" "$R9" "$R10" "$R12" "$R13" "$R14" "$R15"
-     "$R16" "$R17" "$R18" "$R19" "$R20" "$R21" "$R22" "$R23"
-     "$R24" "$R25" "$R26" "$R27" "$R28" "$R29" "$R30" "$R31"))
-
-(defun register-name (register-number)
-  (unless (<= 0 register-number 31)
-    (error "Illegal register number!"))
-  (let ((register-names (ecase register-name-style
-			  (:c *c-register-names*)
-			  (:lisp *lisp-register-names*)
-			  (:raw *raw-register-names*))))
-    (svref register-names register-number)))
-
-
-;;;; Instruction Type Definition
-
-;;;
-;;; These instruction types correspond to the various ways the decoded
-;;; instructions are printed which in turn corresponds somewhat to the
-;;; way the instructions are decoded.
-;;; 
-
-(defvar *mips-instruction-types* (make-hash-table :test #'eq))
-
-(defmacro def-mips-instruction-type (types &body body)
-  `(let ((closure #'(lambda (name word stream) ,@body)))
-     (dolist (type ',types)
-       (when (gethash type *mips-instruction-types*)
-	 (warn "Instruction type ~S being redefined" type))
-       (setf (gethash type *mips-instruction-types*) closure))))
-
-(defun mips-instruction-type-p (type)
-  (not (not (gethash type *mips-instruction-types*))))
-
-
-;;;; Instruction Types
-
-;;;
-;;; Used later for relative branches.
-(defvar *current-instruction-number* 0)
-
-(def-mips-instruction-type (:ls-type)
-  (let ((rs (ldb (byte 5 21) word))
-	(rt (ldb (byte 5 16) word))
-	(immed (signed-ldb (byte 16 0) word)))
-    (format stream "~16,8T~A~8,8T~A, #x~X(~A)~%"
-	    name (register-name rt) immed (register-name rs))))
-
-(def-mips-instruction-type (:si-type)
-  (let ((rs (ldb (byte 5 21) word))
-	(rt (ldb (byte 5 16) word))
-	(immed (signed-ldb (byte 16 0) word)))
-    (cond ((and (zerop rs) (or (string= name "ADDI") (string= name "ADDIU")))
-	   (format stream "~16,8TLOADI~8,8T~A, #x~X~%"
-		   (register-name rt) immed))
-	  ((and (= rs c::null-offset) (string= name "ADDI")
-		(eq register-name-style :lisp))
-	   ;; Major hack ...
-	   (format stream "~16,8T~A~8,8T~A, ~A, #x~X~48,8T; ~S~%"
-		   name (register-name rt) (register-name rs) immed
-		   (vm:offset-static-symbol immed)))
-	  (t
-	   (format stream "~16,8T~A~8,8T~A, ~A, #x~X~%"
-		   name (register-name rt) (register-name rs) immed)))))
-
-(def-mips-instruction-type (:ui-type)
-  (let ((rs (ldb (byte 5 21) word))
-	(rt (ldb (byte 5 16) word))
-	(immed (ldb (byte 16 0) word)))
-    (cond ((and (zerop rs) (or (string= name "ORI") (string= name "XORI")))
-	   (format stream "~16,8TLOADI~8,8T~A, #x~X~%"
-		   (register-name rt) immed))
-	  (t
-	   (format stream "~16,8T~A~8,8T~A, ~A, #x~X~%"
-		   name (register-name rt) (register-name rs) immed)))))
-
-(def-mips-instruction-type (:lui-type)
-  (let ((rt (ldb (byte 5 16) word))
-	(immed (ldb (byte 16 0) word)))
-    (format stream "~16,8T~A~8,8T~A, #x~X~%" name (register-name rt) immed)))
-
-(def-mips-instruction-type (:j-type)
-  (let ((target (ldb (byte 26 0) word)))
-    (format stream "~16,8T~A~8,8Ttarget = ~D~%" name target)))
-
-(def-mips-instruction-type (:jr-type)
-  (let ((rs (ldb (byte 5 21) word)))
-    (format stream "~16,8T~A~8,8T~A~%" name (register-name rs))))
-
-(def-mips-instruction-type (:jalr-type)
-  (let ((rs (ldb (byte 5 21) word))
-	(rd (ldb (byte 5 11) word)))
-    (format stream "~16,8T~A~8,8T~A, ~A~%" name
-	    (register-name rd) (register-name rs))))
-
-(defun branch-target (offset)
-  (+ *current-instruction-number* offset 1))
-
-(def-mips-instruction-type (:branch-type)
-  (let ((rs (ldb (byte 5 21) word))
-	(offset (signed-ldb (byte 16 0) word)))
-    (format stream "~16,8T~A~8,8T~A, ~D~%" name
-	    (register-name rs) (branch-target offset))))
-
-(def-mips-instruction-type (:branch2-type)
-  (let* ((rs (ldb (byte 5 21) word))
-	 (rt (ldb (byte 5 16) word))
-	 (offset (signed-ldb (byte 16 0) word))
-	 (target (branch-target offset)))
-    (cond ((and (zerop rs) (zerop rt) (string= name "BEQ"))
-	   (format stream "~16,8TB~8,8T~D~%" target))
-	  (t
-	   (format stream "~16,8T~A~8,8T~A, ~A, ~D~%" name
-		   (register-name rs) (register-name rt) target)))))
-
-(def-mips-instruction-type (:r3-type)
-  (let ((rs (ldb (byte 5 21) word))
-	(rt (ldb (byte 5 16) word))
-	(rd (ldb (byte 5 11) word)))
-    (cond ((zerop rd)
-	   ;; Hack for NOP
-	   (format stream "~16,8TNOP~%"))
-	  ((and (zerop rt) (or (string= name "OR") (string= name "ADDU")))
-	   ;; Hack for MOVE
-	   (format stream "~16,8TMOVE~8,8T~A, ~A~%"
-		   (register-name rd) (register-name rs)))
-	  (t
-	   (format stream "~16,8T~A~8,8T~A, ~A, ~A~%"
-		   name (register-name rd) (register-name rs)
-		   (register-name rt))))))
-
-(def-mips-instruction-type (:mf-type)
-  (let ((rd (ldb (byte 5 11) word)))
-    (format stream "~16,8T~A~8,8T~A~%" name (register-name rd))))
-
-(def-mips-instruction-type (:mt-type)
-  (let ((rs (ldb (byte 5 21) word)))
-    (format stream "~16,8T~A~8,8T~A~%" name (register-name rs))))
-
-(def-mips-instruction-type (:mult-type)
-  (let ((rs (ldb (byte 5 21) word))
-	(rt (ldb (byte 5 16) word)))
-    (format stream "~16,8T~A~8,8T~A, ~A~%" name
-	    (register-name rs) (register-name rt))))
-
-(def-mips-instruction-type (:shift-type)
-  (let ((rt (ldb (byte 5 16) word))
-	(rd (ldb (byte 5 11) word))
-	(shamt (ldb (byte 5 6) word)))
-    ;; Hack for NOP
-    (cond ((= word 0)
-	   (format stream "~16,8TNOP~%"))
-	  (t
-	   (format stream "~16,8T~A~8,8T~A, ~A, #x~X~%"
-		   name (register-name rd) (register-name rt) shamt)))))
-
-(def-mips-instruction-type (:shiftv-type)
-  (let ((rs (ldb (byte 5 21) word))
-	(rt (ldb (byte 5 16) word))
-	(rd (ldb (byte 5 11) word)))
-    (format stream "~16,8T~A~8,8T~A, ~A, ~A~%"
-	    name (register-name rd) (register-name rt) (register-name rs))))
-
-(def-mips-instruction-type (:break-type)
-  (let ((code (ldb (byte 10 16) word))) ; The entire field is (byte 20 6)
-    (format stream "~16,8T~A~8,8T#x~X~%" name code)))
-
-(def-mips-instruction-type (:syscall-type)
-  (declare (ignore word))
-  (format stream "~16,8T~A~%" name))
-
-(def-mips-instruction-type (:cop0-type :cop1-type :cop2-type :cop3-type)
-  (format stream "~16,8T~A~8,8T(#x~X)~%" name word))
-
-
-;;;; Instruction Definition
-
-(defstruct (mips-instruction
-	    (:constructor make-mips-instruction (name type))
-	    (:print-function %print-mips-instruction))
-  (name "" :type simple-string)
-  type)
-
-(defun %print-mips-instruction (instr stream depth)
-  (declare (ignore depth))
-  (format stream "#<MIPS instruction ~A>" (mips-instruction-name instr)))
-
-
-(defconstant mips-instruction-bits 6)
-
-(defvar *mips-instructions*
-  (make-array (ash 1 mips-instruction-bits)))
-(proclaim '(type *mips-instructions* 'simple-vector))
-
-(defmacro def-mips-instr (name op-code type)
-  `(let ((name ,name)
-	 (type ,type))
-     (unless (mips-instruction-type-p type)
-       (warn "~S is an unknown instruction type" type))
-     (setf (svref *mips-instructions* ,op-code)
-	   (make-mips-instruction name ,type))
-     name))
-
-
-(defconstant mips-special-instruction-bits 6)
-
-(defvar *mips-special-instructions*
-  (make-array (ash 1 mips-special-instruction-bits)))
-(proclaim '(type *mips-special-instructions* 'simple-vector))
-
-(defmacro def-mips-special-instr (name op-code type)
-  `(let ((name ,name)
-	 (type ,type))
-     (unless (mips-instruction-type-p type)
-       (warn "~S is an unknown instruction type" type))
-     (setf (svref *mips-special-instructions* ,op-code)
-	   (make-mips-instruction name ,type))
-     name))
-
-
-(defconstant mips-bcond-instruction-bits 6)
-
-(defvar *mips-bcond-instructions*
-  (make-array (ash 1 mips-bcond-instruction-bits)))
-(proclaim '(type *mips-bcond-instructions* 'simple-vector))
-
-(defmacro def-mips-bcond-instr (name op-code type)
-  `(let ((name ,name)
-	 (type ,type))
-     (unless (mips-instruction-type-p type)
-       (warn "~S is an unknown instruction type" type))
-     (setf (svref *mips-bcond-instructions* ,op-code)
-	   (make-mips-instruction name ,type))
-     name))
-
-
-;;;; Normal Opcodes
-
-(def-mips-instr "J" #b000010 :j-type)
-(def-mips-instr "JAL" #b000011 :j-type)
-(def-mips-instr "BEQ" #b000100 :branch2-type)
-(def-mips-instr "BNE" #b000101 :branch2-type)
-(def-mips-instr "BLEZ" #b000110 :branch-type)
-(def-mips-instr "BGTZ" #b000111 :branch-type)
-
-(def-mips-instr "ADDI" #b001000 :si-type)
-(def-mips-instr "ADDIU" #b001001 :si-type)
-(def-mips-instr "SLTI" #b001010 :si-type)
-(def-mips-instr "SLTIU" #b001011 :si-type)
-(def-mips-instr "ANDI" #b001100 :ui-type)
-(def-mips-instr "ORI" #b001101 :ui-type)
-(def-mips-instr "XORI" #b001110 :ui-type)
-(def-mips-instr "LUI" #b001111 :lui-type)
-
-(def-mips-instr "COP0" #b010000 :cop0-type)
-(def-mips-instr "COP1" #b010001 :cop1-type)
-(def-mips-instr "COP2" #b010010 :cop2-type)
-(def-mips-instr "COP3" #b010011 :cop3-type)
-
-(def-mips-instr "LB" #b100000 :ls-type)
-(def-mips-instr "LH" #b100001 :ls-type)
-(def-mips-instr "LWL" #b100010 :ls-type)
-(def-mips-instr "LW" #b100011 :ls-type)
-(def-mips-instr "LBU" #b100100 :ls-type)
-(def-mips-instr "LHU" #b100101 :ls-type)
-(def-mips-instr "LWR" #b100110 :ls-type)
-
-(def-mips-instr "SB" #b101000 :ls-type)
-(def-mips-instr "SH" #b101001 :ls-type)
-(def-mips-instr "SWL" #b101010 :ls-type)
-(def-mips-instr "SW" #b101011 :ls-type)
-(def-mips-instr "SWR" #b101110 :ls-type)
-
-(def-mips-instr "LWC0" #b110000 :cop0-type)
-(def-mips-instr "LWC1" #b110001 :cop1-type)
-(def-mips-instr "LWC2" #b110010 :cop2-type)
-(def-mips-instr "LWC3" #b110011 :cop3-type)
-
-(def-mips-instr "SWC0" #b111000 :cop0-type)
-(def-mips-instr "SWC1" #b111001 :cop1-type)
-(def-mips-instr "SWC2" #b111010 :cop2-type)
-(def-mips-instr "SWC3" #b111011 :cop3-type)
-
-
-;;;; SPECIAL Opcodes
-
-(defconstant special-op #b000000)
-
-(def-mips-special-instr "SLL" #b000000 :shift-type)
-(def-mips-special-instr "SRL" #b000010 :shift-type)
-(def-mips-special-instr "SRA" #b000011 :shift-type)
-(def-mips-special-instr "SLLV" #b000100 :shiftv-type)
-(def-mips-special-instr "SRLV" #b000110 :shiftv-type)
-(def-mips-special-instr "SRAV" #b000111 :shiftv-type)
-
-(def-mips-special-instr "JR" #b001000 :jr-type)
-(def-mips-special-instr "JALR" #b001001 :jalr-type)
-(def-mips-special-instr "SYSCALL" #b001100 :syscall-type)
-(def-mips-special-instr "BREAK" #b001101 :break-type)
-
-(def-mips-special-instr "MFHI" #b010000 :mf-type)
-(def-mips-special-instr "MTHI" #b010001 :mt-type)
-(def-mips-special-instr "MFLO" #b010010 :mf-type)
-(def-mips-special-instr "MTLO" #b010011 :mt-type)
-
-(def-mips-special-instr "MULT" #b011000 :mult-type)
-(def-mips-special-instr "MULTU" #b011001 :mult-type)
-(def-mips-special-instr "DIV" #b011010 :mult-type)
-(def-mips-special-instr "DIVU" #b011011 :mult-type)
-
-(def-mips-special-instr "ADD" #b100000 :r3-type)
-(def-mips-special-instr "ADDU" #b100001 :r3-type)
-(def-mips-special-instr "SUB" #b100010 :r3-type)
-(def-mips-special-instr "SUBU" #b100011 :r3-type)
-(def-mips-special-instr "AND" #b100100 :r3-type)
-(def-mips-special-instr "OR" #b100101 :r3-type)
-(def-mips-special-instr "XOR" #b100110 :r3-type)
-(def-mips-special-instr "NOR" #b100111 :r3-type)
-
-(def-mips-special-instr "SLT" #b101010 :r3-type)
-(def-mips-special-instr "SLTU" #b101011 :r3-type)
-
-
-;;;; BCOND Opcodes
-
-(defconstant bcond-op #b000001)
-
-(def-mips-bcond-instr "BLTZ" #b00000 :branch-type)
-(def-mips-bcond-instr "BLTZAL" #b00001 :branch-type)
-
-(def-mips-bcond-instr "BLTZAL" #b10000 :branch-type)
-(def-mips-bcond-instr "BGEZAL" #b10001 :branch-type)
-
-
-;;;; Signed-Ldb
-
-(defun signed-ldb (byte-spec integer)
-  (let ((unsigned (ldb byte-spec integer))
-	(length (byte-size byte-spec)))
-    (if (logbitp (1- length) unsigned)
-	(- unsigned (ash 1 length))
-	unsigned)))
-
-
-;;;; Instruction Decoding
-
-(defun mips-instruction (word)
-  (let* ((opcode (ldb (byte 6 26) word)))
-    (cond ((= opcode special-op)
-	   (let ((function (ldb (byte 6 0) word)))
-	     (svref *mips-special-instructions* function)))
-	  ((= opcode bcond-op)
-	   (let ((cond (ldb (byte 5 16) word)))
-	     (svref *mips-bcond-instructions* cond)))
-	  (t
-	   (svref *mips-instructions* opcode)))))
-
-
-;;;; Disassemble-Instruction
-
-(defun disassemble-instruction (word &optional (stream t))
-  (let* ((instr (mips-instruction word)))
-    (cond (instr
-	   (let* ((instr-name (mips-instruction-name instr))
-		  (instr-type (mips-instruction-type instr))
-		  (closure (gethash instr-type *mips-instruction-types*)))
-	     (cond (closure
-		    (funcall closure instr-name word stream))
-		   (t
-		    (format stream "UNKNOWN TYPE (~A/~S/#x~X)~%"
-			    instr-name instr-type word)))
-	     (values instr-name instr-type)))
-	  (t
-	   (format stream "~16,8TDATA~8,8T#x~X~%" word)
-	   (return-from disassemble-instruction (values nil nil))))))
-
-
-
-;;; Dissassemble-Code-Vector
-
-(defconstant delay-slot-instruction-types
-  '(:j-type :jr-type :jalr-type :branch-type :branch2-type))
-
-(defun disassemble-code-vector (code-vector length &optional (stream t))
-  (do ((i 0 (+ i 4))
-       (*current-instruction-number* 0 (1+ *current-instruction-number*))
-       (instruction-in-delay-slot-p nil))
-      ((>= i length))
-    (unless instruction-in-delay-slot-p
-      (format stream "~6D:" *current-instruction-number*))
-    (multiple-value-bind
-	(name type)
-	(disassemble-instruction (logior (aref code-vector i)
-					 (ash (aref code-vector (+ i 1)) 8)
-					 (ash (aref code-vector (+ i 2)) 16)
-					 (ash (aref code-vector (+ i 3)) 24))
-				 stream)
-      (declare (ignore name))
-      (cond ((member type delay-slot-instruction-types :test #'eq)
-	     (setf instruction-in-delay-slot-p t))
-	    (t
-	     (setf instruction-in-delay-slot-p nil))))))
diff --git a/code/pprint.lisp b/code/pprint.lisp
deleted file mode 100644
index 5eddd974bba763aab8daef4eb7a931b220eeed06..0000000000000000000000000000000000000000
--- a/code/pprint.lisp
+++ /dev/null
@@ -1,90 +0,0 @@
-;;; -*- Log: code.log; Package: Lisp -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; CMU Common Lisp pretty printer.
-;;; Written by Skef Wholey.
-;;; Modified by Todd Kaufmann, Bill Chiles, Rob Maclachlan, William Lott.
-;;;
-
-(in-package "LISP")
-(export '(pprint))
-
-
-(in-package "EXTENSIONS")
-(export '(grindef))
-(in-package "LISP")
-#|
-(defun pprin1 (object &optional stream)
-  "Prettily outputs the Object to the Stream slashifying special characters."
-  (xp::prin1 object stream)
-  (values))
-
-(defun pprinc (object &optional stream)
-  "Prettily outputs the Object to the Stream without slashifying."
-  (xp::princ object stream)
-  (values))
-|#
-
-(defun pprint (object &optional stream)
-  "Prettily outputs the Object preceded by a newline and followed by a space."
-  (xp::pprint object stream)
-  (values))
-
-;;; OUTPUT-PRETTY-OBJECT is called by WRITE, PRIN1, PRINC, and their associated
-;;; ...-TO-STRING forms when *print-pretty* is non-nil.  Calling this when
-;;; *print-pretty* is nil could cause XP and our system to recursively call
-;;; each other for a very long time.  Stream has already been set correctly
-;;; according the semantics in the manual with respect to t and nil.
-;;;
-(defun output-pretty-object (object stream)
-  (assert *print-pretty*)
-  (typecase object
-    ((or list structure vector array)
-     (xp::basic-write object stream))
-    (t (let ((*print-pretty* nil))
-	 (output-object object stream)))))
-
-(defun pretty-lambda-to-defun (name lambda &optional arglist)
-  `(defun ,name ,(or arglist (cadr lambda))
-     ,@(if (and (null (cdddr lambda)) (listp (caddr lambda))
-		(eq (caaddr lambda) 'block))
-	   (cddr (caddr lambda))
-	   (cddr lambda))))
-
-(defmacro grindef (function-name)
- "Prettily prints the definition of the function whose name is Function-Name."
- (if (and (symbolp function-name) (fboundp function-name))
-     (let ((stuff (symbol-function function-name)))
-       (if (and (listp stuff) (listp (cdr stuff)))
-	   (case (car stuff)
-	     (lambda `(pprint ',(pretty-lambda-to-defun function-name stuff)))
-	     (macro `(pprint ',(pretty-lambda-to-defun function-name (cdr stuff)
-						       '(&rest **macroarg**))))
-	     (t `(pprint '(setf (symbol-function ,function-name) ',stuff))))
-	   `(pprint '(setf (symbol-function ,function-name) ',stuff))))
-     nil))
-
-
-;;; Tab-Over prints the specified number of spaces on *Standard-Output*.
-;;; Taken from the old pretty printer.  Needed by some function in filesys.
-(defconstant maximum-pp-indentation 70)
-(defconstant pp-indentation-string (make-string 70 :initial-element #\space))
-
-(defun tab-over (indent-pos)
-  (write-string pp-indentation-string *standard-output*
-		:start 0
-		:end (min indent-pos maximum-pp-indentation)))
-
-;;; Initialize Water's pretty printer.
-(defun pprint-init ()
-  (xp::install :shadow nil)
-  (define-print-dispatch (cons (and symbol (satisfies fboundp)))
-			 ((:priority 5) (:table *print-dispatch*))
-    #'fill-style))
-
diff --git a/code/pred.lisp b/code/pred.lisp
deleted file mode 100644
index 204ebc019fecc0a3d8bd7f301e47bc0f2a5a7c3b..0000000000000000000000000000000000000000
--- a/code/pred.lisp
+++ /dev/null
@@ -1,602 +0,0 @@
-;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; Predicate functions for Spice Lisp.
-;;; The type predicates are implementation-specific.  A different version
-;;;   of this file will be required for implementations with different
-;;;   data representations.
-;;;
-;;; Written and currently maintained by Scott Fahlman.
-;;; Based on an earlier version by Joe Ginder.
-;;;
-(in-package 'lisp)
-(export '(typep null symbolp atom consp listp numberp integerp rationalp
-	  floatp complexp characterp stringp bit-vector-p vectorp
-	  simple-vector-p simple-string-p simple-bit-vector-p arrayp
-	  functionp compiled-function-p commonp eq eql equal equalp not
-	  type-of
-	  ;; Names of types...
-	  array atom bignum bit bit-vector character common
-	  compiled-function complex cons double-float
-	  fixnum float function integer keyword list long-float nil
-	  null number ratio rational sequence short-float signed-byte
-	  simple-array simple-bit-vector simple-string simple-vector
-	  single-float standard-char string string-char symbol t
-	  unsigned-byte vector structure satisfies))
-
-(in-package "EXTENSIONS")
-(export '(structurep fixnump bignump bitp ratiop))
-(in-package "LISP")
-
-
-;;; Data type predicates.
-
-;;; Translation from type keywords to specific predicates.  Assumes that
-;;; the following are named structures and need no special type hackery:
-;;; PATHNAME, STREAM, READTABLE, PACKAGE, HASHTABLE, RANDOM-STATE.
-
-(defconstant type-pred-alist
-  '((keyword . keywordp)
-    (common . commonp)
-    (null . null)
-    (cons . consp)
-    (list . listp)
-    (symbol . symbolp)
-    (array . arrayp)
-    (vector . vectorp)
-    (bit-vector . bit-vector-p)
-    (string . stringp)
-    (sequence . sequencep)
-    (simple-array . simple-array-p)
-    (simple-vector . simple-vector-p)
-    (simple-string . simple-string-p)
-    (simple-bit-vector . simple-bit-vector-p)
-    (function . functionp)
-    (compiled-function . compiled-function-p)
-    (character . characterp)
-    (number . numberp)
-    (rational . rationalp)
-    (float . floatp)
-    (string-char . %string-char-p)
-    (integer . integerp)
-    (ratio . ratiop)
-    (short-float . short-float-p)
-    (standard-char . %standard-char-p)
-    (fixnum . fixnump)
-    (complex . complexp)
-;    (single-float . single-float-p)
-    (single-float . short-float-p)
-    (bignum . bignump)
-    (double-float . double-float-p)
-    (bit . bitp)
-    (long-float . long-float-p)
-    (structure . structurep)
-    (atom . atom)))
-
-
-;;;; TYPE-OF and auxiliary functions.
-
-(defun type-of (object)
-  "Returns the type of OBJECT as a type-specifier.
-  Since objects may be of more than one type, the choice is somewhat
-  arbitrary and may be implementation-dependent."
-  (if (null object) 'symbol
-      (case (%primitive get-type object)
-	(#.%+-fixnum-type 'fixnum)
-	(#.%bignum-type 'bignum)
-	(#.%ratio-type 'ratio)
-	((#.%short-+-float-type #.%short---float-type) 'short-float)
-	(#.%long-float-type 'long-float)
-	(#.%complex-type 'complex)
-	(#.%string-type `(simple-string ,(%primitive vector-length object)))
-	(#.%bit-vector-type
-	 `(simple-bit-vector ,(%primitive vector-length object)))
-	(#.%integer-vector-type (type-of-i-vector object))
-	(#.%general-vector-type (type-of-g-vector object))
-	(#.%array-type (type-of-array object))
-	(#.%function-type 'function)
-	(#.%symbol-type 'symbol)
-	(#.%list-type 'cons)
-	(#.%string-char-type 'string-char)
-	(#.%bitsy-char-type 'character)
-	(#.%--fixnum-type 'fixnum)
-	(t 'random))))
-
-;;; %String-Char-P is called by typep when the type specification
-;;; is string-char.  The CL string-char-p does not do the right thing.
-(defun %string-char-p (x)
-  (and (characterp x)
-       (< (the fixnum (char-int x)) char-code-limit)))
-
-;;; Create the list-style description of a G-vector.
-
-(defun type-of-g-vector (object)
-  (cond ((structurep object) (svref object 0))
-	(t `(simple-vector ,(%primitive vector-length object)))))
-
-;;; I-Vector-Element-Type  --  Internal
-;;;
-;;;    Return a type specifier for the element type of an I-Vector.
-;;;
-(defun i-vector-element-type (object)
-  (let ((ac (%primitive get-vector-access-code object)))
-    (if (< 0 ac 6)
-	(svref '#((mod 2) (mod 4) (mod 16) (mod 256) (mod 65536)
-		  (mod 4294967296))
-	       ac)
-	(error "Invalid I-Vector access code: ~S" ac))))
-	
-;;; Create the list-style description of an I-vector.
-	
-(defun type-of-i-vector (object)
-  `(simple-array ,(i-vector-element-type object)
-		 ,(%primitive vector-length object)))
-
-
-;;; Create the list-style description of an array.
-
-(defun type-of-array (object)
-  (with-array-data ((data-vector object) (start) (end))
-    (declare (ignore start end))
-    (let ((rank (- (the fixnum (%primitive header-length object))
-		   %array-first-dim-slot))
-	  (length (%primitive header-ref object %array-length-slot)))
-      (declare (fixnum rank length))
-      (if (= rank 1)
-	  (typecase data-vector
-	    (simple-bit-vector `(bit-vector ,length))
-	    (simple-string `(string ,length))
-	    (simple-vector `(vector t ,length))
-	    (t `(vector ,(i-vector-element-type data-vector) ,length)))
-	  `(array
-	    ,(typecase data-vector
-	       (simple-bit-vector '(mod 2))
-	       (simple-string 'string-char)
-	       (simple-vector 't)
-	       (t (i-vector-element-type data-vector)))
-	    ,(array-dimensions object))))))
-
-;;;; TYPEP and auxiliary functions.
-
-(defun %typep (object type)
-  (let ((type (type-expand type))
-	temp)
-    (cond ((symbolp type)
-	   (cond ((or (eq type t) (eq type '*)) t)
-		 ((eq type 'nil) nil)
-		 ((setq temp (assq type type-pred-alist))
-		  (funcall (cdr temp) object))
-		 (t (structure-typep object type))))
-	  ((listp type) 
-	   ;; This handles list-style type specifiers.
-	   (case (car type)
-	     (vector (and (vectorp object)
-			  (vector-eltype object (cadr type))
-			  (test-length object (caddr type))))
-	     (simple-vector (and (simple-vector-p object)
-				 (test-length object (cadr type))))
-	     (string (and (stringp object)
-			  (test-length object (cadr type))))
-	     (simple-string (and (simple-string-p object)
-				 (test-length object (cadr type))))
-	     (bit-vector (and (bit-vector-p object)
-			      (test-length object (cadr type))))
-	     (simple-bit-vector (and (simple-bit-vector-p object)
-				     (test-length object (cadr type))))
-	     (array (array-typep object type))
-	     (simple-array (and (not (array-header-p object))
-				(array-typep object type)))
-	     (satisfies (funcall (cadr type) object))
-	     (member (member object (cdr type)))
-	     (not (not (typep object (cadr type))))
-	     (or (dolist (x (cdr type) nil)
-		   (if (typep object x) (return t))))
-	     (and (dolist (x (cdr type) t)
-		    (if (not (typep object x)) (return nil))))
-	     (integer (and (integerp object) (test-limits object type)))
-	     (rational (and (rationalp object) (test-limits object type)))
-	     (float (and (floatp object) (test-limits object type)))
-	     (short-float (and (short-float-p object)
-			       (test-limits object type)))
-	     (single-float (and (single-float-p object)
-				(test-limits object type)))
-	     (double-float (and (double-float-p object)
-				(test-limits object type)))
-	     (long-float (and (long-float-p object)
-			      (test-limits object type)))
-	     (mod (and (integerp object)
-		       (>= object 0)
-		       (< object (cadr type))))
-	     (signed-byte
-	      (and (integerp object)
-		   (let ((n (cadr type)))
-		     (or (not n) (eq n '*)
-			 (> n (integer-length object))))))
-	     (unsigned-byte
-	      (and (integerp object)
-		   (not (minusp object))
-		   (let ((n (cadr type)))
-		     (or (not n) (eq n '*)
-			 (>= n (integer-length object))))))
-	     (complex (and (numberp object)
-			   (or (not (cdr type))
-			       (typep (realpart object) (cadr type)))))
-	     (t (error "~S -- Illegal type specifier to TYPEP."  type))))
-	  (t (error "~S -- Illegal type specifier to TYPEP."  type)))))
-
-(defun typep (obj type)
-  "Returns T if OBJECT is of the specified TYPE, otherwise NIL."
-  (declare (notinline %typep))
-  (%typep obj type))
-
-
-;;; Given that the object is a vector of some sort, and that we've already
-;;; verified that it matches CAR of TYPE, see if the rest of the type
-;;; specifier wins.  Mild hack: Eltype Nil means either type not supplied
-;;; or was Nil.  Any vector can hold objects of type Nil, since there aren't
-;;; any, so (vector nil) is the same as (vector *).
-;;;
-(defun vector-eltype (object eltype)
-  (let ((data (if (array-header-p object)
-		  (with-array-data ((data object) (start) (end))
-		    (declare (ignore start end))
-		    data)
-		  object))
-	(eltype (type-expand eltype)))
-    (case eltype
-      ((t) (simple-vector-p data))
-      (string-char (simple-string-p data))
-      (bit (simple-bit-vector-p data))
-      ((* nil) t)
-      (t
-       (subtypep eltype
-		 (cond ((simple-vector-p data) t)
-		       ((simple-string-p data) 'string-char)
-		       ((simple-bit-vector-p data) 'bit)
-		       (t
-			(i-vector-element-type data))))))))
-
-
-;;; Test sequence for specified length.
-
-(defun test-length (object length)
-  (or (null length)
-      (eq length '*)
-      (= length (length object))))
-
-
-;;; See if object satisfies the specifier for an array.
-
-(defun array-typep (object type)
-  (and (arrayp object)
-       (vector-eltype object (cadr type))
-       (if (cddr type)
-	   (let ((dims (third type)))
-	     (cond ((eq dims '*) t)
-		   ((numberp dims)
-		    (and (vectorp object)
-			 (= (the fixnum (length (the vector object)))
-			    (the fixnum dims))))
-		   (t
-		    (dotimes (i (array-rank object) (null dims))
-		      (when (null dims) (return nil))
-		      (let ((dim (pop dims)))
-			(unless (or (eq dim '*)
-				    (= dim (array-dimension object i)))
-			  (return nil)))))))
-	   t)))
-
-
-;;; Test whether a number falls within the specified limits.
-
-(defun test-limits (object type)
-  (let ((low (cadr type))
-	(high (caddr type)))
-    (and (cond ((null low) t)
-	       ((eq low '*) t)
-	       ((numberp low) (>= object low))
-	       ((and (consp low) (numberp (car low)))
-		(> object (car low)))
-	       (t nil))
-	 (cond ((null high) t)
-	       ((eq high '*) t)
-	       ((numberp high) (<= object high))
-	       ((and (consp high) (numberp (car high)))
-		(< object (car high)))
-	       (t nil)))))
-
-
-;;; Structure-Typep  --  Internal
-;;;
-;;; This is called by Typep if the type-specifier is a symbol and is not one of
-;;; the built-in Lisp types.  If it's a structure, see if it's that type, or if
-;;; it includes that type.
-;;;
-(defun structure-typep (object type)
-  (declare (optimize speed))
-  (let ((type (type-expand type)))
-    (if (symbolp type)
-	(let ((info (info type defined-structure-info type)))
-	  (if info
-	      (and (structurep object)
-		   (let ((obj-name (%primitive header-ref object 0)))
-		     (or (eq obj-name type)
-			 (if (memq obj-name (c::dd-included-by info))
-			     t nil))))
-	      (error "~S is an unknown type specifier." type)))
-	(error "~S is an unknown type specifier." type))))
-
-
-;;;; Assorted mumble-P type predicates.
-
-(defun commonp (object)
-  "Returns T if object is a legal Common-Lisp type, NIL if object is any
-  sort of implementation-dependent or internal type."
-  (or (structurep object)
-      (let ((type-spec (type-of object)))
-	(if (listp type-spec) (setq type-spec (car type-spec)))
-	(when (memq type-spec
-		    '(character fixnum short-float single-float double-float
-				long-float vector string simple-vector
-				simple-string bignum ratio complex
-				compiled-function array symbol cons))
-	  T))))
-
-(defun bit-vector-p (object)
-  "Returns T if the object is a bit vector, else returns NIL."
-  (bit-vector-p object))
-
-;;; The following definitions are trivial because the compiler open-codes
-;;; all of these.
-
-(defun null (object)
-  "Returns T if the object is NIL, else returns NIL."
-  (null object))
-
-(defun not (object)
-  "Returns T if the object is NIL, else returns NIL."
-  (null object))
-
-(defun symbolp (object)
-  "Returns T if the object is a symbol, else returns NIL."
-  (symbolp object))
-
-(defun atom (object)
-  "Returns T if the object is not a cons, else returns NIL.
-  Note that (ATOM NIL) => T."
-  (atom object))
-
-(defun consp (object)
-  "Returns T if the object is a cons cell, else returns NIL.
-  Note that (CONSP NIL) => NIL."
-  (consp object))
-
-(defun listp (object)
-  "Returns T if the object is a cons cell or NIL, else returns NIL."
-  (listp object))
-
-(defun numberp (object)
-  "Returns T if the object is any kind of number."
-  (numberp object))
-
-(defun integerp (object)
-  "Returns T if the object is an integer (fixnum or bignum), else 
-  returns NIL."
-  (integerp object))
-
-(defun rationalp (object)
-  "Returns T if the object is an integer or a ratio, else returns NIL."
-  (rationalp object))
-
-(defun floatp (object)
-  "Returns T if the object is a floating-point number, else returns NIL."
-  (floatp object))
-
-(defun complexp (object)
-  "Returns T if the object is a complex number, else returns NIL."
-  (complexp object))
-
-(defun %standard-char-p (x)
-  (and (characterp x) (standard-char-p x)))
-
-(defun characterp (object)
-  "Returns T if the object is a character, else returns NIL."
-  (characterp object))
-
-(defun stringp (object)
-  "Returns T if the object is a string, else returns NIL."
-  (stringp object))
-
-(defun simple-string-p (object)
-  "Returns T if the object is a simple string, else returns NIL."
-  (simple-string-p object))
-
-(defun vectorp (object)
-  "Returns T if the object is any kind of vector, else returns NIL."
-  (vectorp object))
-
-(defun simple-array-p (object)
-  "Returns T if the object is a simple array, else returns NIL."
-  (and (arrayp object) (not (array-header-p object))))
-
-(defun simple-vector-p (object)
-  "Returns T if the object is a simple vector, else returns NIL."
-  (simple-vector-p object))
-
-(defun simple-bit-vector-p (object)
-  "Returns T if the object is a simple bit vector, else returns NIL."
-  (simple-bit-vector-p object))
-
-(defun arrayp (object)
-  "Returns T if the argument is any kind of array, else returns NIL."
-  (arrayp object))
-
-(defun functionp (object)
-  "Returns T if the object is a function, suitable for use by FUNCALL
-  or APPLY, else returns NIL."
-  (functionp object))
-
-(defun compiled-function-p (object)
-  "Returns T if the object is a compiled function object, else returns NIL."
-  (compiled-function-p object))
-
-;;; ### Dummy definition until we figure out what to really do...
-(defun clos::funcallable-instance-p (object)
-  (declare (ignore object))
-  nil)
-
-(defun sequencep (object)
-  "Returns T if object is a sequence, NIL otherwise."
-  (typep object 'sequence))
-
-
-;;; The following are not defined at user level, but are necessary for
-;;; internal use by TYPEP.
-
-(defun structurep (object)
-  (structurep object))
-
-(defun fixnump (object)
-  (fixnump object))
-
-(defun bignump (object)
-  (bignump object))
-
-(defun bitp (object)
-  (typep object 'bit))
-
-(defun short-float-p (object)
-  (typep object 'short-float))
-
-(defun single-float-p (object)
-  (typep object 'single-float))
-
-(defun double-float-p (object)
-  (typep object 'double-float))
-
-(defun long-float-p (object)
-  (typep object 'long-float))
-
-(defun ratiop (object)
-  (ratiop object))
-
-;;; Some silly internal things for tenser array hacking:
-
-(defun array-header-p (object)
-  (array-header-p object))
-
-;;;; Equality Predicates.
-
-(defun eq (x y)
-  "Returns T if X and Y are the same object, else returns NIL."
-  (eq x y))
-
-(defun eql (x y)
-  "Returns T if X and Y are EQ, or if they are numbers of the same
-  type and precisely equal value, or if they are characters and
-  are CHAR=, else returns NIL."
-  (eql x y))
-
-(defun equal (x y)
-  "Returns T if X and Y are EQL or if they are structured components
-  whose elements are EQUAL.  Strings and bit-vectors are EQUAL if they
-  are the same length and have indentical components.  Other arrays must be
-  EQ to be EQUAL."
-  (cond ((eql x y) t)
-	((consp x)
-	 (and (consp y)
-	      (equal (car x) (car y))
-	      (equal (cdr x) (cdr y))))
-	((stringp x)
-	 (and (stringp y) (string= x y)))
-	((pathnamep x)
-	 (and (pathnamep y)
-	      (do* ((i 1 (1+ i))
-		    (len (length x)))
-		   ((>= i len) t)
-		(declare (fixnum i len))
-		(let ((x-el (svref x i))
-		      (y-el (svref y i)))
-		  (if (and (simple-vector-p x-el)
-			   (simple-vector-p y-el))
-		      (let ((lx (length x-el))
-			    (ly (length y-el)))
-			(declare (fixnum lx ly))
-			(if (/= lx ly) (return nil))
-			(do ((i 0 (1+ i)))
-			    ((>= i lx))
-			  (declare (fixnum i))
-			  (if (not (equal (svref x-el i) (svref y-el i)))
-			      (return-from equal nil))))
-		      (unless (or (eql x-el y-el)
-				  (equal x-el y-el))
-			(return nil)))))))
-	((bit-vector-p x)
-	 (and (bit-vector-p y)
-	      (= (the fixnum (length x))
-		 (the fixnum (length y)))
-	      (do ((i 0 (1+ i))
-		   (length (length x)))
-		  ((= i length) t)
-		(declare (fixnum i))
-		(or (= (the fixnum (bit x i))
-		       (the fixnum (bit y i)))
-		    (return nil)))))
-	(t nil)))
-
-
-(defun equalp (x y)
-  "Just like EQUAL, but more liberal in several respects.
-  Numbers may be of different types, as long as the values are identical
-  after coercion.  Characters may differ in alphabetic case.  Vectors and
-  arrays must have identical dimensions and EQUALP elements, but may differ
-  in their type restriction."
-  (cond ((eql x y) t)
-	((characterp x) (char-equal x y))
-	((numberp x) (and (numberp y) (= x y)))
-	((consp x)
-	 (and (consp y)
-	      (equalp (car x) (car y))
-	      (equalp (cdr x) (cdr y))))
-	((vectorp x)
-	 (let ((length (length x)))
-	   (declare (fixnum length))
-	   (and (vectorp y)
-		(= length (the fixnum (length y)))
-		(dotimes (i length t)
-		  (let ((x-el (aref x i))
-			(y-el (aref y i)))
-		    (unless (or (eql x-el y-el)
-				(equalp x-el y-el))
-		      (return nil)))))))
-	((arrayp x)
-	 (let ((rank (array-rank x))
-	       (len (%primitive header-ref x %array-length-slot)))
-	   (declare (fixnum rank len))
-	   (and (arrayp y)
-		(= (the fixnum (array-rank y)) rank)
-		(dotimes (i rank t)
-		  (unless (= (the fixnum (array-dimension x i))
-			     (the fixnum (array-dimension y i)))
-		    (return nil)))
-		(with-array-data ((x-vec x) (x-start) (end))
-		  (declare (ignore end))
-		  (with-array-data ((y-vec y) (y-start) (end))
-		    (declare (ignore end))
-		    (do ((i x-start (1+ i))
-			 (j y-start (1+ j))
-			 (count len (1- count)))
-			((zerop count) t)
-		      (declare (fixnum i j count))
-		      (let ((x-el (aref x-vec i))
-			    (y-el (aref y-vec j)))
-			(unless (or (eql x-el y-el)
-				    (equalp x-el y-el))
-			  (return nil)))))))))
-	(t nil)))
diff --git a/code/print.lisp b/code/print.lisp
deleted file mode 100644
index 9ce5364f96ebd222ce5e120270c148900c3ad710..0000000000000000000000000000000000000000
--- a/code/print.lisp
+++ /dev/null
@@ -1,1261 +0,0 @@
-;;; -*- Log: code.log; Package: Lisp -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; CMU Common Lisp printer.
-;;;
-;;; Written by Neal Feinberg, Bill Maddox, Steven Handerson, and Skef Wholey.
-;;; Modified by various CMU Common Lisp maintainers.
-;;;
-
-(in-package "LISP")
-
-(export '(*print-escape* *print-pretty* *print-circle* *print-base*
-	  *print-radix* *print-case* *print-level* *print-length*
-	  *print-array* *print-gensym* write prin1 print princ
-	  write-to-string prin1-to-string princ-to-string))
-
-(defvar *print-escape* T
-  "Flag which indicates that slashification is on.  See the manual")
-(defvar *print-pretty* T
-  "Flag which indicates that pretty printing is to be used")
-(defvar *print-base* 10.
-  "The output base for integers and rationals.")
-(defvar *print-radix* ()
-  "This flag requests to verify base when printing rationals.")
-(defvar *print-level* ()
-  "How many levels deep to print.  Unlimited if null.")
-(defvar *print-length* ()
-  "How many elements to print on each level.  Unlimited if null.")
-(defvar *print-circle* ()
-  "Whether to worry about circular list structures. See the manual.")
-(defvar *print-case* ':upcase
-  "What kind of case the printer should use by default")
-(defvar *print-array* T
-  "Whether the array should print it's guts out")
-(defvar *print-gensym* T
-  "If true, symbols with no home package are printed with a #: prefix.
-  If false, no prefix is printed.")
-
-
-;;; Imported from reader.
-;;;
-(proclaim '(special *read-default-float-format*))
-
-;;; From the package system.
-;;;
-(proclaim '(special *package* *keyword-package*))
-
-
-;;; DOSTRING -- Internal.
-;;;
-;;; This macro returns code which maps over a string, binding VARIABLE to each
-;;; successive character in the string INIT-FORM, and executing BODY with
-;;; the variable so bound.  This function used to be part of Common Lisp, but
-;;; is no more.  It lives on in the printer, though.
-;;;
-(defmacro dostring ((variable init-form terminate-form) &rest body)
-  (let ((str (gensym))
-	(end (gensym))
-	(index (gensym)))
-    `(let* ((,str ,init-form)
-	    (,end (length (the string ,str)))
-	    (,index 0))
-       (declare (fixnum ,index ,end))
-       (loop
-	 (when (= ,index ,end) (return ,terminate-form))
-	 (let ((,variable (char ,str ,index)))
-	   ,@body)
-	 (incf ,index)))))
-
-
-
-;;;; Printing Functions
-
-(proclaim '(inline setup-printer-state))
-
-(defvar *previous-case* ()
-  "What the previous case selection the printer was set to.")
-
-;;; This variable contains the current definition of one of three symbol
-;;; printers.  SETUP-PRINTER-STATE sets this variable.
-;;;
-(defvar *internal-symbol-output-function* nil)
-
-;;; SETUP-PRINTER-STATE -- Internal.
-;;;
-;;; This function sets the internal global symbol
-;;; *internal-symbol-output-function* to the right function depending on the
-;;; value of *print-case*.  See the manual for details.  The print buffer
-;;; stream is also reset.
-;;;
-(defun setup-printer-state ()
-  (unless (eq *print-case* *previous-case*)
-    (setq *previous-case* *print-case*)
-    (setq *internal-symbol-output-function*
-	  (case *print-case*
-	    (:upcase #'output-uppercase-symbol)
-	    (:downcase #'output-lowercase-symbol)
-	    (:capitalize #'output-capitalize-symbol)
-	    (T (let ((bad-case *print-case*))
-		 (setq *print-case* :upcase)
-		 (Error "Invalid *print-case* value: ~s" bad-case)))))))
-
-
-(defun write (object &key
-		     ((:stream  stream)		     *standard-output*)
-		     ((:escape  *print-escape*)      *print-escape*)
-		     ((:radix   *print-radix*)       *print-radix*)
-		     ((:base    *print-base*)        *print-base*)
-		     ((:circle  *print-circle*)      *print-circle*)
-		     ((:pretty  *print-pretty*)      *print-pretty*)
-		     ((:level   *print-level*)       *print-level*)
-		     ((:length  *print-length*)      *print-length*)
-		     ((:case    *print-case*)        *print-case*)
-		     ((:array   *print-array*)       *print-array*)
-		     ((:gensym  *print-gensym*)      *print-gensym*))
-  "Outputs OBJECT to the specified stream, defaulting to *standard-output*"
-  (setup-printer-state)
-  (let ((stream (out-synonym-of stream)))
-    (if *print-pretty*
-	(output-pretty-object object stream)
-	(output-object object stream)))
-  object)
-
-(defun prin1 (object &optional stream)
-  "Outputs a mostly READable printed representation of OBJECT on the specified
-  stream."
-  (let ((stream (out-synonym-of stream)))
-    (setup-printer-state)
-    (let ((*print-escape* T))
-      (if *print-pretty*
-	  (output-pretty-object object stream)
-	  (output-object object stream)))
-    object))
-
-(defun princ (object &optional stream)
-  "Outputs an asthetic but not READable printed representation of OBJECT on the
-  specified stream."
-  (let ((stream (out-synonym-of stream)))
-    (setup-printer-state)
-    (let ((*print-escape* NIL))
-      (if *print-pretty*
-	  (output-pretty-object object stream)
-	  (output-object object stream)))
-    object))
-
-(defun print (object &optional stream)
-  "Outputs a terpri, the mostly READable printed represenation of OBJECT, and 
-  space to the stream."
-  (let ((stream (out-synonym-of stream)))
-    (terpri stream)
-    (prin1 object stream)
-    (write-char #\space stream)
-    object))
-
-(defun write-to-string (object &key
-		     ((:escape  *print-escape*)      *print-escape*)
-		     ((:radix   *print-radix*)       *print-radix*)
-		     ((:base    *print-base*)        *print-base*)
-		     ((:circle  *print-circle*)      *print-circle*)
-		     ((:pretty  *print-pretty*)      *print-pretty*)
-		     ((:level   *print-level*)       *print-level*)
-		     ((:length  *print-length*)      *print-length*)
-		     ((:case    *print-case*)        *print-case*)
-		     ((:array   *print-array*)       *print-array*)
-		     ((:gensym  *print-gensym*)      *print-gensym*))
-  "Returns the printed representation of OBJECT as a string."
-  (stringify-object object *print-escape*))
-
-(defun prin1-to-string (object)
-  "Returns the printed representation of OBJECT as a string with 
-   slashification on."
-  (stringify-object object t))
-
-(defun princ-to-string (object)
-  "Returns the printed representation of OBJECT as a string with
-  slashification off."
-  (stringify-object object nil))
-
-(defvar *print-string-stream* (make-string-output-stream)
-  "Holds the string stream for the x-TO-STRING functions.")
-
-(defvar *in-stringify-object* ()
-  "T if in the middle of stringify-object.")
-
-;;; STRINGIFY-OBJECT -- Internal.
-;;;
-;;; This produces the printed representation of an object as a string.  The
-;;; few ...-TO-STRING functions above call this.
-;;;
-(defun stringify-object (object &optional (*print-escape* nil))
-  (let ((stream (if *in-stringify-object*
-		    (make-string-output-stream)
-		    *print-string-stream*))
-	(*in-stringify-object* t))
-    (setup-printer-state)
-    (if *print-pretty*
-	(output-pretty-object object stream)
-	(output-object object stream 0))
-    (get-output-stream-string stream)))
-
-
-
-;;;; Central Print Functions.  
-
-;;; OUTPUT-OBJECT -- Internal.
-;;;
-;;; This takes an object and outputs its printed representation to stream,
-;;; which typically is the internal print stream.  This function is called
-;;; recursively by the sub-functions which know how to print structures which
-;;; can contain other lisp objects.
-;;;
-(defun output-object (object stream &optional (currlevel 0))
-  "Outputs a string which is the printed representation of the given object."
-  ;; First check and make sure we aren't too deep
-  (declare (fixnum currlevel))
-  (if (and (not (null *print-level*))
-	   (not (= *print-level* 0))
-	   (>= currlevel (the fixnum *print-level*)))
-      (write-char #\# stream)
-      (typecase object
-	    (symbol
-	     (if *print-escape*
-		 (output-symbol object stream)
-		 (case *print-case*
-		   (:upcase (write-string (symbol-name object) stream))
-		   (:downcase
-		    (let ((name (symbol-name object)))
-		      (declare (simple-string name))
-		      (dotimes (i (length name))
-			(write-char (char-downcase (char name i)) stream))))
-		   (:capitalize
-		    (write-string (string-capitalize (symbol-name object))
-				  stream)))))
-	    ;; If a list, go through element by element, being careful
-	    ;; about not running over the printlength
-	    (list
-	     (output-list object stream (1+ currlevel)))
-	    (string
-	     (if *print-escape*
-		 (quote-string object stream)
-		 (write-string object stream)))
-	    (integer
-	     (output-integer object stream))
-	    (float
-	     (output-float object stream))
-	    (ratio
-	     (output-ratio object stream))
-	    (complex
-	     (output-complex object stream))
-	    (structure
-	     (output-structure object stream currlevel))
-	    (character
-	     (output-character object stream))
-	    (vector
-	     (output-vector object stream))
-	    (array
-	     (output-array object stream (1+ currlevel))) 
-	    (t (output-random object stream)))))
-
-
-
-;;;; Symbol Printing Subfunctions
-
-(defun output-symbol (object stream)
-  (let ((package (symbol-package object))
-	(name (symbol-name object)))
-    (cond
-     ;; If the symbol's home package is the current one, then a
-     ;; prefix is never necessary.
-     ((eq package *package*))
-     ;; If the symbol is in the keyword package, output a colon.
-     ((eq package *keyword-package*)
-      (write-char #\: stream))
-     ;; Uninterned symbols print with a leading #:.
-     ((null package)
-      (when *print-gensym* (write-string "#:" stream)))
-     (t
-      (let ((found (car (memq package (package-use-list *package*)))))
-	(multiple-value-bind (symbol externalp)
-			     (find-external-symbol name package)
-	  ;; If the symbol's home package is in our use list and is an external
-	  ;; symbol there, then it needs no qualification.
-	  (unless (and found externalp (eq symbol object))
-	    (multiple-value-bind (symbol accessible)
-				 (find-symbol name *package*)
-	      ;; If we can find the symbol by looking it up, it need not be
-	      ;; qualified.  This can happen if the symbol has been inherited
-	      ;; from a package other than its home package.
-	      (unless (and accessible (eq symbol object))
-		(funcall *internal-symbol-output-function*
-			 (package-name package)
-			 stream)
-		(if externalp
-		    (write-char #\: stream)
-		    (write-string "::" stream)))))))))
-    (funcall *internal-symbol-output-function* name stream)))
-
-
-
-;;;; Escaping symbols:
-
-;;;    When we print symbols we have to figure out if they need to be
-;;; printed with escape characters.  This isn't a whole lot easier than
-;;; reading symbols in the first place.
-;;;
-;;; For each character, the value of the corresponding element is a fixnum
-;;; with bits set corresponding to attributes that the character has.  This
-;;; is also used by the character printer.
-;;;
-(defvar character-attributes
-  (make-array char-code-limit :element-type '(unsigned-byte 8)
-	      :initial-element 0))
-
-(eval-when (compile load eval)
-
-;;; Constants which are a bit-mask for each interesting character attribute.
-;;;
-(defconstant number-attribute	#b10)		; A numeric digit.
-(defconstant letter-attribute	#b100)		; A upper-case letter.
-(defconstant sign-attribute	#b1000)		; +-
-(defconstant extension-attribute #b10000)	; ^_
-(defconstant dot-attribute 	#b100000)	; .
-(defconstant slash-attribute	#b1000000)	; /
-(defconstant other-attribute	#b1)            ; Anything else legal.
-(defconstant funny-attribute	#b10000000)	; Anything illegal.
-
-(defconstant attribute-names
-  '((number . number-attribute) (letter . letter-attribute)
-    (sign . sign-attribute) (extension . extension-attribute)
-    (dot . dot-attribute) (slash . slash-attribute)
-    (other . other-attribute) (funny . funny-attribute)))
-
-); Eval-When (compile load eval)
-
-(flet ((set-bit (char bit)
-	 (let ((code (char-code char)))
-	   (setf (aref character-attributes code)
-		 (logior bit (aref character-attributes code))))))
-
-  (dolist (char '(#\! #\@ #\$ #\% #\& #\* #\= #\~ #\[ #\] #\{ #\}
-		  #\? #\< #\>))
-    (set-bit char other-attribute))
-
-  (dotimes (i 10)
-    (set-bit (digit-char i) number-attribute))
-
-  (do ((code (char-code #\A) (1+ code))
-       (end (char-code #\Z)))
-      ((> code end))
-    (declare (fixnum code end))
-    (set-bit (code-char code) letter-attribute))
-
-  (set-bit #\- sign-attribute)
-  (set-bit #\+ sign-attribute)
-  (set-bit #\^ extension-attribute)
-  (set-bit #\_ extension-attribute)
-  (set-bit #\. dot-attribute)
-  (set-bit #\/ slash-attribute)
-
-  ;; Make anything not explicitly allowed funny...
-  (dotimes (i char-code-limit)
-    (when (zerop (aref character-attributes i))
-      (setf (aref character-attributes i) funny-attribute))))
-
-;;; For each character, the value of the corresponding element is the lowest
-;;; base in which that character is a digit.
-;;;
-(defvar digit-bases
-  (make-array char-code-limit :element-type '(mod 37) :initial-element 36))
-
-(dotimes (i 36)
-  (let ((char (digit-char i 36)))
-    (setf (aref digit-bases (char-code char)) i)))
-
-
-;;; SYMBOL-QUOTEP  --  Internal
-;;;
-;;;    A FSM-like thingie that determines whether a symbol is a potential
-;;; number or has evil characters in it.
-;;;
-(defun symbol-quotep (name)
-  (declare (simple-string name))
-  (macrolet ((advance (tag &optional (at-end t))
-	       `(progn
-		 (when (= index len)
-		   ,(if at-end '(go TEST-SIGN) '(return nil)))
-		 (setq current (schar name index)
-		       code (char-code current)
-		       bits (aref attributes code))
-		 (incf index)
-		 (go ,tag)))
-	     (test (&rest attributes)
-		`(not (zerop
-		       (the fixnum
-			    (logand
-			     (logior ,@(mapcar
-					#'(lambda (x)
-					    (or (cdr (assoc x attribute-names))
-						(error "Blast!")))
-					attributes))
-			     bits)))))
-	     (digitp ()
-	       `(< (the fixnum (aref bases code)) base)))
-
-    (prog ((len (length name))
-	   (attributes character-attributes)
-	   (bases digit-bases)
-	   (base *print-base*)
-	   (index 0)
-	   (bits 0)
-	   (code 0)
-	   current)
-      (declare (fixnum len base index bits code))
-      (advance START t)
-
-     TEST-SIGN ; At end, see if it is a sign...
-      (return (not (test sign)))
-
-     OTHER ; Not potential number, see if funny chars...
-      (return (not (null (%primitive find-character-with-attribute
-				     name (1- index) len
-				     attributes funny-attribute))))
-     START
-      (when (digitp)
-	(if (test letter)
-	    (advance LAST-DIGIT-ALPHA)
-	    (advance DIGIT)))
-      (when (test letter number other slash) (advance OTHER nil))
-      (when (char= current #\.) (advance DOT-FOUND))
-      (when (test sign extension) (advance START-STUFF nil))
-      (return t)
-		  
-     DOT-FOUND ; Leading dots...
-      (when (test letter) (advance START-DOT-MARKER nil))
-      (when (digitp) (advance DOT-DIGIT))
-      (when (test number other) (advance OTHER nil))
-      (when (test extension slash sign) (advance START-DOT-STUFF nil))
-      (when (char= current #\.) (advance DOT-FOUND))
-      (return t)
-
-     START-STUFF ; Leading stuff before any dot or digit.
-      (when (digitp)
-	(if (test letter)
-	    (advance LAST-DIGIT-ALPHA)
-	    (advance DIGIT)))
-      (when (test number other) (advance OTHER nil))
-      (when (test letter) (advance START-MARKER nil))
-      (when (char= current #\.) (advance START-DOT-STUFF nil))
-      (when (test sign extension slash) (advance START-STUFF nil))
-      (return t)
-
-     START-MARKER ; Number marker in leading stuff...
-      (when (test letter) (advance OTHER nil))
-      (go START-STUFF)
-
-     START-DOT-STUFF ; Leading stuff containing dot w/o digit...
-      (when (test letter) (advance START-DOT-STUFF nil))
-      (when (digitp) (advance DOT-DIGIT))
-      (when (test sign extension dot slash) (advance START-DOT-STUFF nil))
-      (when (test number other) (advance OTHER nil))
-      (return t)
-
-     START-DOT-MARKER ; Number marker in leading stuff w/ dot..
-      ;; Leading stuff containing dot w/o digit followed by letter...
-      (when (test letter) (advance OTHER nil))
-      (go START-DOT-STUFF)
-
-     DOT-DIGIT ; In a thing with dots...
-      (when (test letter) (advance DOT-MARKER))
-      (when (digitp) (advance DOT-DIGIT))
-      (when (test number other) (advance OTHER nil))
-      (when (test sign extension dot slash) (advance DOT-DIGIT))
-      (return t)
-
-     DOT-MARKER ; Number maker in number with dot...
-      (when (test letter) (advance OTHER nil))
-      (go DOT-DIGIT)
-
-     LAST-DIGIT-ALPHA ; Previous char is a letter digit...
-      (when (or (digitp) (test sign slash))
-	(advance ALPHA-DIGIT))
-      (when (test letter number other dot) (advance OTHER nil))
-      (return t)
-      
-     ALPHA-DIGIT ; Seen a digit which is a letter...
-      (when (or (digitp) (test sign slash))
-	(if (test letter)
-	    (advance LAST-DIGIT-ALPHA)
-	    (advance ALPHA-DIGIT)))
-      (when (test letter) (advance ALPHA-MARKER))
-      (when (test number other dot) (advance OTHER nil))
-      (return t)
-
-     ALPHA-MARKER ; Number marker in number with alpha digit...
-      (when (test letter) (advance OTHER nil))
-      (go ALPHA-DIGIT)
-
-     DIGIT ; Seen only real numeric digits...
-      (when (digitp)
-	(if (test letter)
-	    (advance ALPHA-DIGIT)
-	    (advance DIGIT)))
-      (when (test number other) (advance OTHER nil))
-      (when (test letter) (advance MARKER)) 
-      (when (test extension slash sign) (advance DIGIT))
-      (when (char= current #\.) (advance DOT-DIGIT))
-      (return t)
-
-     MARKER ; Number marker in a numeric number...
-      (when (test letter) (advance OTHER nil))
-      (go DIGIT))))
-
-;;;; Pathname hackery
-
-;;; This function takes the pname of a symbol and adds slashes and/or 
-;;; vertical bars to it to make it readable again.
-;;; Special quoting characters are currently vertical bar and slash who's 
-;;; role in life are to specially quote symbols.  Funny symbol characters
-;;; are those who need special slashification when they are to be printed
-;;; so they can be read in again.  These currently include such characters 
-;;; as hash signs, colons of various sorts, etc.
-;;; Now there are three different version: UPPERCASE, lowercase and Captialize.
-;;; Check out the manual under the entry for *print-case* for details.
-
-(eval-when (compile eval)
-(defmacro symbol-quote-char-p (char)
-  `(or (char= ,char #\\) (char= ,char #\|)))
-); eval-when (compile eval)
-
-(defun output-uppercase-symbol (pname stream)
-  (declare (simple-string pname))
-  (cond ((symbol-quotep pname)
-	 (write-char #\| stream)
-	 (dostring (char pname)
-	   ;;If it needs slashing, do it.
-	   (if (symbol-quote-char-p char)
-	       (write-char #\\ stream))
-	   (write-char char stream))
-	 (write-char #\| stream))
-	(t
-	 (write-string pname stream))))
-
-;;; See documentation for output-symbol-uppercase (above).
-;;;
-(defun output-lowercase-symbol (pname stream)
-  (declare (simple-string pname))
-  (cond ((symbol-quotep pname)
-	 (write-char #\| stream)
-	 (dostring (char pname)
-	   (if (symbol-quote-char-p char)
-	       (write-char #\\ stream))
-	   (write-char char stream))
-	 (write-char #\| stream))
-	(t
-	 (dostring (char pname)
-	   (write-char (char-downcase char) stream)))))
-
-
-(defun output-capitalize-symbol (pname stream)
-  (declare (simple-string pname))
-  (cond
-   ((symbol-quotep pname)
-    (write-char #\| stream)
-    (dostring (char pname)
-      (if (symbol-quote-char-p char)
-	  (write-char #\\ stream))
-      (write-char char stream))
-    (write-char #\| stream))
-   (t
-    (do ((index 0 (1+ index))
-	 (pname-length (length (the string pname)))
-	 (prev-not-alpha t))
-	((= index pname-length))
-      (declare (fixnum index pname-length))
-      (let ((char (char pname index)))
-	(write-char (if prev-not-alpha char (char-downcase char)) stream)
-	(setq prev-not-alpha (not (alpha-char-p char))))))))
-
-
-
-;;;; Recursive Datatype Printing Subfunctions
-
-(defun output-list (list stream &optional (currlevel 0))
-  (write-char #\( stream)
-  (do ((list list (cdr list))
-       (currlength 0 (1+ currlength)))
-      ((or (null list)
-	   (and (not (null *print-length*))
-		(>= currlength (the fixnum *print-length*))))
-       (if (not (null list)) (write-string " ..." stream))
-       (write-char #\) stream))
-    (declare (fixnum currlength))
-    ;;If we are not printing the first object, we should space first.
-    (if (> currlength 0) (write-char #\space stream))
-    ;;Print whatever the car of the list is, at this level.
-    (output-object (car list) stream currlevel)
-    (cond ((not (or (consp (cdr list))
-		    (null (cdr list))))
-	   (write-string " .  " stream)
-	   (output-object (cdr list) stream currlevel)
-	   (write-char #\) stream)
-	   (return ())))))
- 
-(defun output-vector (vector stream &optional (currlevel 0))
-  (declare (fixnum currlevel))
-  (cond ((not *print-array*)
-	 (output-terse-array vector stream currlevel))
-	(T
-	 (if (bit-vector-p vector)
-	     (write-string "#*" stream)
-	     (write-string "#(" stream))
-	 (do ((currlength 0 (1+ currlength))
-	      (vlength (length (the vector vector)))
-	      (not-bit-vector-p (not (bit-vector-p vector))))
-	     ((or (and (not (null *print-length*))
-		       (>= currlength (the fixnum *print-length*)))
-		  (= currlength vlength))
-	      (if (not (= currlength vlength)) (write-string " ..." stream))
-	      (if not-bit-vector-p
-		  (write-char #\) stream)))
-	   (declare (fixnum currlength vlength))
-	 ;;Put a space before every element except the first
-	 ;; and not in bit vectors.
-	 (if (and (> currlength 0) not-bit-vector-p)
-	     (write-char #\space stream))
-	 ;;Output an element of the vector
-	 (output-object (aref vector currlength) stream currlevel)))))
-
-(defun output-array (array stream &optional (currlevel 0))
-  "Outputs the printed representation of any array in either the #< or #A form."
-  (let ((rank (array-rank array)))
-    (cond ((not *print-array*)
-	   (output-terse-array array stream rank))
-	  (T
-	   (output-array-guts array rank stream currlevel)))))
-
-;;; Master function for outputing the #A form of an array
-;;;
-(defun output-array-guts (array rank stream currlevel)
-  (write-char #\# stream)
-  (let ((*print-base* 10))
-    (output-integer rank stream))
-  (write-char #\A stream)
-  (with-array-data ((data array) (start) (end))
-    (declare (ignore end))
-    (sub-output-array-guts data (array-dimensions array)
-			   stream currlevel start)))
-
-;;; Some Ideas stolen from Skef Wholey.
-;;; Helping function for above.
-(defun sub-output-array-guts (array dimensions stream currlevel index)
-  (declare (fixnum currlevel index))
-  (cond ((null dimensions)
-	 (output-object (aref array index) stream currlevel)
-	 (1+ index))
-	((and (not (null *print-level*))
-	      (>= currlevel (the fixnum *print-level*)))
-	 (write-char #\# stream)
-	 index)
-	(t
-	 (write-char #\( stream)
-	 (do ((index index)
-	      (times 0 (1+ times))
-	      (limit (pop dimensions)))
-	     ((or (= times limit)
-		  (and (not (null *print-length*))
-		       (= times *print-length*)))
-	      (if (not (= times limit))
-		  (write-string " ...)" stream)
-		  (write-char #\) stream))
-	      index)
-	   (declare (fixnum index times limit))
-	   (if (not (zerop times)) (write-char #\space stream))
-	   (setq index
-		 (sub-output-array-guts array dimensions
-					stream (1+ currlevel) index))))))
-
-;;; Used to output the #< form of any array.
-;;;
-(defun output-terse-array (array stream rank)
-  (write-string "#<" stream)
-  (cond ((vectorp array)
-	 (if (bit-vector-p array)
-	     (write-string "Bit-vector" stream)
-	     (write-string "Vector" stream)))
-	(T
-	 (write-string "Array, rank " stream)
-	 (output-integer rank stream)))
-  (finish-random array stream))
-
-
-;;; Structure Printing.  These days we can always pass the buck to the Defstruct
-;;; code.
-
-(defun output-structure (structure stream currlevel)
-  (funcall (or (info type printer (svref structure 0))
-	       #'c::default-structure-print)
-	   structure stream currlevel))
-
-
-;;;; Functions to help print strings.
-
-;;; QUOTE-STRING -- Internal.
-;;;
-;;; This function outputs a string quoting characters sufficiently, so someone
-;;; can read it in again.  Basically, put a slash in front of an character
-;;; satisfying FROB.
-;;;
-(defun quote-string (string stream)
-  (macrolet ((frob (char)
-	       ;; Probably should look at readtable, but just do this for now.
-	       `(or (char= ,char #\\)
-		    (char= ,char #\"))))
-    (write-char #\" stream)
-    (dostring (char string)
-      (when (frob char) (write-char #\\ stream))
-      (write-char char stream))
-    (write-char #\" stream)))
-
-
-(defun whitespace-char-p (char)
-  "Determines whether or not the character is considered whitespace."
-  (or (char= char #\space)
-      (char= char #\tab)
-      (char= char #\return)
-      (char= char #\linefeed)))
-
-;;;; Integer, ratio, complex printing.
-
-(defun output-integer (integer stream)
-  (cond ((not (and (fixnump *print-base*) (> (the fixnum *print-base*) 1)))
-	 (let ((obase *print-base*))
-	   (setq *print-base* 10.)
-	   (error "~A is not a reasonable value for *Print-Base*." obase)))
-	;; Otherwise print the base
-	(T (cond ((and (not (= *print-base* 10.))
-		       *print-radix*)
-		  ;; First print leading base information, if any.
-		  (write-char #\# stream)
-		  (write-char (case *print-base*
-				(2.  #\b)
-				(8.  #\o)
-				(16. #\x)
-				(T (let ((fixbase *print-base*)
-					 (*print-base* 10.)
-					 (*print-radix* ()))
-				     (sub-output-integer fixbase stream))
-				   #\r))
-			      stream)))
-	   ;; Then output a minus sign if the number is negative, then output
-	   ;; the absolute value of the number.
-	   (cond ((bignump integer) (print-bignum integer stream))
-		 ((< integer 0)
-		  (write-char #\- stream)
-		  (sub-output-integer (- integer) stream))
-		 (T (sub-output-integer integer stream)))
-	   ;; Print any trailing base information, if any.
-	   (if (and (= *print-base* 10.) *print-radix*)
-	       (write-char #\. stream)))))
-
-(defun sub-output-integer (integer stream)
-  (let ((quotient ())
-	(remainder ()))
-    ;; Recurse until you have all the digits pushed on the stack.
-    (if (not (zerop (multiple-value-setq (quotient remainder)
-		      (truncate integer *print-base*))))
-	(sub-output-integer quotient stream))
-    ;; Then as each recursive call unwinds, turn the digit (in remainder) 
-    ;; into a character and output the character.
-    (write-char (int-char (if (and (> remainder 9.)
-				   (> *print-base* 10.))
-			      (+ (char-int #\A) (- remainder 10.))
-			      (+ (char-int #\0) remainder)))
-		stream)))
-
-
-(defun output-ratio (ratio stream)
-  (when *print-radix*
-    (write-char #\# stream)
-    (case *print-base*
-      (2 (write-char #\b stream))
-      (8 (write-char #\o stream))
-      (16 (write-char #\x stream))
-      (t (write *print-base* :stream stream :radix nil :base 10)))
-    (write-char #\r stream))
-  (let ((*print-radix* nil))
-    (output-integer (numerator ratio) stream)
-    (write-char #\/ stream)
-    (output-integer (denominator ratio) stream)))
-
-(defun output-complex (complex stream)
-  (write-string "#C(" stream)
-  (output-object (realpart complex) stream)
-  (write-char #\space stream)
-  (output-object (imagpart complex) stream)
-  (write-char #\) stream))
-
-
-
-;;;; Bignum printing
-
-;;; Written by Steven Handerson
-;;;  (based on Skef's idea)
-
-;;; BIGNUM-FIXNUM-DIVIDE-INPLACE wants the divisor to be of integer-length 19
-;;; or less.  1- the ideal power of the base for a divisor.
-;;;
-(defparameter *fixnum-power--1*
-  '#(NIL NIL 17 10 8 7 6 5 5 4 4 4 4 4 3 3 3 3 3 3 3 3 3 3 3 3 3 2 2 2 2 2 2 2 2
-	 2))
-
-;;; The base raised to the ideal power.
-;;;
-(defparameter *base-power*
-  '#(NIL NIL 262144 177147 262144 390625 279936 117649 262144 59049 100000
-	 161051 248832 371293 38416 50625 65536 83521 104976 130321 160000
-	 194481 234256 279841 331776 390625 456976 19683 21952 24389 27000
-	 29791 32768 35937 39304 42875))
-
-(defun print-bignum (big stream)
-  (bignum-print-aux (cond ((minusp big)
-			   (write-char #\- stream)
-			   (- big))
-			  (t (copy-xnum big)))
-		    stream)
-  big)
-
-(defun bignum-print-aux (big stream)
-  (multiple-value-bind (newbig fix)
-		       (bignum-fixnum-divide-inplace
-			big (aref *base-power* *print-base*))
-    (if (fixnump newbig)
-	(sub-output-integer newbig stream)
-	(bignum-print-aux newbig stream))
-    (do ((zeros (aref *fixnum-power--1* *print-base*) (1- zeros))
-	 (base-power *print-base* (* base-power *print-base*)))
-	((> base-power fix)
-	 (dotimes (i zeros) (write-char #\0 stream))
-	 (sub-output-integer fix stream)))))
-
-
-
-;;;; Floating Point printing
-;;;
-;;;  Written by Bill Maddox
-;;;
-;;;
-;;;
-;;; FLONUM-TO-STRING (and its subsidiary function FLOAT-STRING) does most of 
-;;; the work for all printing of floating point numbers in the printer and in
-;;; FORMAT.  It converts a floating point number to a string in a free or 
-;;; fixed format with no exponent.  The interpretation of the arguments is as 
-;;; follows:
-;;;
-;;;     X        - The floating point number to convert, which must not be
-;;;                negative.
-;;;     WIDTH    - The preferred field width, used to determine the number
-;;;                of fraction digits to produce if the FDIGITS parameter
-;;;                is unspecified or NIL.  If the non-fraction digits and the
-;;;                decimal point alone exceed this width, no fraction digits
-;;;                will be produced unless a non-NIL value of FDIGITS has been
-;;;                specified.  Field overflow is not considerd an error at this
-;;;                level.
-;;;     FDIGITS  - The number of fractional digits to produce. Insignificant
-;;;                trailing zeroes may be introduced as needed.  May be
-;;;                unspecified or NIL, in which case as many digits as possible
-;;;                are generated, subject to the constraint that there are no
-;;;                trailing zeroes.
-;;;     SCALE    - If this parameter is specified or non-NIL, then the number
-;;;                printed is (* x (expt 10 scale)).  This scaling is exact,
-;;;                and cannot lose precision.
-;;;     FMIN     - This parameter, if specified or non-NIL, is the minimum
-;;;                number of fraction digits which will be produced, regardless
-;;;                of the value of WIDTH or FDIGITS.  This feature is used by
-;;;                the ~E format directive to prevent complete loss of
-;;;                significance in the printed value due to a bogus choice of
-;;;                scale factor.
-;;;
-;;; Most of the optional arguments are for the benefit for FORMAT and are not
-;;; used by the printer.
-;;;
-;;; Returns:
-;;; (VALUES DIGIT-STRING DIGIT-LENGTH LEADING-POINT TRAILING-POINT DECPNT)
-;;; where the results have the following interpretation:
-;;;
-;;;     DIGIT-STRING    - The decimal representation of X, with decimal point.
-;;;     DIGIT-LENGTH    - The length of the string DIGIT-STRING.
-;;;     LEADING-POINT   - True if the first character of DIGIT-STRING is the
-;;;                       decimal point.
-;;;     TRAILING-POINT  - True if the last character of DIGIT-STRING is the
-;;;                       decimal point.
-;;;     POINT-POS       - The position of the digit preceding the decimal
-;;;                       point.  Zero indicates point before first digit.
-;;;
-;;; WARNING: For efficiency, there is a single string object *digit-string*
-;;; which is modified destructively and returned as the value of
-;;; FLONUM-TO-STRING.  Thus the returned value is not valid across multiple 
-;;; calls.
-;;;
-;;; NOTE:  FLONUM-TO-STRING goes to a lot of trouble to guarantee accuracy.
-;;; Specifically, the decimal number printed is the closest possible 
-;;; approximation to the true value of the binary number to be printed from 
-;;; among all decimal representations  with the same number of digits.  In
-;;; free-format output, i.e. with the number of digits unconstrained, it is 
-;;; guaranteed that all the information is preserved, so that a properly-
-;;; rounding reader can reconstruct the original binary number, bit-for-bit, 
-;;; from its printed decimal representation. Furthermore, only as many digits
-;;; as necessary to satisfy this condition will be printed.
-;;;
-;;;
-;;; FLOAT-STRING actually generates the digits for positive numbers.  The
-;;; algorithm is essentially that of algorithm Dragon4 in "How to Print 
-;;; Floating-Point Numbers Accurately" by Steele and White.  The current 
-;;; (draft) version of this paper may be found in [CMUC]<steele>tradix.press.
-;;; DO NOT EVEN THINK OF ATTEMPTING TO UNDERSTAND THIS CODE WITHOUT READING 
-;;; THE PAPER!
-
-(defvar *digits* "0123456789")
-
-(defvar *digit-string*
-  (make-array 50 :element-type 'string-char :fill-pointer 0 :adjustable t))
-
-(defun flonum-to-string (x &optional width fdigits scale fmin)
-  (cond ((zerop x)
-	 ;;zero is a special case which float-string cannot handle
-	 (if fdigits
-	     (let ((s (make-string (1+ fdigits) :initial-element #\0)))
-	       (setf (schar s 0) #\.)
-	       (values s (length s) t (zerop fdigits) 0))
-	     (values "." 1 t t 0)))
-	(t
-	  (setf (fill-pointer *digit-string*) 0)
-	  (multiple-value-bind (sig exp)
-			       (integer-decode-float x)
-	    (if (typep x 'short-float)
-		;;20 and 53 are the number of bits of information in the
-		;;significand, less sign, of a short float and a long float
-		;;respectively.
-		(float-string sig exp 20 width fdigits scale fmin)
-		(float-string sig exp 53 width fdigits scale fmin))))))
-
-(defun float-string (fraction exponent precision width fdigits scale fmin)
-  (let ((r fraction) (s 1) (m- 1) (m+ 1) (k 0)
-	(digits 0) (decpnt 0) (cutoff nil) (roundup nil) u low high)
-    ;;Represent fraction as r/s, error bounds as m+/s and m-/s.
-    ;;Rational arithmetic avoids loss of precision in subsequent calculations.
-    (cond ((> exponent 0)
-	   (setq r (ash fraction exponent))
-	   (setq m- (ash 1 exponent))	   
-	   (setq m+ m-))                   
-	  ((< exponent 0)
-	   (setq s (ash 1 (- exponent)))))
-    ;;adjust the error bounds m+ and m- for unequal gaps
-    (when (= fraction (ash 1 precision))
-      (setq m+ (ash m+ 1))
-      (setq r (ash r 1))
-      (setq s (ash s 1)))
-    ;;scale value by requested amount, and update error bounds
-    (when scale
-      (if (minusp scale)
-	  (let ((scale-factor (expt 10 (- scale))))
-	    (setq s (* s scale-factor)))
-	  (let ((scale-factor (expt 10 scale)))
-	    (setq r (* r scale-factor))
-	    (setq m+ (* m+ scale-factor))
-	    (setq m- (* m- scale-factor)))))
-    ;;scale r and s and compute initial k, the base 10 logarithm of r
-    (do ()
-        ((>= r (ceiling s 10)))
-      (decf k)
-      (setq r (* r 10))
-      (setq m- (* m- 10))
-      (setq m+ (* m+ 10)))
-    (do ()(nil)
-      (do ()
-	  ((< (+ (ash r 1) m+) (ash s 1)))
-	(setq s (* s 10))
-	(incf k))
-      ;;determine number of fraction digits to generate
-      (cond (fdigits
-	     ;;use specified number of fraction digits
-	     (setq cutoff (- fdigits))
-	     ;;don't allow less than fmin fraction digits
-	     (if (and fmin (> cutoff (- fmin))) (setq cutoff (- fmin))))
-	    (width
-	     ;;use as many fraction digits as width will permit
-             ;;but force at least fmin digits even if width will be exceeded
-	     (if (< k 0)
-		 (setq cutoff (- 1 width))
-		 (setq cutoff (1+ (- k width))))
-	     (if (and fmin (> cutoff (- fmin))) (setq cutoff (- fmin)))))
-      ;;If we decided to cut off digit generation before precision has
-      ;;been exhausted, rounding the last digit may cause a carry propagation.
-      ;;We can prevent this, preserving left-to-right digit generation, with
-      ;;a few magical adjustments to m- and m+.  Of course, correct rounding
-      ;;is also preserved.
-      (when (or fdigits width)
-	(let ((a (- cutoff k))
-	      (y s))
-	  (if (>= a 0)
-	      (dotimes (i a) (setq y (* y 10)))
-	      (dotimes (i (- a)) (setq y (ceiling y 10))))
-	  (setq m- (max y m-))
-	  (setq m+ (max y m+))
-	  (when (= m+ y) (setq roundup t))))
-      (when (< (+ (ash r 1) m+) (ash s 1)) (return)))
-    ;;zero-fill before fraction if no integer part
-    (when (< k 0)
-      (setq decpnt digits)
-      (vector-push-extend #\. *digit-string*)
-      (dotimes (i (- k))
-	(incf digits) (vector-push-extend #\0 *digit-string*)))
-    ;;generate the significant digits
-    (do ()(nil)
-      (decf k)
-      (when (= k -1)
-	(vector-push-extend #\. *digit-string*)
-	(setq decpnt digits))
-      (multiple-value-setq (u r) (truncate (* r 10) s))
-      (setq m- (* m- 10))
-      (setq m+ (* m+ 10))
-      (setq low (< (ash r 1) m-))
-      (if roundup
-	  (setq high (>= (ash r 1) (- (ash s 1) m+)))
-	  (setq high (> (ash r 1) (- (ash s 1) m+))))
-      ;;stop when either precision is exhausted or we have printed as many
-      ;;fraction digits as permitted
-      (when (or low high (and cutoff (<= k cutoff))) (return))
-      (vector-push-extend (char *digits* u) *digit-string*)
-      (incf digits))
-    ;;if cutoff occured before first digit, then no digits generated at all
-    (when (or (not cutoff) (>= k cutoff))
-      ;;last digit may need rounding
-      (vector-push-extend (char *digits*
-				(cond ((and low (not high)) u)
-				      ((and high (not low)) (1+ u))
-				      (t (if (<= (ash r 1) s) u (1+ u)))))
-			  *digit-string*)
-      (incf digits))
-    ;;zero-fill after integer part if no fraction
-    (when (>= k 0)
-      (dotimes (i k) (incf digits) (vector-push-extend #\0 *digit-string*))
-      (vector-push-extend #\. *digit-string*)
-      (setq decpnt digits))
-    ;;add trailing zeroes to pad fraction if fdigits specified
-    (when fdigits
-      (dotimes (i (- fdigits (- digits decpnt)))
-	(incf digits)
-	(vector-push-extend #\0 *digit-string*)))
-    ;;all done
-    (values *digit-string* (1+ digits) (= decpnt 0) (= decpnt digits) decpnt)))
-
-
-(defconstant short-log10-of-2 0.30103s0)
-
-;;; Given a non-negative floating point number, SCALE-EXPONENT returns a
-;;; new floating point number Z in the range (0.1, 1.0] and and exponent
-;;; E such that Z * 10^E is (approximately) equal to the original number.
-;;; There may be some loss of precision due the floating point representation.
-
-
-;;;
-(defun scale-exponent (x)
-  (if (typep x 'short-float)
-      (scale-expt-aux x 0.0s0 1.0s0 1.0s1 1.0s-1 short-log10-of-2)
-      (scale-expt-aux x 0.0l0 1.0l0 %long-float-ten
-		      %long-float-one-tenth long-log10-of-2)))
-
-
-(defun scale-expt-aux (x zero one ten one-tenth log10-of-2)
-  (multiple-value-bind (sig exponent)
-		       (decode-float x)
-    (declare (ignore sig))
-    (if (= x zero)
-	(values zero 1)
-	(let* ((ex (round (* exponent log10-of-2)))
-	       (x (if (minusp ex)		;For the end ranges.
-		      (* x ten (expt ten (- -1 ex)))
-		      (/ x ten (expt ten (1- ex))))))
-	  (do ((d ten (* d ten))
-	       (y x (/ x d))
-	       (ex ex (1+ ex)))
-	      ((< y one)
-	       (do ((m ten (* m ten))
-		    (z y (* z m))
-		    (ex ex (1- ex)))
-		   ((>= z one-tenth) (values z ex)))))))))
-
-
-;;;; Entry point for the float printer.
-
-;;; Entry point for the float printer as called by PRINT, PRIN1, PRINC,
-;;; etc.  The argument is printed free-format, in either exponential or 
-;;; non-exponential notation, depending on its magnitude.
-;;;
-;;; NOTE:  When a number is to be printed in exponential format, it is scaled
-;;; in floating point.  Since precision may be lost in this process, the
-;;; guaranteed accuracy properties of FLONUM-TO-STRING are lost.  The
-;;; difficulty is that FLONUM-TO-STRING performs extensive computations with
-;;; integers of similar magnitude to that of the number being printed.  For
-;;; large exponents, the bignums really get out of hand.  When we switch to
-;;; IEEE format for long floats, this will significantly restrict the magnitude
-;;; of the largest allowable float.  This combined with microcoded bignum
-;;; arithmetic might make it attractive to handle exponential notation with
-;;; the same accuracy as non-exponential notation, using the method described
-;;; in the Steele and White paper.
-
-(defun output-float (x stream)
-  (if (typep x 'short-float)
-      (output-float-aux x stream 1.0s-3 1.0s7)
-      (output-float-aux x stream %long-float1l-3 %long-float1l7)))
-
-
-(defun output-float-aux (x stream e-min e-max)
-  (cond ((zerop x)
-	 (write-string "0.0" stream)
-	 (if (and (not (typep x *read-default-float-format*))
-		  (not (and (eq *read-default-float-format* 'single-float)
-			    (typep x 'short-float))))
-	     (write-string (if (typep x 'short-float) "s0" "L0") stream)))
-	(t (when (minusp x) 
-	     (write-char #\- stream)
-	     (setq x (- x)))
-	   (if (and (>= x e-min) (< x e-max))
-	       ;;free format
-	       (multiple-value-bind (str len lpoint tpoint)
-				    (flonum-to-string x)
-		 (declare (ignore len))
-		 (when lpoint (write-char #\0 stream))
-		 (write-string str stream)
-		 (when tpoint (write-char #\0 stream))
-		 (if (and (not (typep x *read-default-float-format*))
-			  (not (and (eq *read-default-float-format*
-					'single-float)
-				    (typep x 'short-float))))
-		     (write-string (if (typep x 'short-float) "s0" "L0")
-				   stream)))
-	       ;;exponential format 
-	       (multiple-value-bind (f ex)
-				    (scale-exponent x)
-		 (multiple-value-bind (str len lpoint tpoint)
-				      (flonum-to-string f nil nil 1)
-		   (declare (ignore len))
-		   (when lpoint (write-char #\0 stream))
-		   (write-string str stream)
-		   (when tpoint (write-char #\0 stream))
-		   (write-char (if (typep x *read-default-float-format*)
-				   #\E
-				   (if (typep x 'short-float) #\S #\L))
-			       stream)
-		   ;;must subtract 1 from exponent here, due to
-		   ;;the scale factor of 1 in call to FLONUM-TO-STRING
-		   (unless (minusp (1- ex)) (write-char #\+ stream))
-		   (output-integer (1- ex) stream)))))))
-
-
-;;;; Output Character
-
-;;; FUNNY-CHARACTER-CHAR-P returns a predicate which determines whether a
-;;; character must be slashified when being output.
-;;;
-(defmacro funny-character-char-p (char)
-  `(and (not (zerop (char-bits ,char)))
-	(not (zerop (logand (aref character-attributes (char-code ,char))
-			    funny-attribute)))))
-
-;;; OUTPUT-CHARACTER  --  Internal
-;;;
-;;;    If *print-escape* is false, just do a WRITE-CHAR, otherwise output
-;;; any bits and then the character or name, escaping if necessary.  In
-;;; either case, we blast the bits or font before writing the character
-;;; itself to the stream.
-;;;
-(defun output-character (char stream)
-  (let ((base (make-char char)))
-    (if *print-escape*
-	(let ((name (char-name base)))
-	  (write-string "#\\" stream)
-	  (macrolet ((frob (key string)
-		       `(when (char-bit char ,key)
-			  (write-string ,string stream))))
-	    (frob :control "CONTROL-")
-	    (frob :meta "META-")
-	    (frob :super "SUPER-")
-	    (frob :hyper "HYPER-"))
-	  (cond (name (write-string name stream))
-		(t 
-		 (when (funny-character-char-p char)
-		   (write-char #\\ stream))
-		 (write-char base stream))))
-	(write-char base stream))))
-
-
-
-;;;; Random and Miscellaneous Print Subfunctions
-
-
-;;; OUTPUT-FUNCTION-OBJECT outputs the main part of the printed 
-;;; representation of function objects.  It is called from OUTPUT-RANDOM
-;;; below.
-
-(defun output-function-object (subr stream)
-  (let ((name (%primitive header-ref subr %function-name-slot)))
-    (case (%primitive get-vector-subtype subr)
-      (#.%function-entry-subtype
-       (if (stringp name)
-	   (format stream "Internal Function ~S" name)
-	   (format stream "Function ~S" name)))
-      (#.%function-closure-subtype
-       (if (eval:interpreted-function-p subr)
-	   (multiple-value-bind
-	       (def ignore name)
-	       (eval:interpreted-function-lambda-expression subr)
-	     (declare (ignore ignore))
-	     (let ((*print-level* 3))
-	       (format stream "Interpreted Function ~S" (or name def))))
-	   (format stream "Closure ~S"
-		   (%primitive header-ref name %function-name-slot))))
-      (#.%function-closure-entry-subtype
-       (format stream "Closure Entry ~S" name))
-      (#.%function-constants-subtype
-       (format stream "Function Constants ~S" name))
-      (#.%function-value-cell-subtype
-       (assert (= %function-value-cell-value-slot %function-name-slot))
-       (format stream "Indirect Value Cell ~S" name))
-      #|
-      (#.%function-funcallable-instance-subtype
-       (format stream "Funcallable Instance ~S" name))
-      |#
-      (t (error "Unknown function subtype.")))))
-
-
-;;; FINISH-RANDOM is a helping function for OUTPUT-RANDOM below.  
-;;; It outputs the numerical value of the low 28 bits of 
-;;; RANDOM-OBJECT, enclosed in braces, followed by the closing
-;;; angle-bracket (">") random objects have at the end.  This
-;;; is used to distringuish random objects of the same type.
-
-(defun finish-random (random-object stream)
-  (write-string " {" stream)
-  (let ((*print-base* 16))
-    (output-integer (%primitive make-fixnum random-object)) stream)
-  (write-string "}>" stream))
-
-;;; Functions Objects and other implmentation specific objects 
-;;; are output here. 
-
-(defun output-random (object stream)
-  (write-string "#<" stream)
-  (if (compiled-function-p object)
-      (output-function-object object stream)
-      (let ((type (%primitive get-type object)))
-	(write-string "Pointer into Hell, level ")
-	(sub-output-integer type stream)))
-  (finish-random object stream))
diff --git a/code/purify.lisp b/code/purify.lisp
deleted file mode 100644
index aa33b30938220f19f8d44611f799b5cccb6e83b7..0000000000000000000000000000000000000000
--- a/code/purify.lisp
+++ /dev/null
@@ -1,535 +0,0 @@
-;;; -*- Log: code.log; Package: Lisp -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; Storage purifier for Spice Lisp.
-;;; Written by Rob MacLachlan and Skef Wholey.
-;;;
-;;;    The function Purify, defined herein, puts as much of the Lisp system as
-;;; possible into Read-Only and Static spaces so that subsequent garbage
-;;; collections are quicker.  This is done by frobbing the free-pointers for
-;;; spaces so that new objects are put in static or read-only space as
-;;; appropiate, then doing a GC.
-;;;
-;;;    We also transport all of the dynamic symbols in Lisp code so we
-;;; can do clever things that improve locality in the resulting Lisp. 
-;;; Some constant conses and g-vectors are also transported in macrocode
-;;; so that we can put them in read-only space.
-;;;
-(in-package 'lisp)
-
-(defun purify (&key root-structures)
-  (declare (special lisp-environment-list))
-  (setq lisp-environment-list NIL)
-  (write-string "[Doing purification: ")
-  (force-output)
-  (setq *already-maybe-gcing* t)
-  ;;
-  ;; Find GC stack fixups before we go around trashing vector headers.
-  (let ((fixups (gc-grovel-stack)))
-    ;;
-    ;; Move symbols to static space, constants to read-only space.
-    (localify root-structures)
-    ;;
-    ;; Move everything else to either static or read-only space, depending
-    ;; on type.
-    (%primitive clear-registers)
-    (%primitive purify)
-    (gc-fixup-stack fixups))
-
-  (setq *already-maybe-gcing* nil)
-  (setq *need-to-collect-garbage* nil)
-  (write-line "done]")
-  nil)
-
-;;;; Localify
-
-(eval-when (compile eval)
-;;; Peek, Poke  --  Internal
-;;;
-;;;    Read or write the cell at a location without doing any type-checking or
-;;; anything silly like that.
-;;; 
-(defmacro peek (x)
-  `(%primitive read-control-stack ,x))
-(defmacro poke (x val)
-  `(%primitive write-control-stack ,x ,val))
-
-;;; Symbol-Bits  --  Internal
-;;;
-;;;    There is a whole 32 bits at the end of every symbol, which until
-;;; now, was unused.  We will use the low 16 to annotate some stuff about
-;;; how symbols are referenced.
-;;;
-(defmacro symbol-bits (sym)
-  `(get ,sym 'purify-symbol-bits 0))
-
-(defsetf symbol-bits (sym) (val)
-  `(let ((space (%primitive get-allocation-space)))
-     (%primitive set-allocation-space %dynamic-space)
-     (prog1 (setf (get ,sym 'purify-symbol-bits) ,val)
-	    (%primitive set-allocation-space space))))
-
-(defconstant marked-bit		#b001)
-(defconstant worthwhile-bit	#b010)
-(defconstant referenced-bit	#b100)
-
-;;; Do-Allocated-Symbols  --  Internal
-;;;
-;;;    Iterate over all the symbols allocated in some space.
-;;;
-(defmacro do-allocated-symbols ((symbol space) &body forms)
-  `(let* ((old-alloc-space (%primitive get-allocation-space)))
-     (%primitive set-allocation-space %dynamic-space)
-     (let* ((index (+ (ash %symbol-type %alloc-ref-type-shift)
-		      (ash ,space %alloc-ref-space-shift)))
-	    (alloc-table (int-sap %fixnum-alloctable-address))
-	    (end (+ (logior (%primitive 16bit-system-ref alloc-table (1+ index))
-			    (ash (logand %type-space-mask
-					 (%primitive 16bit-system-ref alloc-table index))
-				 16))
-		    (ash ,space %space-shift))))
-       (declare (fixnum end))
-       (do ((base (ash ,space %space-shift) (+ base %symbol-length)))
-	   ((= base end))
-	 (declare (fixnum base))
-	 (let ((,symbol (%primitive make-immediate-type base %symbol-type)))
-	   (%primitive set-allocation-space old-alloc-space)
-	   ,@forms
-	   (%primitive set-allocation-space %dynamic-space))))
-     (%primitive set-allocation-space old-alloc-space)))
-
-;;; Inlinep  --  Internal
-;;;
-;;;    Return true if symbol appears to be the name of a function likely
-;;; to be coded inline.
-;;;
-(defmacro inlinep (sym)
-  #|Accesses global vars, so can't work....
-  `(or (info function source-transform ,sym)
-       (let ((info (info function info ,sym)))
-	 (and info
-	      (or (c::function-info-templates info)
-		  (c::function-info-ir2-convert info)))))
-  |#
-  nil)
-
-
-;;; Next-Symbol, Next-Cons  --  Internal
-;;;
-;;;    Return the object allocated after the supplied one.
-;;;
-(defmacro next-symbol (sym)
-  `(%primitive make-immediate-type (+ (%primitive make-fixnum ,sym) %symbol-length)
-	       %symbol-type))
-(defmacro next-cons (cons)
-  `(%primitive make-immediate-type (+ (%primitive make-fixnum ,cons) %cons-length)
-	       %list-type))
-
-;;; Purep  --  Internal
-;;;
-;;;    True if Obj is either not dynamic or has already been transported.
-;;;
-(defmacro purep (obj)
-  `(or (>= (%primitive get-space ,obj) %static-space)
-       (let ((type (%primitive get-type ,obj)))
-	 (declare (fixnum type))
-	 (or (< type %first-pointer-type)
-	     (> type %last-pointer-type)
-	     (= (%primitive get-type (peek ,obj)) %gc-forward-type)))))
-
-;;; Free-Pointer-Location  --  Internal
-;;;
-;;;    Return the SAP which points to the location of the free-pointer
-;;; for the specifed type and space in the alloc table.
-;;;
-(defmacro free-pointer-location (type space)
-  `(+ %fixnum-alloctable-address
-      (%primitive lsh ,type (1+ %alloc-ref-type-shift))
-      (%primitive lsh ,space (1+ %alloc-ref-space-shift))))
-
-;;; Transport-Symbol  --  Internal
-;;;
-;;;    If Sym is impure, copy it into static space and put a GC forward in the
-;;; old symbol.  Return True only if we actually did something.
-;;; 
-(defmacro transport-symbol (sym)
-  `(unless (purep ,sym)
-     (let ((new-sym (%primitive alloc-symbol (symbol-name ,sym))))
-       (when (boundp ,sym)
-	 (setf (symbol-value new-sym) (symbol-value ,sym)))
-       (when (fboundp ,sym)
-	 (setf (symbol-function new-sym) (symbol-function ,sym)))
-       (setf (symbol-plist new-sym) (symbol-plist ,sym))
-       (%primitive set-package new-sym (symbol-package ,sym))
-       (poke ,sym (%primitive make-immediate-type new-sym %gc-forward-type))
-       t)))
-
-;;; Copy-G-Vector  --  Internal
-;;;
-;;;    Copy a G-Vector into the current allocation space, and forward
-;;; the old object.  Return the new object.  If an EQ hashtable,
-;;; change the subtype, otherwise preserve it.
-;;;
-(defmacro copy-g-vector (object)
-  `(let* ((len (length ,object))
-	  (new (%primitive alloc-g-vector len nil))
-	  (st (%primitive get-vector-subtype ,object)))
-     (dotimes (i len)
-       (setf (svref new i) (svref ,object i)))
-     (%primitive set-vector-subtype new
-		 (case st
-		   ((2 3) 4)
-		   (t st)))
-     (poke ,object (%primitive make-immediate-type new %gc-forward-type))
-     new))
-
-
-;;; Scavenge-Symbols  --  Internal
-;;;
-;;;    Scan through static symbol space doing a Transport-Function on
-;;; the definition of every Fbound symbol between the free pointer
-;;; and our clean pointer.  The free pointer can move during the process
-;;; due to symbols being transported.
-;;;
-(defmacro scavenge-symbols ()
-  `(do ((free-ptr (peek free-ptr-loc) (peek free-ptr-loc)))
-       ((eq clean-ptr free-ptr))
-     (when (fboundp clean-ptr)
-       (transport-function (symbol-function clean-ptr)))
-     (setq clean-ptr (next-symbol clean-ptr))))
-); eval-when (compile eval)
-
-;;; Mark-Function  --  Internal
-;;;
-;;;    Set the referenced bit in any symbol constants, and call
-;;; Mark-If-Worthwhile on any which are not marked.
-;;;
-(defun mark-function (fun)
-  (let ((len (%primitive header-length fun)))
-    (do ((i %function-constants-constants-offset (1+ i)))
-	((= i len))
-      (let ((el (%primitive header-ref fun i)))
-	(when (symbolp el)
-	  (let ((bits (symbol-bits el)))
-	    (setf (symbol-bits el) (logior referenced-bit bits))
-	    (when (zerop (logand marked-bit bits))
-	      (mark-if-worthwhile el))))))))
-
-
-;;; Mark-If-Worthwhile  --  Internal
-;;;
-;;;    Mark the symbol if it is not already marked.  If it is appears to
-;;; be a symbol likely to be used at runtime, we set the worthwhile
-;;; bit as well.
-;;;
-(defun mark-if-worthwhile (sym)
-  (when (zerop (logand (symbol-bits sym) marked-bit))
-    ;;
-    ;; Mark it so we know we have been here...
-    (setf (symbol-bits sym) (logior marked-bit (symbol-bits sym)))
-    ;;
-    ;; If fbound and not an open-coded function, walk the function.
-    (when (and (fboundp sym) (not (inlinep sym)))
-      (setf (symbol-bits sym)
-	    (logior worthwhile-bit (symbol-bits sym)))
-      (mark-function (symbol-function sym)))
-    ;;
-    ;; If bound and not a inline constant, or neither bound nor fbound, 
-    ;; but has a plist, mark as worthwhile.
-    (when (if (boundp sym)
-	      (not (and (constantp sym)
-			(let ((val (symbol-value sym)))
-			  (or (characterp val) (numberp val) (eq sym val)))))
-	      (and (not (fboundp sym))
-		   (not (null (cddr (symbol-plist sym))))))
-      (setf (symbol-bits sym)
-	    (logior worthwhile-bit (symbol-bits sym))))))
-
-
-;;; Transport-And-Scavenge  --  Internal
-;;;
-;;;    Transport a symbol and then scavenge to completion.
-;;;
-(defun transport-and-scavenge (symbol)
-  (let* ((free-ptr-loc (free-pointer-location %symbol-type %static-space))
-	 (clean-ptr (peek free-ptr-loc)))
-    (transport-symbol symbol)
-    (scavenge-symbols)))
-
-
-;;; Transport-Function  --  Internal
-;;;
-;;;    Grovel the constants of a function object, transporting things
-;;; that look useful.  If a symbol has the worthwhile bit set, we move it.  We
-;;; transport conses and g-vectors here so that they can go into read-only
-;;; space.  If a constant is a compiled function, we recurse on it.
-;;;
-(defun transport-function (fun)
-  (unless (purep fun)
-    (let ((def (ecase (%primitive get-vector-subtype fun)
-		 ((#.%function-entry-subtype #.%function-closure-entry-subtype)
-		  (transport-function-object fun)
-		  (%primitive header-ref fun %function-entry-constants-slot))
-		 (#.%function-closure-subtype
-		  (let ((entry (%primitive header-ref fun
-					   %function-name-slot)))
-		    (unless (purep entry)
-		      (transport-function-object entry)
-		      (%primitive header-ref entry
-				  %function-entry-constants-slot))))
-		 (#.%function-funcallable-instance-subtype
-		  nil))))
-      (when (and def (not (purep def)))
-	(let ((length (%primitive header-length def)))
-	  (transport-function-object def)
-	  (do ((i %function-constants-constants-offset (1+ i)))
-	      ((= i length))
-	    (let ((const (%primitive header-ref def i)))
-	      (typecase const
-		(symbol
-		 (unless (zerop (logand worthwhile-bit (symbol-bits const)))
-		   (transport-symbol const)))
-		(cons
-		 (transport-cons const))
-		(compiled-function
-		 (transport-function const))
-		(simple-vector
-		 (transport-g-vector const))))))))))
-
-
-;;; TRANSPORT-FUNCTION-OBJECT  --  Internal
-;;;
-;;;    Copy a function object into read-only space.  This only moves the
-;;; function (entry or constants) object itself, and lets GC scavenge.
-;;;
-(defun transport-function-object (fun)
-  (%primitive set-allocation-space %read-only-space)
-  (let* ((len (%primitive header-length fun))
-	 (res (%primitive alloc-function len)))
-    (%primitive set-vector-subtype res (%primitive get-vector-subtype fun))
-    (dotimes (i len)
-      (%primitive header-set res i (%primitive header-ref fun i)))
-    (poke fun (%primitive make-immediate-type res %gc-forward-type)))
-  (%primitive set-allocation-space %static-space))
- 
-
-;;; Transport-Cons  --  Internal
-;;;
-;;;    Transport a cons and any list structure attached to it into read-only
-;;; space and scavenge to completion.
-;;;
-(defun transport-cons (cons)
-  (unless (purep cons)
-    (%primitive set-allocation-space %read-only-space)
-    (let* ((free-ptr-loc (free-pointer-location %list-type %read-only-space))
-	   (clean-ptr (peek free-ptr-loc)))
-      (loop
-	(loop
-	  (let ((new (cons (car cons) (cdr cons))))
-	    (poke cons (%primitive make-immediate-type new %gc-forward-type))
-	    (setq cons (cdr cons))
-	    (when (or (atom cons) (purep cons)) (return nil))))
-	(let ((free-ptr (peek free-ptr-loc)))
-	  (loop
-	    (when (eq clean-ptr free-ptr)
-	      (%primitive set-allocation-space %static-space)
-	      (return-from transport-cons nil))
-	    (setq cons (car clean-ptr))
-	    (setq clean-ptr (next-cons clean-ptr))
-	    (unless (or (atom cons) (purep cons)) (return nil))))))))
-
-;;; Transport-G-Vector  --  Internal
-;;;
-;;;    Transport a G-Vector into static space.  We only bother with
-;;; the top level, and leave the rest to GC.
-;;;
-(defun transport-g-vector (vec &optional read-only)
-  (unless (purep vec)
-    (when read-only
-      (%primitive set-allocation-space %read-only-space))
-    (copy-g-vector vec)
-    (when read-only
-      (%primitive set-allocation-space %static-space))))
-
-;;; Transport-Root  --  Internal
-;;;
-;;;    Descend into lists, simple-vectors and compiled functions, transporting 
-;;; any useful symbols we run into, and scavenging to completion after each.  We
-;;; transport simple-vectors now so that we don't lose on circular or highly
-;;; shared structures.
-;;;
-(defun transport-root (object)
-  (unless (purep object)
-    (typecase object
-      (symbol
-       (unless (zerop (logand worthwhile-bit (symbol-bits object)))
-	 (transport-and-scavenge object)))
-      (simple-vector
-       (let ((new (copy-g-vector object)))
-	 (dotimes (i (length new))
-	   (transport-root (svref new i)))))
-      (cons
-       (transport-root (car object))
-       (transport-root (cdr object)))
-      (compiled-function
-       (transport-function object)))))
-
-;;; Localify  --  Internal
-;;;
-;;;    This function goes GC-Like stuff at lisp level to try to increase 
-;;; the locality in a purified core image.  The basic idea is to do a
-;;; breadth-first walk of the function objects, moving interesting symbols
-;;; into static space.
-;;;
-(defun localify (root-structures)
-  (%primitive set-allocation-space %static-space)
-  ;;
-  ;; Mark interesting symbols, and those referenced by their definitions.
-  (do-allocated-symbols (sym %dynamic-space)
-    (setf (symbol-bits sym) 0))
-  (do-allocated-symbols (sym %dynamic-space)
-    (mark-if-worthwhile sym))
-  ;;
-  ;; Move interesting symbols referenced by the root structures.
-  (dolist (x root-structures)
-    (transport-root x))
-  ;;
-  ;; Treat interesting unreferenced symbols as roots...
-  (do-allocated-symbols (sym %dynamic-space)
-    (unless (purep sym)
-      (let ((bits (symbol-bits sym)))
-	(when (and (zerop (logand referenced-bit bits))
-		   (not (zerop (logand worthwhile-bit bits))))
-	  (transport-and-scavenge sym)))))
-  ;;
-  ;; Treat referenced symbols as roots...
-  (do-allocated-symbols (sym %dynamic-space)
-    (unless (or (purep sym)
-		(zerop (logand referenced-bit (symbol-bits sym))))
-      (transport-and-scavenge sym)))
-  ;;
-  ;; Do anything else that wants to be done...
-  (do-allocated-symbols (sym %dynamic-space)
-    ;;
-    ;; Move some types of variable value...
-    (when (boundp sym)
-      (let ((val (symbol-value sym)))
-	(cond ((purep val))
-	      #|Accesses global vars, so can't work...
-	      ((eq (info variable kind sym) :constant)
-	       (typecase val
-		 (cons (transport-cons val))
-		 (simple-vector (transport-g-vector val t))))
-	      |#
-	      )))
-    ;;
-    ;; Move any interned symbol that's left...
-    (unless (or (purep sym) (not (symbol-package sym)))
-      (transport-and-scavenge sym)))
-
-  ;;
-  ;; Reset the bits...
-  (remprop nil 'purify-symbol-bits)
-
-  (do-allocated-symbols (sym %static-space)
-    (remprop sym 'purify-symbol-bits))
-
-  (do-allocated-symbols (sym %dynamic-space)
-    (remprop sym 'purify-symbol-bits))
-
-  (%primitive set-allocation-space %dynamic-space))
-); Compiler-Let
-
-;;;; Save-Stand-Alone-Lisp
-;;;
-;;;    A stand-alone is a lisp that has had everything that doesn't pertain
-;;; to a particular application GC'ed away.  This can result in a drastic
-;;; size reduction, but tends make the Lisp unusable for anything else and
-;;; hard to debug in.  We do this by blowing away all symbols not directly
-;;; referenced and doing a GC.  We also blow away random debug info.
-
-
-;;; Save-Stand-Alone-Lisp  --  Public
-;;;
-(defun save-stand-alone-lisp (file root-function)
-  "Write into File a core file which contains only objects referenced
-  by Root-Function or needed for the basic system.  Root-Function
-  is called when the core file is resumed.  Root-Function should be
-  a symbol rather than an actual function object."
-  (let ((all-packages (list-all-packages)))
-    (fresh-line)
-    (write-string "[Nuking useless stuff")
-    (force-output)
-    ;;
-    ;; Mark all external symbols so that we can find them later...
-    (dolist (p all-packages)
-      (do-external-symbols (s p)
-	(setf (symbol-bits s) 1)))
-    ;;
-    ;; Nuke all hashtables in packages...
-    (dolist (p all-packages)
-      (make-package-hashtable 10 (package-internal-symbols p))
-      (make-package-hashtable 10 (package-external-symbols p)))
-    #|
-    ;;
-    ;; Nuke random garbage on all symbols...
-    (do-allocated-symbols (s %dynamic-space)
-      ;;
-      ;; Nuke arglists on functions...
-      (when (fboundp s)
-	(let ((fun (symbol-function s)))
-	  (cond ((compiled-function-p fun)
-		 (%primitive header-set fun %function-arg-names-slot ()))
-		((and (consp fun) (compiled-function-p (cdr fun)))
-		 (%primitive header-set (cdr fun) %function-arg-names-slot
-			     ()))))
-    
-      ;;
-      ;; Nuke unnecessary properties...
-      (when (symbol-plist s)
-	(dolist (p garbage-properties)
-	  (when (get s p)
-	    (remprop s p))))))
-    |#
-      
-    (write-string "]
-[GC'ing it away")
-    (force-output)
-    ;;
-    ;; GC it away....
-    (gc nil)
-    (write-string "]")
-    ;;
-    ;; Rebuild packages...
-    (write-string "]
-[Rebuilding packages")
-    (force-output)
-    (do-allocated-symbols (s %dynamic-space)
-      (let ((p (symbol-package s)))
-	(cond ((null p))
-	      ((zerop (symbol-bits s))
-	       (add-symbol (package-internal-symbols p) s))
-	      (t
-	       (add-symbol (package-external-symbols p) s)
-	       (setf (symbol-bits s) 0)))
-	(remprop s 'purify-symbol-bits)))
-    (do-allocated-symbols (s %static-space)
-      (let ((p (symbol-package s)))
-	(cond ((null p))
-	      ((zerop (symbol-bits s))
-	       (add-symbol (package-internal-symbols p) s))
-	      (t
-	       (add-symbol (package-external-symbols p) s)
-	       (setf (symbol-bits s) 0)))
-	(remprop s 'purify-symbol-bits)))
-    (write-line "]")
-    (purify :root-structures (list root-function))
-    (if (save file)
-	(quit)
-	(funcall root-function))))
diff --git a/code/query.lisp b/code/query.lisp
deleted file mode 100644
index c5ca1b451f28a507f55a0bd2662f3f1edfd10c29..0000000000000000000000000000000000000000
--- a/code/query.lisp
+++ /dev/null
@@ -1,79 +0,0 @@
-;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; Querying the user.
-;;; Written by Walter van Roggen, 27 December 1982.
-;;; Brought up to date and fixed somewhat by Rob MacLachlan.
-;;; Modified by Bill Chiles.
-;;;
-;;; These functions are part of the standard Spice Lisp environment.
-;;;
-;;; **********************************************************************
-;;;
-
-(in-package "LISP")
-
-(export '(y-or-n-p yes-or-no-p))
-
-(eval-when (compile)
-  (defmacro query-readline ()
-    `(string-trim " 	" (read-line *query-io*))))
-
-;;; Y-OR-N-P  --  Public.
-;;;
-;;; This prints the message, if any, and reads characters from *QUERY-IO* until
-;;; any of "y", "Y", or <newline> are seen as an affirmative, or either "n" or
-;;; "N" is seen as a negative answer.  It ignores preceding whitespace and asks
-;;; again if other characters are seen.
-;;;
-(defun y-or-n-p (&optional format-string &rest arguments)
-  "Y-OR-N-P prints the message, if any, and reads characters from
-   *QUERY-IO* until any of y, Y, or <newline> are seen as an 
-   affirmative, or either n or N is seen as a negative answer.
-   It ignores preceding whitespace and asks again if other characters
-   are seen."
-  (when format-string
-    (fresh-line *query-io*)
-    (apply #'format *query-io* format-string arguments)
-    (force-output *query-io*))
-  (loop
-    (let* ((line (query-readline))
-	   (ans (if (string= line "") :ignore-and-warn (schar line 0))))
-      (unless (whitespacep ans)
-	(case ans
-	  ((#\y #\Y) (return t))
-	  ((#\n #\N) (return nil))
-	  (t
-	   (write-line "Type \"y\" for yes or \"n\" for no. " *query-io*)
-	   (when format-string
-	     (apply #'format *query-io* format-string arguments))
-	   (force-output *query-io*)))))))
-
-;;; YES-OR-NO-P  --  Public.
-;;;
-;;; This is similar to Y-OR-N-P, but it clears the input buffer, beeps, and
-;;; uses READ-LINE to get "YES" or "NO".
-;;;
-(defun yes-or-no-p (&optional format-string &rest arguments)
-  "YES-OR-NO-P is similar to Y-OR-N-P, except that it clears the 
-   input buffer, beeps, and uses READ-LINE to get the strings 
-   YES or NO."
-  (clear-input *query-io*)
-  (beep)
-  (when format-string
-    (fresh-line *query-io*)
-    (apply #'format *query-io* format-string arguments))
-  (do ((ans (query-readline) (query-readline)))
-      (())
-    (cond ((string-equal ans "YES") (return t))
-	  ((string-equal ans "NO") (return nil))
-	  (t
-	   (write-line "Type \"yes\" for yes or \"no\" for no. " *query-io*)
-	   (when format-string
-	     (apply #'format *query-io* format-string arguments))))))
diff --git a/code/rand.lisp b/code/rand.lisp
deleted file mode 100644
index 9bfbe8841fa9d409e163e665c3ba1e62125bdc3a..0000000000000000000000000000000000000000
--- a/code/rand.lisp
+++ /dev/null
@@ -1,128 +0,0 @@
-;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; Functions to random number functions for Spice Lisp 
-;;; Written by David Adam.
-;;;
-;;; The random number functions are part of the standard Spicelisp environment.
-;;;
-;;; **********************************************************************
-;;;
-(in-package 'lisp)
-(export '(random-state random-state-p random *random-state*
-	  make-random-state))
-
-(defconstant random-const-a 8373)
-(defconstant random-const-c 101010101)
-(defconstant random-upper-bound 134217726)
-(defconstant random-max 54)
-(defvar rand-seed 0)
-(defvar *random-state*)
-
-(defstruct (random-state (:constructor make-random-object))
-  (j 24 :type integer)
-  (k 0 :type integer)
-  (seed (make-array (1+ random-max) :initial-contents
-		    (do ((list-rands () (cons (rand1) list-rands))
-			 (i 0 (1+ i)))
-			((> i random-max) list-rands)))
-	:type simple-vector))
-
-
-;;; Generates a random number from rand-seed.
-(defun rand1 ()
-   (setq rand-seed (mod (+ (* rand-seed random-const-a) random-const-c)
-			(1+ random-upper-bound))))
-
-;;; rand3  --  Internal
-;;;
-;;; This function generates fixnums between 0 and random-upper-bound, 
-;;; inclusive For the algorithm to work random-upper-bound must be an 
-;;; even positive fixnum.  State is the random state to use.
-;;;
-(defun rand3 (state)
-  (let ((seed (random-state-seed state))
-	(j (random-state-j state))
-	(k (random-state-k state)))
-    (declare (fixnum j k) (simple-vector seed))
-    (setf (svref seed k)
-	  (let ((a (- random-upper-bound
-		      (svref seed
-			      (setf (random-state-j state)
-				    (if (= j 0) random-max (1- j))))
-		      (svref seed
-			      (setf (random-state-k state)
-				    (if (= k 0) random-max (1- k)))))))
-	    (if (minusp a) (- a) (- random-upper-bound a))))))
-
-
-(defun random-init ()
-  (setq *random-state*
-	(make-random-object :seed
-	 (make-array (1+ random-max) :initial-contents
-		     '(45117816 133464727 86324180 99419799 68851957 87250180
-		      52971860 84081967 30854110 121122797 70449044 18801152
-		      45149898 15881380 27398356 117706009 49915564 80620628
-		      120974070 98193932 43883764 53717012 100954825 82579490
-		      17280729 118523949 42282975 127220348 6288263 56575578
-		      2474156 47934425 561006 21989698 74046730 105055318
-		      113363907 48749716 78183593 109613585 37323232 65101428
-		      46453209 76906562 5371267 86544820 33922642 60765033
-		      41889257 77176406 38775255 78514879 72553872 66916641
-		      100613180)))))
-
-(defun copy-state (cur-state)
-  (let ((state (make-random-object
-		:seed (make-array 55)
-		:j (random-state-j cur-state)
-		:k (random-state-k cur-state))))
-    (do ((i 0 (1+ i)))
-	((= i 55) state)
-      (declare (fixnum i))
-      (setf (aref (random-state-seed  state) i)
-	    (aref (random-state-seed cur-state) i)))))
-
-(defun make-random-state (&optional state)
-  "Make a random state object.  If State is not supplied, return a copy
-  of the default random state.  If State is a random state, then return a
-  copy of it.  If state is T then return a random state generated from
-  the universal time."
-  (cond ((not state) (copy-state *random-state*))
-	((random-state-p state) (copy-state state))
-	((eq state t) (setq rand-seed (get-universal-time))
-		      (make-random-object))
-	(t (error "Bad argument, ~A, for RANDOM-STATE." state))))
-
-(proclaim '(ftype (function (t) fixnum) rand3))
-(defun random (arg &optional (state *random-state*))
-  "Generate a uniformly distributed pseudo-random number between zero
-  and Arg.  State, if supplied, is the random state to use."
-  (typecase arg
-    (fixnum
-     (unless (plusp (the fixnum arg))
-       (error "Non-positive argument, ~A, to RANDOM." arg))     
-     (rem (the fixnum (rand3 state)) (the fixnum arg)))
-    (float
-     (unless (plusp arg)
-       (error "Non-positive argument, ~A, to RANDOM." arg))
-     (let ((arg-length (typecase arg
-			 (short-float %short-float-mantissa-length)
-			 (single-float %single-float-mantissa-length)
-			 (double-float %double-float-mantissa-length)
-			 (long-float %long-float-mantissa-length))))
-       (* arg (/ (float (random (ash 2 arg-length) state))
-		 (float (ash 2 arg-length))))))
-    (integer
-     (unless (plusp arg)
-       (error "Non-positive argument, ~A, to RANDOM." arg))
-     (do ((tot (rand3 state) (+ (ash tot %fixnum-length) (rand3 state)))
-	  (end (ash arg (- %fixnum-length))
-	       (ash end (- %fixnum-length))))
-	 ((zerop end) (mod tot arg))))
-    (t (error "Wrong type argument, ~A, to RANDOM." arg))))
diff --git a/code/reader.lisp b/code/reader.lisp
deleted file mode 100644
index 717b6c4f8ed637e42de5aa8318b1da342be0b6e7..0000000000000000000000000000000000000000
--- a/code/reader.lisp
+++ /dev/null
@@ -1,1304 +0,0 @@
-;;; -*- Log: code.log; Package: Lisp -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; Spice Lisp Reader 
-;;; Written by David Dill
-;;; Package system interface by Lee Schumacher.
-;;; Runs in the standard Spice Lisp environment.
-;;;
-(in-package 'lisp)
-(export '(readtable readtablep *read-base* *readtable* copy-readtable 
-	  set-syntax-from-char set-macro-character get-macro-character
-	  make-dispatch-macro-character set-dispatch-macro-character
-	  get-dispatch-macro-character
-	  read *read-default-float-format* read-preserving-whitespace
-	  read-delimited-list parse-integer read-from-string *read-suppress*))
-
-;;;Random global variables
-
-(defvar *read-default-float-format* 'single-float "Float format for 1.0E1")
-
-(defvar *readtable* () "Variable bound to current readtable.")
-
-
-
-;;;; Readtable implementation.
-
-;;; The readtable is a structure with three components: the
-;;; CHARACTER-ATTRIBUTE-TABLE is a vector of 128 integers for describing the
-;;; character type.  Conceptually, there are 4 distinct "primary" character
-;;; attributes (WHITESPACE, TERMINATING-MACRO, ESCAPE, and CONSTITUENT --
-;;; non-terminating macros have the attribute CONSTITUENT, and the symbol
-;;; reader is implemented as a non-terminating macro), and a number of
-;;; "secondary" attributes that are used by the function READ-QUALIFIED-TOKEN,
-;;; which apply only when the primary attribute is CONSTITUENT.  In order to
-;;; make the READ-QUALIFIED-TOKEN fast, all this information is stored in the
-;;; character attribute table by having different varieties of constituents.
-;;; In order to conform with the white pages, the primary attributes should be
-;;; moved by SET-SYNTAX-FROM-CHARACTER and SET-MACRO-CHARACTER, while the
-;;; secondary attributes are constant properties of the characters (as long as
-;;; they are constituents).
-
-
-;;; The CHARACTER-MACRO-TABLE is a vector of 128 functions.  One of these
-;;; functions called with appropriate arguments whenever any non-WHITESPACE
-;;; character is encountered inside READ-PRESERVING-WHITESPACE.  These
-;;; functions are used to implement user-defined read-macros, system
-;;; read-macros, and the number-symbol reader.  Finally, there is a
-;;; DISPATCH-TABLES entry, which is an alist from dispatch characters to
-;;; vectors of 128 functions, for use in defining dispatching macros (like
-;;; #-macro).
-
-(defvar std-lisp-readtable ()
-  "Standard lisp readtable. This is for recovery from broken
-   read-tables, and should not normally be user-visible.")
-
-(defstruct (readtable
-	    (:conc-name nil)
-	    (:predicate readtablep)
-	    (:copier nil))
-  "Readtable is a data structure that maps characters into syntax
-   types for the Common Lisp expression reader."
-  (character-attribute-table (make-character-attribute-table) :type simple-vector)
-  (character-macro-table (make-character-macro-table) :type simple-vector)
-  (dispatch-tables () :type list))
-
-
-
-;;;; Constants for character attributes.  These are all as in the manual.
-
-(eval-when (compile load eval)
-  (defconstant whitespace 0)
-  (defconstant terminating-macro 1)
-  (defconstant escape 2)
-  (defconstant constituent 3)
-  (defconstant constituent-dot 4)
-  (defconstant constituent-expt 5)
-  (defconstant constituent-slash 6)
-  (defconstant constituent-digit 7)
-  (defconstant constituent-sign 8)
-  (defconstant sharp-sign 9)
-  (defconstant multiple-escape 10)
-  (defconstant package-delimiter 11)
-  ;;fake attribute for use in read-unqualified-token
-  (defconstant delimiter 12))
-
-
-
-;;;; Package specials.
-
-(defvar *old-package* ()
-  "Value of *package* at the start of the last read or Nil.")
-
-;;; In case we get an error trying to parse a symbol, we want to rebind the
-;;; above stuff so it's cool.
-
-(proclaim '(special *package* *keyword-package* *read-base*))
-
-
-
-;;;; Macros and functions for character tables.
-
-(defmacro get-cat-entry (char rt)
-  ;;only give this side-effect-free args.
-  `(elt (the simple-vector (character-attribute-table ,rt))
-	(char-int ,char)))
-
-(defun set-cat-entry (char newvalue &optional (rt *readtable*))
-  (setf (elt (the simple-vector (character-attribute-table rt))
-	     (char-int char))
-	newvalue))
-
-(defmacro get-cmt-entry (char rt)
-  `(elt (the simple-vector (character-macro-table ,rt))
-	(char-int ,char)))
-
-(defun set-cmt-entry (char newvalue &optional (rt *readtable*))
-  (setf (elt (the simple-vector (character-macro-table rt))
-	     (char-int char))
-	newvalue))
-
-(defun make-character-attribute-table ()
-  (make-array 256 :element-type t :initial-element #.constituent))
-
-(defun make-character-macro-table ()
-  (make-array 256 :element-type t
-		      :initial-element #'undefined-macro-char))
-
-(defun undefined-macro-char (ignore char)
-  (declare (ignore ignore))
-  (error "Undefined read-macro character ~S" char))
-
-
-;;; The character attribute table is a 128-long vector of integers. 
-
-(defmacro test-attribute (char whichclass rt)
-  `(= (the fixnum (get-cat-entry ,char ,rt)) ,whichclass)))
-
-;;; Predicates for testing character attributes
-
-;;; Make this a function, since other people want to use it.
-;;;
-(proclaim '(inline whitespacep))
-(defun whitespacep (char &optional (rt *readtable*))
-  (test-attribute char whitespace rt))
-
-(defmacro constituentp (char &optional (rt '*readtable*))
-  `(>= (get-cat-entry ,char ,rt) #.constituent))
-
-(defmacro terminating-macrop (char &optional (rt '*readtable*))
-  `(test-attribute ,char #.terminating-macro ,rt))
-
-(defmacro escapep (char &optional (rt '*readtable*))
-  `(test-attribute ,char #.escape ,rt))
-
-(defmacro multiple-escape-p (char &optional (rt '*readtable*))
-  `(test-attribute ,char #.multiple-escape ,rt))
-
-(defmacro token-delimiterp (char &optional (rt '*readtable*))
-  ;;depends on actual attribute numbering above.
-  `(<= (get-cat-entry ,char ,rt) #.terminating-macro))
-
-
-
-;;;; Secondary attribute table.
-
-(defvar secondary-attribute-table ())
-
-(defun set-secondary-attribute (char attribute)
-  (setf (elt (the simple-vector secondary-attribute-table) (char-int char))
-	attribute))
-
-
-(defun init-secondary-attribute-table ()
-  (setq secondary-attribute-table
-	(make-array 128 :element-type t
-			    :initial-element #.constituent))
-  (set-secondary-attribute #\: #.package-delimiter)
-  (set-secondary-attribute #\| #.multiple-escape)	; |) [For EMACS]
-  (set-secondary-attribute #\. #.constituent-dot)
-  (set-secondary-attribute #\+ #.constituent-sign)
-  (set-secondary-attribute #\- #.constituent-sign)
-  (set-secondary-attribute #\/ #.constituent-slash)  
-  (do ((i (char-int #\0) (1+ i)))
-      ((> i (char-int #\9)))
-    (set-secondary-attribute (int-char i) #.constituent-digit))
-  (set-secondary-attribute #\E #.constituent-expt)
-  (set-secondary-attribute #\F #.constituent-expt)
-  (set-secondary-attribute #\D #.constituent-expt)
-  (set-secondary-attribute #\S #.constituent-expt)
-  (set-secondary-attribute #\L #.constituent-expt)
-  (set-secondary-attribute #\e #.constituent-expt)
-  (set-secondary-attribute #\f #.constituent-expt)
-  (set-secondary-attribute #\d #.constituent-expt)
-  (set-secondary-attribute #\s #.constituent-expt)
-  (set-secondary-attribute #\l #.constituent-expt))
-
-(defmacro get-secondary-attribute (char)
-  `(elt (the simple-vector secondary-attribute-table)
-	(char-int ,char)))
-
-
-
-;;;; Readtable operations.
-
-(defun copy-readtable (&optional (from-readtable *readtable*) to-readtable)
-  "A copy is made of from-readtable and place into to-readtable."
-  (if (null from-readtable) (setq from-readtable std-lisp-readtable))
-  (if (null to-readtable) (setq to-readtable (make-readtable)))
-  ;;physically clobber contents of internal tables.
-  (replace (character-attribute-table to-readtable)
-	   (character-attribute-table from-readtable))
-  (replace (character-macro-table to-readtable)
-	   (character-macro-table from-readtable))
-  (setf (dispatch-tables to-readtable)
-	(mapcar #'(lambda (pair) (cons (car pair)
-				       (copy-seq (cdr pair))))
-		(dispatch-tables from-readtable)))
-  to-readtable)
-
-(defun set-syntax-from-char (to-char from-char &optional
-				     (to-readtable *readtable*)
-				     (from-readtable ()))
-  "Causes the syntax of to-char to be the same as from-char in the 
-   optional readtable (defaults to the current readtable).  The
-   from-table defaults the standard lisp readtable by being nil."
-  (if (null from-readtable) (setq from-readtable std-lisp-readtable))
-  ;;copy from-char entries to to-char entries, but make sure that if
-  ;;from char is a constituent you don't copy non-movable secondary
-  ;;attributes (constituent types), and that said attributes magically
-  ;;appear if you transform a non-constituent to a constituent.
-  (let ((att (get-cat-entry from-char from-readtable)))
-    (if (constituentp from-char from-readtable)
-	(setq att (get-secondary-attribute to-char)))
-    (set-cat-entry to-char att to-readtable)
-    (set-cmt-entry to-char
-		   (get-cmt-entry from-char from-readtable)
-		   to-readtable)
-    NIL))
-
-(defun set-macro-character (char function &optional
-				 (non-terminatingp nil) (rt *readtable*))
-  "Causes char to be a macro character which invokes function when
-   seen by the reader.  The non-terminatingp flag can be used to
-   make the macro character non-terminating.  The optional readtable
-   argument defaults to the current readtable.  Set-macro-character
-   returns T."
-  (if non-terminatingp
-      (set-cat-entry char (get-secondary-attribute char) rt)
-      (set-cat-entry char #.terminating-macro rt))
-  (set-cmt-entry char function rt)
-  T)
-
-(defun get-macro-character (char &optional (rt *readtable*))
-  "Returns the function associated with the specified char
-   which is a macro character.  The optional readtable argument
-   defaults to the current readtable."
-  (when (null rt) (setf rt *readtable*))
-  ;;check macro syntax, return associated function if it's there.
-  ;;returns a value for all constituents.
-  (cond ((constituentp char)
-	 (values (get-cmt-entry char rt) t))
-	((terminating-macrop char)
-	 (values (get-cmt-entry char rt) nil))
-	(t nil)))
-
-
-
-;;;; These definitions support internal programming conventions.
-
-(defconstant eof-object '(*eof*))
-
-(defmacro eofp (char) `(eq ,char eof-object))
-
-(defun flush-whitespace (stream)
-  ;;This flushes whitespace chars, returning the last char it read (a non-white
-  ;;one).  It always gets an error on end-of-file.
-  (prepare-for-fast-read-char stream
-    (do ((attribute-table (character-attribute-table *readtable*))
-	 (char (fast-read-char t) (fast-read-char t)))
-      ((/= (the fixnum (svref attribute-table (char-int char))) #.whitespace)
-       (done-with-fast-read-char)
-       char))))
-
-
-
-;;;; Temporary initialization hack.
-
-(defun init-std-lisp-readtable ()
-  (setq std-lisp-readtable (make-readtable))
-  ;;all characters default to "constituent" in make-readtable
-  ;;*** un-constituent-ize some of these ***
-  (let ((*readtable* std-lisp-readtable))
-    (set-cat-entry #\tab #.whitespace)
-    (set-cat-entry #\linefeed #.whitespace)  
-    (set-cat-entry #\space #.whitespace)
-    (set-cat-entry #\page #.whitespace)
-    (set-cat-entry #\return #.whitespace)
-    (set-cat-entry #\\ #.escape)
-    (set-cmt-entry #\\ #'read-token)
-    (set-cat-entry #\rubout #.whitespace)
-    (set-cmt-entry #\: #'read-token)
-    (set-cmt-entry #\| #'read-token)
-    ;;macro definitions
-    (set-macro-character #\" #'read-string)
-    ;;* # macro
-    (set-macro-character #\' #'read-quote)
-    (set-macro-character #\( #'read-list)
-    (set-macro-character #\) #'read-right-paren)
-    (set-macro-character #\; #'read-comment)
-    ;;* backquote
-    ;;all constituents
-    (do ((ichar 0 (1+ ichar))
-	 (char))
-	((= ichar #O200))
-      (setq char (int-char ichar))
-      (when (constituentp char std-lisp-readtable)
-	    (set-cat-entry char (get-secondary-attribute char))
-	    (set-cmt-entry char #'read-token)))))
-
-
-
-;;;; read-buffer implementation.
-
-(defvar read-buffer)
-(defvar read-buffer-length)
-
-(defvar inch-ptr)
-(defvar ouch-ptr)
-
-(defmacro reset-read-buffer ()
-  ;;turn read-buffer into an empty read-buffer.
-  ;;ouch-ptr always points to next char to write
-  `(progn
-    ;;next is in case interrupt processor has re-bound read-buffer to nil.
-    (unless (or (boundp 'read-buffer) read-buffer) (init-read-buffer))
-    (setq ouch-ptr 0)
-    ;;inch-ptr always points to next char to read
-    (setq inch-ptr 0)))
-
-(defun init-read-buffer ()
-  (setq read-buffer (make-string 512))			;initial bufsize
-  (setq read-buffer-length 512)
-  (reset-read-buffer))
-
-(defmacro ouch-read-buffer (char)
-  `(progn
-    (if (>= (the fixnum ouch-ptr)
-	    (the fixnum read-buffer-length))
-	;;buffer overflow -- double the size
-	(grow-read-buffer))
-    (setf (elt (the simple-string read-buffer) ouch-ptr) ,char)
-    (setq ouch-ptr (1+ ouch-ptr))))
-;; macro to move ouch-ptr back one.
-(defmacro ouch-unread-buffer ()
-  '(if (> (the fixnum ouch-ptr) (the fixnum inch-ptr))
-       (setq ouch-ptr (1- (the fixnum ouch-ptr)))))
-
-(defun grow-read-buffer ()
-  (let ((rbl (length (the simple-string read-buffer))))
-    (declare (fixnum rbl))
-    (setq read-buffer
-	  (concatenate 'simple-string
-		       (the simple-string read-buffer)
-		       (the simple-string (make-string rbl))))
-    (setq read-buffer-length (* 2 rbl))))
-
-(defun inchpeek-read-buffer ()
-  (if (>= (the fixnum inch-ptr) (the fixnum ouch-ptr))
-      eof-object
-      (elt (the simple-string read-buffer) inch-ptr)))
-
-(defun inch-read-buffer ()
-  (cond ((>= (the fixnum inch-ptr) (the fixnum ouch-ptr))
-	 eof-object)
-	(t (prog1 (elt (the simple-string read-buffer) inch-ptr)
-		  (setq inch-ptr (1+ (the fixnum inch-ptr)))))))
-
-(defmacro unread-buffer ()
-  `(decf (the fixnum inch-ptr)))
-
-(defun read-unwind-read-buffer ()
-  ;;keep contents, but make next (inch..) return first char.
-  (setq inch-ptr 0))
-
-(defun read-buffer-to-string ()
-  (subseq (the simple-string read-buffer) 0 ouch-ptr))
-
-
-
-;;;; READ-PRESERVING-WHITESPACE, READ-DELIMITED-LIST, and READ.
-
-(defvar *real-eof-errorp* ()
-  "Value checked by reader if recursivep is true.")
-(defvar *real-eof-value* ()
-  "Eof-value used for eof-value if recursivep is true.")
-
-(defvar right-paren-whitespace t
-  "Flag that READ uses to tell when it's ok to treat right parens as
-  whitespace.")
-
-;; Alist for sharp-equal. Used to keep track of objects with labels assigned
-;; that have been completly read.
-(defvar sharp-equal-alist ())
-
-;; Alist for sharp-sharp. Assoc's a number with a symbol produced by gensym.
-;; Used by sharp-sharp as an unforgeable label, instead of the number.
-(defvar sharp-sharp-alist ())
-
-(proclaim '(special *standard-input*))
- 
-;;; READ-PRESERVING-WHITESPACE behaves just like read only it makes sure
-;;; to leave terminating whitespace in the stream.
-;;;
-(defun read-preserving-whitespace
-  (&optional (stream *standard-input*) (eof-errorp t) (eof-value ())
-	     (recursivep ()))
-  "Reads from stream and returns the object read, preserving the whitespace
-  that followed the object."
-  (let ((*real-eof-value* *real-eof-value*)
-	(*real-eof-errorp* *real-eof-errorp*))
-   (if recursivep
-       (setq eof-errorp *real-eof-errorp*
-	     eof-value *real-eof-value*)
-       (setq *real-eof-value* eof-value
-	     *real-eof-errorp* eof-errorp
-	     ;; The scope of these two lists is the top level read, so they
-	     ;; have to be reset here.
-	     sharp-equal-alist nil
-	     sharp-sharp-alist nil))
-   (progn
-    ;;loop for repeating when a macro returns nothing.
-    (do ((char (read-char stream nil eof-object)
-	       (read-char stream nil eof-object)))
-	(())
-	(cond ((eofp char)
-	       (if eof-errorp
-		   (error "Unexpected end-of-file encountered.")
-		   (return eof-value)))
-	      ((whitespacep char))
-	      (t
-	       (let* ((macrofun (get-cmt-entry char *readtable*))
-		      (result (multiple-value-list
-			       (funcall macrofun stream char))))
-		 ;;repeat if macro returned nothing.
-		 (if result (return (car result))))))))))
-
-(defun read-maybe-nothing (stream char)
-  ;;returns nil or a list with one thing, depending.
-  ;;for functions that want comments to return so they can look
-  ;;past them.  Assumes char is not whitespace.
-  (let ((retval (multiple-value-list
-		 (funcall (get-cmt-entry char *readtable*) stream char))))
-    (if retval (rplacd retval nil))))
-
-(defun read (&optional (stream *standard-input*) (eof-errorp t)
-			   (eof-value ()) (recursivep ()))
-  "Reads in the next object in the stream, which defaults to
-  *standard-input*. For details see the I/O chapter of
-  the manual."
-   (prog1
-    (read-preserving-whitespace stream eof-errorp eof-value recursivep)
-    (let ((whitechar (read-char stream nil eof-object)))
-      (if (and (not (eofp whitechar))
-	       (or (not (whitespacep whitechar))
-		   recursivep))
-	  (unread-char whitechar stream)))))
-
-(defun read-delimited-list (endchar &optional
-				    (input-stream *standard-input*)
-				    recursive-p)
-  "Reads objects from input-stream until the next character after an
-   object's representation is endchar.  A list of those objects read
-   is returned."
-  (declare (ignore recursive-p))
-  (do ((char (flush-whitespace input-stream)
-	     (flush-whitespace input-stream))
-       (retlist ()))
-      ((char= char endchar) (nreverse retlist))
-    (setq retlist (nconc (read-maybe-nothing input-stream char) retlist))))
-
-
-
-;;;; Standard ReadMacro definitions to implement the reader.
-
-(defun read-quote (stream ignore)
-  (declare (ignore ignore))
-  (list 'quote (read stream () () t)))
-
-(defun read-comment (stream ignore)
-  (declare (ignore ignore))
-  (prepare-for-fast-read-char stream
-    (do ((char (fast-read-char nil nil)
-	       (fast-read-char nil nil)))
-	((or (not char) (char= char #\newline))
-	 (done-with-fast-read-char))))
-  ;;don't return anything
-  (values))
-
-(defun read-list (stream ignore)
-  (declare (ignore ignore))
-  (let* ((thelist (list nil))
-	 (listtail thelist))
-    (do ((firstchar (flush-whitespace stream) (flush-whitespace stream)))
-	((char= firstchar #\) ) (cdr thelist))
-      (when (char= firstchar #\.)
-	    (let ((nextchar (read-char stream t)))
-	      (cond ((token-delimiterp nextchar)
-		     (cond ((eq listtail thelist)
-			    (error "Nothing appears before . in list."))
-			   ((whitespacep nextchar)
-			    (setq nextchar (flush-whitespace stream))))
-		     (rplacd listtail
-			     ;;return list containing last thing.
-			     (car (read-after-dot stream nextchar)))
-		     (return (cdr thelist)))
-		    ;;put back nextchar so we can read it normally.
-		    (t (unread-char nextchar stream)))))
-      ;;next thing is not an isolated dot.
-      (let ((listobj (read-maybe-nothing stream firstchar)))
-	;;allows the possibility that a comment was read.
-	(when listobj
-	      (rplacd listtail listobj)
-	      (setq listtail listobj))))))
-
-(defun read-after-dot (stream firstchar)
-  ;;firstchar is non-whitespace!
-  (let ((lastobj ()))
-    (do ((char firstchar (flush-whitespace stream)))
-	((char= char #\) )
-	 (error "Nothing appears after . in list."))
-      ;;see if there's something there.
-      (setq lastobj (read-maybe-nothing stream char))
-      (when lastobj (return t)))
-    ;;at least one thing appears after the dot.
-    ;;check for more than one thing following dot.
-    (do ((lastchar (flush-whitespace stream)
-		   (flush-whitespace stream)))
-	((char= lastchar #\) ) lastobj)	;success!
-      ;;try reading virtual whitespace
-      (if (read-maybe-nothing stream lastchar)
-	  (error "More than one object follows . in list.")))))
-
-(defun read-string (stream closech)
-  ;;this accumulates chars until it sees same char that invoked it.
-  ;;for a very long string, this could end up bloating the read buffer.
-  (reset-read-buffer)
-  (prepare-for-fast-read-char stream
-    (do ((char (fast-read-char t) (fast-read-char t)))
-	((char= char closech)
-	 (done-with-fast-read-char))
-      (if (escapep char) (setq char (fast-read-char t)))
-      (ouch-read-buffer char)))
-  (read-buffer-to-string))
-
-(defun read-right-paren (ig1 ig2)
-  (declare (ignore ig1 ig2))
-  (if right-paren-whitespace
-      (values)
-      (error "Unmatched right parenthesis.")))
-
-(defun internal-read-extended-token (stream firstchar
-					    &aux (escape-appearedp nil))
-  ;;read the string up to the next delimiter.  Leaves resulting token
-  ;;in read-buffer, returns a flag that is true if an escape (\\)
-  ;;appeared, meaning that it has to be a symbol.
-  ;;needs to have package hacks added.
-  (reset-read-buffer)
-  (do ((char firstchar (read-char stream nil eof-object)))
-      ;;for now, treat #\: as a constituent:
-      ;; does this cond need same fix as the top-level read did ??
-      ((cond ((eofp char) t)
-	     ((token-delimiterp char)
-	      (unread-char char stream)
-	      t)
-	     (t nil))
-       escape-appearedp)
-    (cond ((escapep char)
-	   ;;it can't be a number, even if it's 1\23.
-	   (setq escape-appearedp t)
-	   ;;read next char here, so it won't be upper-casified.
-	   (let ((nextchar (read-char stream nil eof-object)))
-	     (if (eofp nextchar)
-		 (error "End-of-file after escape character.")
-		 (ouch-read-buffer nextchar))))
-	  (t (ouch-read-buffer (char-upcase char))))))
-
-
-
-;;;; Character classes.
-
-;;; return the character class for a char
-;;;
-(defmacro char-class (char attable)
-  `(let ((att (svref ,attable (char-int ,char))))
-     (declare (fixnum att))
-     (if (<= att #.terminating-macro)
-	 #.delimiter
-	 att)))
-
-;;; return the character class for a char which might be part of a rational
-;;; number
-;;;
-(defmacro char-class2 (char attable)
-  `(let ((att (svref ,attable (char-int ,char))))
-     (declare (fixnum att))
-     (if (<= att #.terminating-macro)
-	 #.delimiter
-	 (if (digit-char-p ,char *read-base*)
-	     constituent-digit
-	     (if (= att constituent-digit)
-		 constituent
-		 att)))))
-
-;;; return the character class for a char which might be part of a rational or
-;;; floating number (assume that it is a digit if it could be)
-;;;
-(defmacro char-class3 (char attable)
-  `(let ((att (svref ,attable (char-int ,char))))
-     (declare (fixnum att))
-     (if possibly-rational
-	 (setq possibly-rational
-	       (or (digit-char-p ,char *read-base*)
-		   (= att constituent-slash))))
-     (if possibly-float
-	 (setq possibly-float
-	       (or (digit-char-p ,char 10)
-		   (= att constituent-dot))))
-     (if (<= att #.terminating-macro)
-	 #.delimiter
-	 (if (digit-char-p ,char (max *read-base* 10))
-	     (if (digit-char-p ,char *read-base*)
-		 constituent-digit
-		 constituent)
-	     att))))
-
-
-
-;;;; Token fetching.
-
-#|
-(defmacro backup-char (char stream)
-  `(if ,char (unread-char ,char ,stream)))
-|#
-
-(defvar *read-suppress* nil 
-  "Suppresses most interpreting of the reader when T")
-
-(defvar *read-base* 10
-  "The radix that Lisp reads numbers in.")
-
-(defun read-token (stream firstchar)
-  "This function is just an fsm that recognizes numbers and symbols."
-  ;;check explicitly whether firstchar has entry for non-terminating
-  ;;in character-attribute-table and read-dot-number-symbol in CMT.
-  ;;Report an error if these are violated (if we called this, we want
-  ;;something that is a legitimate token!).
-  ;;read in the longest possible string satisfying the bnf for
-  ;;"unqualified-token".  Leave the result in the READ-BUFFER.
-  ;;Return next char after token (last char read).
-  (if *read-suppress*
-      (internal-read-extended-token stream firstchar)
-  (let ((attribute-table (character-attribute-table *readtable*))
-	(package *package*)
-	(colons 0)
-	(possibly-rational t)
-	(possibly-float t))
-    (reset-read-buffer)
-    (prog ((char firstchar))
-      (case (char-class3 char attribute-table)
-	(#.constituent-sign (go SIGN))
-	(#.constituent-digit (go LEFTDIGIT))
-	(#.constituent-dot (go FRONTDOT))
-	(#.escape (go ESCAPE))
-	(#.package-delimiter (go COLON))
-	(#.multiple-escape (go MULT-ESCAPE))
-	;;can't have eof, whitespace, or terminating macro as first char!
-	(t (go SYMBOL)))
-     SIGN
-      ;;saw "sign"
-      (ouch-read-buffer char)
-      (setq char (read-char stream nil nil))
-      (unless char (go RETURN-SYMBOL))
-      (setq possibly-rational t
-	    possibly-float t)
-      (case (char-class3 char attribute-table)
-	(#.constituent-digit (go LEFTDIGIT))
-	(#.constituent-dot (go SIGNDOT))
-	(#.escape (go ESCAPE))
-	(#.package-delimiter (go COLON))
-	(#.multiple-escape (go MULT-ESCAPE))	
-	(#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
-	(t (go SYMBOL)))
-     LEFTDIGIT
-      ;;saw "[sign] {digit}+"
-      (ouch-read-buffer (char-upcase char))
-      (setq char (read-char stream nil nil))
-      (unless char (return (make-integer)))
-      (case (char-class3 char attribute-table)
-	(#.constituent-digit (go LEFTDIGIT))
-	(#.constituent-dot (if possibly-float
-			       (go MIDDLEDOT)
-			       (go SYMBOL)))
-	(#.constituent-expt (go EXPONENT))
-	(#.constituent-slash (if possibly-rational
-				 (go RATIO)
-				 (go SYMBOL)))
-	(#.delimiter (unread-char char stream) (return (make-integer)))
-	(#.escape (go ESCAPE))
-	(#.multiple-escape (go MULT-ESCAPE))
-	(#.package-delimiter (go COLON))
-	(t (go SYMBOL)))
-     MIDDLEDOT
-      ;;saw "[sign] {digit}+ dot"
-      (ouch-read-buffer char)
-      (setq char (read-char stream nil nil))
-      (unless char (return (let ((*read-base* 10))
-			     (make-integer))))
-      (case (char-class char attribute-table)
-	(#.constituent-digit (go RIGHTDIGIT))
-	(#.constituent-expt (go EXPONENT))
-	(#.delimiter (unread-char char stream) (return (let ((*read-base* 10))
-							 (make-integer))))
-	(#.escape (go ESCAPE))
-	(#.multiple-escape (go MULT-ESCAPE))
-	(#.package-delimiter (go COLON))
-	(t (go SYMBOL)))
-     RIGHTDIGIT
-      ;;saw "[sign] {digit}* dot {digit}+"
-      (ouch-read-buffer char)
-      (setq char (read-char stream nil nil))
-      (unless char (return (make-float)))
-      (case (char-class char attribute-table)
-	(#.constituent-digit (go RIGHTDIGIT))
-	(#.constituent-expt (go EXPONENT))
-	(#.delimiter (unread-char char stream) (return (make-float)))
-	(#.escape (go ESCAPE))
-	(#.multiple-escape (go MULT-ESCAPE))
-	(#.package-delimiter (go COLON))
-	(t (go SYMBOL)))
-     SIGNDOT
-      ;;saw "[sign] dot"
-      (ouch-read-buffer char)
-      (setq char (read-char stream nil nil))
-      (unless char (go RETURN-SYMBOL))
-      (case (char-class char attribute-table)
-	(#.constituent-digit (go RIGHTDIGIT))
-	(#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
-	(#.escape (go ESCAPE))
-	(#.multiple-escape (go MULT-ESCAPE))
-	(t (go SYMBOL)))
-     FRONTDOT
-      ;;saw "dot"
-      (ouch-read-buffer char)
-      (setq char (read-char stream nil nil))
-      (unless char (error "Dot context error."))
-      (case (char-class char attribute-table)
-	(#.constituent-digit (go RIGHTDIGIT))
-	(#.constituent-dot (go DOTS))
-	(#.delimiter  (error "Dot context error."))
-	(#.escape (go ESCAPE))
-	(#.multiple-escape (go MULT-ESCAPE))
-	(#.package-delimiter (go COLON))
-	(t (go SYMBOL)))
-     EXPONENT
-      (ouch-read-buffer (char-upcase char))
-      (setq char (read-char stream nil nil))
-      (unless char (go RETURN-SYMBOL))
-      (case (char-class char attribute-table)
-	(#.constituent-sign (go EXPTSIGN))
-	(#.constituent-digit (go EXPTDIGIT))
-	(#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
-	(#.escape (go ESCAPE))
-	(#.multiple-escape (go MULT-ESCAPE))
-	(#.package-delimiter (go COLON))
-	(t (go SYMBOL)))
-     EXPTSIGN
-      ;;we got to EXPONENT, and saw a sign character.
-      (ouch-read-buffer char)
-      (setq char (read-char stream nil nil))
-      (unless char (go RETURN-SYMBOL))
-      (case (char-class char attribute-table)
-	(#.constituent-digit (go EXPTDIGIT))
-	(#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
-	(#.escape (go ESCAPE))
-	(#.multiple-escape (go MULT-ESCAPE))
-	(#.package-delimiter (go COLON))
-	(t (go SYMBOL)))
-     EXPTDIGIT
-      ;;got to EXPONENT, saw "[sign] {digit}+"
-      (ouch-read-buffer char)
-      (setq char (read-char stream nil nil))
-      (unless char (return (make-float)))
-      (case (char-class char attribute-table)
-	(#.constituent-digit (go EXPTDIGIT))
-	(#.delimiter (unread-char char stream) (return (make-float)))
-	(#.escape (go ESCAPE))
-	(#.multiple-escape (go MULT-ESCAPE))
-	(#.package-delimiter (go COLON))
-	(t (go SYMBOL)))
-     RATIO
-      ;;saw "[sign] {digit}+ slash"
-      (ouch-read-buffer char)
-      (setq char (read-char stream nil nil))
-      (unless char (go RETURN-SYMBOL))
-      (case (char-class2 char attribute-table)
-	(#.constituent-digit (go RATIODIGIT))
-	(#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
-	(#.escape (go ESCAPE))
-	(#.multiple-escape (go MULT-ESCAPE))
-	(#.package-delimiter (go COLON))
-	(t (go SYMBOL)))
-     RATIODIGIT
-      ;;saw "[sign] {digit}+ slash {digit}+"
-      (ouch-read-buffer (char-upcase char))
-      (setq char (read-char stream nil nil))
-      (unless char (return (make-ratio)))
-      (case (char-class2 char attribute-table)
-	(#.constituent-digit (go RATIODIGIT))
-	(#.delimiter (unread-char char stream) (return (make-ratio)))
-	(#.escape (go ESCAPE))
-	(#.multiple-escape (go MULT-ESCAPE))
-	(#.package-delimiter (go COLON))
-	(t (go SYMBOL)))
-     DOTS
-      ;;saw "dot {dot}+"
-      (ouch-read-buffer char)
-      (setq char (read-char stream nil nil))
-      (unless char (error "Too many dots."))
-      (case (char-class char attribute-table)
-	(#.constituent-dot (go DOTS))
-	(#.delimiter (unread-char char stream) (error "Too many dots."))
-	(#.escape (go ESCAPE))
-	(#.multiple-escape (go MULT-ESCAPE))
-	(#.package-delimiter (go COLON))
-	(t (go SYMBOL)))
-     SYMBOL
-      ;;not a dot, dots, or number.
-      (prepare-for-fast-read-char stream
-	(prog ()
-	 SYMBOL-LOOP
-	  (ouch-read-buffer (char-upcase char))
-	  (setq char (fast-read-char nil nil))
-	  (unless char (go RETURN-SYMBOL))
-	  (case (char-class char attribute-table)
-	    (#.escape (done-with-fast-read-char)
-		      (go ESCAPE))
-	    (#.delimiter (done-with-fast-read-char)
-			 (unread-char char stream)
-			 (go RETURN-SYMBOL))
-	    (#.multiple-escape (done-with-fast-read-char)
-			       (go MULT-ESCAPE))
-	    (#.package-delimiter (done-with-fast-read-char)
-				 (go COLON))
-	    (t (go SYMBOL-LOOP)))))
-     ESCAPE
-      ;;saw an escape.
-      ;;don't put the escape in the read-buffer.
-      ;;read-next char, put in buffer (no case conversion).
-      (let ((nextchar (read-char stream nil nil)))
-	(if nextchar
-	    (ouch-read-buffer nextchar)
-	    (error "End-of-file after escape character.")))
-      (setq char (read-char stream nil nil))
-      (unless char (go RETURN-SYMBOL))
-      (case (char-class char attribute-table)
-	(#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
-	(#.escape (go ESCAPE))
-	(#.multiple-escape (go MULT-ESCAPE))
-	(#.package-delimiter (go COLON))
-	(t (go SYMBOL)))
-      MULT-ESCAPE
-      (do ((char (read-char stream t) (read-char stream t)))
-	  ((multiple-escape-p char))
-	(if (escapep char) (setq char (read-char stream t)))
-	(ouch-read-buffer char))
-      (setq char (read-char stream nil nil))
-      (unless char (go RETURN-SYMBOL))
-      (case (char-class char attribute-table)
-	(#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
-	(#.escape (go ESCAPE))
-	(#.multiple-escape (go MULT-ESCAPE))
-	(#.package-delimiter (go COLON))
-	(t (go SYMBOL)))
-      COLON
-      (cond ((zerop colons)
-	     (setq colons 1)
-	     (setq package (find-package (read-buffer-to-string)))
-	     (unless package (error "Package ~S not found."
-				    (read-buffer-to-string))))
-	    (t (error "Too many colons in ~S" (read-buffer-to-string))))
-      (reset-read-buffer)
-      (setq char (read-char stream nil nil))
-      (unless char (error "End of file encountered after reading a colon."))
-      (case (char-class char attribute-table)
-	(#.delimiter (unread-char char stream)
-		     (error "Illegal terminating character after a colon, ~S."
-			    char))
-	(#.escape (go ESCAPE))
-	(#.multiple-escape (go MULT-ESCAPE))
-	(#.package-delimiter (go INTERN))
-	(t (go SYMBOL)))
-      INTERN
-      (setq colons 2)
-      (setq char (read-char stream nil nil))
-      (unless char (error "End of file encountered after reading a colon."))
-      (case (char-class char attribute-table)
-	(#.delimiter (unread-char char stream)
-		     (error "Illegal terminating character after a colon, ~S"
-			    char))
-	(#.escape (go ESCAPE))
-	(#.multiple-escape (go MULT-ESCAPE))
-	(#.package-delimiter (error "To many colons after ~S:"
-				    (package-name package)))
-	(t (go SYMBOL)))
-      RETURN-SYMBOL
-      (if (or (zerop colons) (= colons 2) (eq package *keyword-package*))
-	  (return (intern* read-buffer ouch-ptr package))
-	  (multiple-value-bind (symbol test)
-			       (find-symbol* read-buffer ouch-ptr package)
-	    (cond ((eq test :external) (return symbol))
-		  ((null test)
-		   (error "Symbol ~S not found in the ~A package."
-			  (read-buffer-to-string) (package-name package)))
-		  (t (cerror "use symbol anyway."
-			     "The symbol ~S is not external in the ~A package."
-			     (read-buffer-to-string) (package-name package))
-		     (return symbol)))))))))
-
-
-(defun read-extended-token (stream &optional (*readtable* *readtable*))
-  ;;for semi-external use: returns 2 values: the string for the token,
-  ;;and a flag for whether there was an escape char.
-  (let ((firstch (read-char stream nil nil t)))
-    (if firstch
-	(let ((escape-appearedp (internal-read-extended-token stream firstch)))
-	  (values (read-buffer-to-string) escape-appearedp))
-	(values "" nil))))
-
-
-
-;;;; Number reading functions.
-
-(defmacro digit* nil
-  `(do ((ch char (inch-read-buffer)))
-       ((or (eofp ch) (not (digit-char-p ch))) (setq char ch))
-     ;;report if at least one digit is seen:
-     (setq one-digit t)))
-
-(defmacro exponent-letterp (letter)
-  `(memq ,letter '(#\E #\S #\F #\L #\D #\e #\s #\f #\l #\d)))
-
-
-(defvar *integer-reader-safe-digits*
-  '#(NIL NIL
-     26 17 13 11 10 9 8 8 8 7 7 7 7 6 6 6 6 6 6 6 6 5 5 5 5 5 5 5 5 5 5 5 5 5 5)
-  "Holds the mapping of base to 'safe' number of digits to read for a fixnum.")
-
-(defvar *integer-reader-base-power* 
-  '#(NIL NIL
-     67108864 129140163 67108864 48828125 60466176 40353607
-     16777216 43046721 100000000 19487171 35831808 62748517 105413504 11390625
-     16777216 24137569 34012224 47045881 64000000 85766121 113379904 6436343
-     7962624 9765625 11881376 14348907 17210368 20511149 24300000 28629151
-     33554432 39135393 45435424 52521875 60466176)
-  "Holds the largest fixnum power of the base for make-integer.")
-
-#|
-(defun init-integer-reader ()
-  (do ((base 2 (1+ base)))
-      ((> base 36))
-    (let ((digits
-	  (do ((fix (truncate most-positive-fixnum base)
-		    (truncate fix base))
-	       (digits 0 (1+ digits)))
-	      ((zerop fix) digits))))	   
-      (setf (aref *integer-reader-safe-digits* base)
-	    digits
-	    (aref *integer-reader-base-power* base)
-	    (expt base digits)))))
-|#
-
-(defun make-integer ()
-  "Minimizes bignum-fixnum multiplies by reading a 'safe' number of digits, 
-  then multiplying by a power of the base and adding."
-  (let* ((base (if (boundp '*read-base*)
-		  (if (and (fixnump *read-base*)
-			   (<= 1 *read-base* 36))
-		      *read-base*
-		      (error "~A not a valid number for *read-base*."
-			     *read-base*))
-		  10.))
-	 (digits-per (aref *integer-reader-safe-digits* base))
-	 (base-power (aref *integer-reader-base-power* base)) 
-	 (negativep nil)
-	 (number 0))
-    (read-unwind-read-buffer)
-    (let ((char (inch-read-buffer)))
-      (cond ((char= char #\-)
-	     (setq negativep t))
-	    ((char= char #\+))
-	    (t (unread-buffer))))
-    (loop
-     (let ((num 0))
-       (dotimes (digit digits-per)
-	 (let* ((ch (inch-read-buffer)))
-	   (cond ((or (eofp ch) (char= ch #\.))
-		  (return-from make-integer
-			       (let ((Res
-				      (if (zerop number) num
-					  (+ num (* number
-						    (expt base digit))))))
-				 (if negativep (- res) res))))
-		 (t (setq num (+ (digit-char-p ch base) (* num base)))))))
-       (setq number (+ num (* number base-power)))))))
-
-
-
-(defun make-float ()
-  ;;assume that the contents of read-buffer are a legal float, with nothing
-  ;;else after it.
-  (read-unwind-read-buffer)
-  (let ((negative-fraction nil)
-	(number 0)
-	(divisor 1)
-	(negative-exponent nil)
-	(exponent 0)
-	(float-char ()) (char (inch-read-buffer)))
-    (if (cond ((char= char #\+) t)
-	      ((char= char #\-) (setq negative-fraction t)))
-	;;flush it
-	(setq char (inch-read-buffer)))
-    ;;read digits before the dot
-    (do* ((ch char (inch-read-buffer))
-	  (dig (digit-char-p ch) (digit-char-p ch)))
-	 ((not dig) (setq char ch))
-      (setq number (+ (* number 10) dig)))
-    ;;deal with the dot, if it's there.
-    (when (char= char #\.)
-      (setq char (inch-read-buffer))
-      ;;read digits after the dot.
-      (do* ((ch char (inch-read-buffer))
-	    (dig (and (not (eofp ch)) (digit-char-p ch))
-		 (and (not (eofp ch)) (digit-char-p ch))))
-	   ((not dig) (setq char ch))
-	(setq divisor (* divisor 10))
-	(setq number (+ (* number 10) dig))))
-    ;;is there an exponent letter?
-    (cond ((eofp char)
-	   ;;if not, we've read the whole number.
-	   (let ((num (make-float-aux number divisor
-				      *read-default-float-format*)))
-	     (return-from make-float (if negative-fraction (- num) num))))
-	  ((exponent-letterp char)
-	   (setq float-char char)
-	   ;;build exponent
-	   (setq char (inch-read-buffer))
-	   ;;check leading sign
-	   (if (cond ((char= char #\+) t)
-		     ((char= char #\-) (setq negative-exponent t)))
-	       ;;flush sign
-	       (setq char (inch-read-buffer)))
-	   ;;read digits for exponent
-	   (do* ((ch char (inch-read-buffer))
-		 (dig (and (not (eofp ch)) (digit-char-p ch))
-		      (and (not (eofp ch)) (digit-char-p ch))))
-	       ((not dig)
-		(setq exponent (if negative-exponent (- exponent) exponent)))
-	       (setq exponent (+ (* exponent 10) dig)))
-	   ;;generate and return the float, depending on float-char:
-	   (let* ((float-format (case float-char
-				  (#\E *read-default-float-format*)
-				  (#\S 'short-float)
-				  (#\F 'single-float)
-				  (#\D 'double-float)
-				  (#\L 'long-float)))
-		  (num (make-float-aux number divisor float-format)))
-	     (setq num (* num (expt 10 exponent)))
-	     (return-from make-float (if negative-fraction (- num) num))))
-	  ;;should never happen:	
-	  (t (error "Internal error in floating point reader.")))))
-
-(defun make-float-aux (number divisor float-format)
-  (let ((fgcd (gcd number divisor)))
-    (when (/= fgcd 1)
-      (setq number (truncate number fgcd))
-      (setq divisor (truncate divisor fgcd))))
-  (when (= divisor 1)
-    (return-from make-float-aux (coerce number float-format)))
-  (let ((float-digits (case float-format
-			((short-float single-float) 37)
-			((double-float long-float) 307)
-			(t 307)))
-	(digits (round (integer-length number) (log 10 2))))
-    (cond ((<= digits float-digits)
-	   (/ (coerce number float-format)
-	      (coerce divisor float-format)))
-	  (T (let ((adj-amount (expt 10 (- digits float-digits))))
-	       (/ (coerce (round number adj-amount) float-format)
-		  (coerce (round divisor adj-amount) float-format)))))))
-
-(defun make-ratio ()
-  ;;assume read-buffer contains a legal ratio.  Build the number from
-  ;;the string.
-  ;;look for optional "+" or "-".
-  (let ((numerator 0) (denominator 0) (char ()) (negative-number nil))
-    (read-unwind-read-buffer)
-    (setq char (inch-read-buffer))
-    (cond ((char= char #\+)
-	   (setq char (inch-read-buffer)))
-	  ((char= char #\-)
-	   (setq char (inch-read-buffer))
-	   (setq negative-number t)))
-    ;;get numerator
-    (do* ((ch char (inch-read-buffer))
-	  (dig (digit-char-p ch *read-base*)
-	       (digit-char-p ch *read-base*)))
-	 ((not dig))
-	 (setq numerator (+ (* numerator *read-base*) dig)))
-    ;;get denominator
-    (do* ((ch (inch-read-buffer) (inch-read-buffer))
-	  (dig ()))
-	 ((or (eofp ch) (not (setq dig (digit-char-p ch *read-base*)))))
-	 (setq denominator (+ (* denominator *read-base*) dig)))
-    (let ((num (/ numerator denominator)))
-      (if negative-number (- num) num))))
-
-       
-
-;;;; dispatching macro cruft
-
-(defun make-char-dispatch-table ()
-  (make-array 128 :initial-element #'dispatch-char-error))
-
-(defun dispatch-char-error (ig1 sub-char ig2)
-  (declare (ignore ig1 ig2))
-  (error "No dispatch function defined for ~S."	sub-char))
-
-(defun make-dispatch-macro-character (char &optional
-					   (non-terminating-p nil)
-					   (rt *readtable*))
-  "Causes char to become a dispatching macro character in readtable
-   (which defaults to the current readtable).  If the non-terminating-p
-   flag is set to T, the char will be non-terminating.  Make-dispatch-
-   macro-character returns T."
-  (set-macro-character char #'read-dispatch-char non-terminating-p rt)
-  (let* ((dalist (dispatch-tables rt))
-	 (dtable (cdr (find char dalist :test #'char= :key #'car))))
-    (cond (dtable
-	   (error "Dispatch character already exists"))
-	  (t
-	   (setf (dispatch-tables rt)
-	    (push (cons char (make-char-dispatch-table)) dalist))))))
-
-(defun set-dispatch-macro-character
-  (disp-char sub-char function &optional (rt *readtable*))
-  "Causes function to be called whenever the reader reads
-   disp-char followed by sub-char. Set-dispatch-macro-character
-   returns T."
-  ;;get the dispatch char for macro (error if not there), diddle
-  ;;entry for sub-char.
-  (let ((dpair (find disp-char (dispatch-tables rt)
-		     :test #'char= :key #'car)))
-    (if dpair
-	(setf (elt (the simple-vector (cdr dpair))
-		   (char-int sub-char))
-	      function)
-	(error "~S is not a dispatch char." disp-char))))
-
-(defun get-dispatch-macro-character (disp-char sub-char
-					       &optional (rt *readtable*))
-  "Returns the macro character function for sub-char under disp-char
-   or nil if there is no associated function."
-  (when (null rt) (setf rt *readtable*))
-  (let ((dpair (find disp-char (dispatch-tables rt)
-		     :test #'char= :key #'car)))
-    (if dpair
-	(elt (the simple-vector (cdr dpair))
-	     (char-int sub-char))
-	(error "~S is not a dispatch char." disp-char))))
-
-(defun read-dispatch-char (stream char)
-  ;;read some digits
-  (let ((numargp nil)
-	(numarg 0)
-	(sub-char ()))
-    (do* ((ch (read-char stream nil eof-object)
-	      (read-char stream nil eof-object))
-	  (dig ()))
-	 ((or (eofp ch)
-	      (not (setq dig (digit-char-p ch))))
-	  ;;take care of the extra char.
-	  (if (eofp ch)
-	      (error "End-of-file inside dispatch character.")
-	      (setq sub-char ch)))
-	 (setq numargp t)
-	 (setq numarg (+ (* numarg 10) dig)))
-    ;;look up the function and call it.
-    (let ((dpair (find char (dispatch-tables *readtable*)
-		       :test #'char= :key #'car)))
-      (if dpair
-	  (funcall (elt (the simple-vector (cdr dpair))
-			(char-int sub-char))
-		   stream sub-char (if numargp numarg nil))
-	  (error "No dispatch table for dispatch char.")))))
-
-
-
-;;;; READ-FROM-STRING.
-
-(defvar read-from-string-spares ()
-  "A resource of string streams for Read-From-String.")
-
-(defun read-from-string (string &optional eof-error-p eof-value
-				&key (start 0) (end (length string))
-				preserve-whitespace)
-  "The characters of string are successively given to the lisp reader
-   and the lisp object built by the reader is returned.  Macro chars
-   will take effect."
-  (declare (string string))
-  (if (null end) (setq end (length string)))
-  (unless read-from-string-spares
-    (push (internal-make-string-input-stream "" 0 0) read-from-string-spares))
-  (let ((stream (pop read-from-string-spares)))
-    (setf (string-input-stream-string stream) (coerce string 'simple-string))
-    (setf (string-input-stream-current stream) start)
-    (setf (string-input-stream-end stream) end)
-    (unwind-protect
-      (values (if preserve-whitespace
-		  (read-preserving-whitespace stream eof-error-p eof-value)
-		  (read stream eof-error-p eof-value))
-	      (string-input-stream-current stream))
-      (push stream read-from-string-spares))))
-
-
-
-;;;; PARSE-INTEGER.
-
-(defun parse-integer (string &key (start 0) (end (length string))
-			     (radix 10) junk-allowed)
-  "Examine the substring of string delimited by start and end
-   (default to the beginning and end of the string)  It skips over
-   whitespace characters and then tries to parse an integer.  The
-   radix parameter must be between 2 and 36."
-  (declare (fixnum end))
-  (if (null end) (setq end (length string)))
-  (let ((index (do ((i start (1+ i)))
-		   ((= i end)
-		    (if junk-allowed
-			(return-from parse-integer (values nil end))
-			(error "No non-whitespace characters in number.")))
-		 (declare (fixnum i))
-		 (unless (whitespacep (char string i)) (return i))))
-	(minusp nil)
-	(found-digit nil)
-	(result 0))
-    (declare (fixnum index))
-    (let ((char (char string index)))
-      (cond ((char= char #\-)
-	     (setq minusp t)
-	     (incf index))
-	    ((char= char #\+)
-	     (incf index))))
-    (loop
-     (when (= index end) (return nil))
-     (let* ((char (char string index))
-	    (weight (digit-char-p char radix)))
-       (cond (weight
-	      (setq result (+ weight (* result radix))
-		    found-digit t))
-	     (junk-allowed (return nil))
-	     ((whitespacep char)
-	      (do ((jndex (1+ index) (1+ jndex)))
-		  ((= jndex end))
-		(declare (fixnum jndex))
-		(unless (whitespacep (char string jndex))
-		  (error "There's junk in this string: ~S." string)))
-	      (return nil))
-	     (t
-	      (error "There's junk in this string: ~S." string))))
-     (incf index))
-    (values
-     (if found-digit
-	 (if minusp (- result) result)
-	 (if junk-allowed
-	     nil
-	     (error "There's no digits in this string: ~S" string)))
-     index)))
-
-
-
-;;;; Reader initialization code.
-
-(defun reader-init ()
-  (init-read-buffer)
-  (init-secondary-attribute-table)
-  (init-std-lisp-readtable)
-; (init-integer-reader)
-  )
diff --git a/code/remote.lisp b/code/remote.lisp
deleted file mode 100644
index fe1cb60608e2952381b3715c95a2bc3ca71cc01a..0000000000000000000000000000000000000000
--- a/code/remote.lisp
+++ /dev/null
@@ -1,363 +0,0 @@
-;;; -*- Log: code.log; Package: wire -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; This file implements a simple remote procedure call mechanism on top
-;;; of wire.lisp.
-;;;
-;;; Written by William Lott.
-;;;
-
-(in-package "WIRE")
-
-(export '(remote remote-value remote-value-bind create-request-server
-	  destroy-request-server connect-to-remote-server))
-
-
-(defstruct remote-wait
-  value1 value2 value3 value4 value5
-  abort
-  finished)
-
-(defvar *pending-returns* nil
-  "AList of wire . remote-wait structs")
-
-
-;;; MAYBE-NUKE-REMOTE-WAIT -- internal
-;;;
-;;; If the remote wait has finished, remove the external translation.
-;;; Otherwise, mark the remote wait as finished so the next call to
-;;; MAYBE-NUKE-REMOTE-WAIT will really nuke it.
-;;;
-(defun maybe-nuke-remote-wait (remote)
-  (cond ((remote-wait-finished remote)
-	 (forget-remote-translation remote)
-	 t)
-	(t
-	 (setf (remote-wait-finished remote)
-	       t)
-	 nil)))
-
-;;; REMOTE -- public
-;;;
-;;; Execute the body remotly. Subforms are executed locally in the lexical
-;;; envionment of the macro call. No values are returned.
-;;;
-(defmacro remote (wire-form &body forms)
-  "Evaluates the given forms remotly. No values are returned, as the remote
-evaluation is asyncronus."
-  (let ((wire (gensym)))
-    `(let ((,wire ,wire-form))
-       ,@(mapcar #'(lambda (form)
-		     `(wire-output-funcall ,wire
-					   ',(car form)
-					   ,@(cdr form)))
-	   forms)
-       (values))))
-
-;;; REMOTE-VALUE-BIND -- public
-;;;
-;;; Send to remote forms. First, a call to the correct dispatch routine based
-;;; on the number of args, then the actual call. The dispatch routine will get
-;;; the second funcall and fill in the correct number of arguments.
-;;; Note: if there are no arguments, we don't even wait for the function to
-;;; return, cause we can kind of guess at what the currect results would be.
-;;;
-(defmacro remote-value-bind (wire-form vars form &rest body)
-  "Bind vars to the multiple values of form (which is executed remotly). The
-forms in body are only executed if the remote function returned as apposed
-to aborting due to a throw."
-  (cond
-   ((null vars)
-    `(progn
-       (remote ,wire-form ,form)
-       ,@body))
-   (t
-    (let ((remote (gensym))
-	  (wire (gensym)))
-      `(let* ((,remote (make-remote-wait))
-	      (,wire ,wire-form)
-	      (*pending-returns* (cons (cons ,wire ,remote)
-				       *pending-returns*)))
-	 (unwind-protect
-	     (let ,vars
-	       (remote ,wire
-		 (,(case (length vars)
-		     (1 'do-1-value-call)
-		     (2 'do-2-value-call)
-		     (3 'do-3-value-call)
-		     (4 'do-4-value-call)
-		     (5 'do-5-value-call)
-		     (t 'do-n-value-call))
-		  (make-remote-object ,remote))
-		 ,form)
-	       (wire-force-output ,wire)
-	       (loop
-		 (system:serve-all-events)
-		 (when (remote-wait-finished ,remote)
-		   (return)))
-	       (unless (remote-wait-abort ,remote)
-		 ,(case (length vars)
-		    (1 `(setf ,(first vars) (remote-wait-value1 ,remote)))
-		    (2 `(setf ,(first vars) (remote-wait-value1 ,remote)
-			      ,(second vars) (remote-wait-value2 ,remote)))
-		    (3 `(setf ,(first vars) (remote-wait-value1 ,remote)
-			      ,(second vars) (remote-wait-value2 ,remote)
-			      ,(third vars) (remote-wait-value3 ,remote)))
-		    (4 `(setf ,(first vars) (remote-wait-value1 ,remote)
-			      ,(second vars) (remote-wait-value2 ,remote)
-			      ,(third vars) (remote-wait-value3 ,remote)
-			      ,(fourth vars) (remote-wait-value4 ,remote)))
-		    (5 `(setf ,(first vars) (remote-wait-value1 ,remote)
-			      ,(second vars) (remote-wait-value2 ,remote)
-			      ,(third vars) (remote-wait-value3 ,remote)
-			      ,(fourth vars) (remote-wait-value4 ,remote)
-			      ,(fifth vars) (remote-wait-value5 ,remote)))
-		    (t
-		     (do ((remaining-vars vars (cdr remaining-vars))
-			  (form (list 'setf)
-				(nconc form
-				       (list (car remaining-vars)
-					     `(pop values)))))
-			 ((null remaining-vars)
-			  `(let ((values (remote-wait-value1 ,remote)))
-			     ,form)))))
-		 ,@body))
-	   (maybe-nuke-remote-wait ,remote)))))))
-
-
-;;; REMOTE-VALUE -- public
-;;;
-;;; Alternate interface to getting the single return value of a remote
-;;; function. Works pretty much just the same, except the single value is
-;;; returned.
-;;;
-(defmacro remote-value (wire-form form &optional
-				  (on-server-unwind
-				   `(error "Remote server unwound")))
-  "Execute the single form remotly. The value of the form is returned.
-  The optional form on-server-unwind is only evaluated if the server unwinds
-  instead of returning."
-  (let ((remote (gensym))
-	(wire (gensym)))
-    `(let* ((,remote (make-remote-wait))
-	    (,wire ,wire-form)
-	    (*pending-returns* (cons (cons ,wire ,remote)
-				     *pending-returns*)))
-       (unwind-protect
-	   (progn
-	     (remote ,wire
-	       (do-1-value-call (make-remote-object ,remote))
-	       ,form)
-	     (wire-force-output ,wire)
-	     (loop
-	       (system:serve-all-events)
-	       (when (remote-wait-finished ,remote)
-		 (return))))
-	 (maybe-nuke-remote-wait ,remote))
-       (if (remote-wait-abort ,remote)
-	 ,on-server-unwind
-	 (remote-wait-value1 ,remote)))))
-
-;;; DEFINE-FUNCTIONS -- internal
-;;;
-;;;   Defines two functions, one that the client runs in the server, and one
-;;; that the server runs in the client:
-;;;
-;;; DO-n-VALUE-CALL -- internal
-;;;
-;;;   Executed by the remote process. Reads the next object off the wire and
-;;; sends the value back. Unwind-protect is used to make sure we send something
-;;; back so the requestor doesn't hang.
-;;;
-;;; RETURN-n-VALUE -- internal
-;;;
-;;;   The remote procedure returned the given value, so fill it in the
-;;; remote-wait structure. Note, if the requestor has aborted, just throw
-;;; the value away.
-;;;
-(defmacro define-functions (values)
-  (let ((do-call (intern (format nil "~:@(do-~D-value-call~)" values)))
-	(return-values (intern (format nil "~:@(return-~D-value~:P~)" values)))
-	(vars nil))
-    (dotimes (i values)
-      (push (gensym) vars))
-    (setf vars (nreverse vars))
-    `(progn
-       (defun ,do-call (result)
-	 (let (worked ,@vars)
-	   (unwind-protect
-	       (progn
-		 (multiple-value-setq ,vars
-		   (wire-get-object *current-wire*))
-		 (setf worked t))
-	     (if worked
-	       (remote *current-wire*
-		 (,return-values result ,@vars))
-	       (remote *current-wire*
-		 (remote-return-abort result)))
-	     (wire-force-output *current-wire*))))
-       (defun ,return-values (remote ,@vars)
-	 (let ((result (remote-object-value remote)))
-	   (unless (maybe-nuke-remote-wait result)
-	     ,@(let ((setf-forms nil))
-		 (dotimes (i values)
-		   (push `(setf (,(intern (format nil
-						  "~:@(remote-wait-value~D~)"
-						  (1+ i)))
-				 result)
-				,(nth i vars))
-			 setf-forms))
-		 (nreverse setf-forms))))
-	 nil))))
-
-(define-functions 1)
-(define-functions 2)
-(define-functions 3)
-(define-functions 4)
-(define-functions 5)
-
-
-;;; DO-N-VALUE-CALL -- internal
-;;; 
-;;; For more values then 5, all the values are rolled into a list and passed
-;;; back as the first value, so we use RETURN-1-VALUE to return it.
-;;;
-(defun do-n-value-call (result)
-  (let (worked values)
-    (unwind-protect
-	(progn
-	  (setf values
-		(multiple-value-list (wire-get-object *current-wire*)))
-	  (setf worked t))
-      (if worked
-	(remote *current-wire*
-	  (return-1-values result values))
-	(remote *current-wire*
-	  (remote-return-abort result)))
-      (wire-force-output *current-wire*))))
-
-;;; REMOTE-RETURN-ABORT -- internal
-;;;
-;;; The remote call aborted instead of returned.
-;;;
-(defun remote-return-abort (result)
-  (setf result (remote-object-value result))
-  (unless (maybe-nuke-remote-wait result)
-    (setf (remote-wait-abort result) t)))
-
-;;; SERVE-REQUESTS -- internal
-;;;
-;;; Serve all pending requests on the given wire.
-;;;
-(defun serve-requests (wire on-death)
-  (handler-bind
-      ((wire-eof #'(lambda (condition)
-		     (declare (ignore condition))
-		     (system:invalidate-descriptor (wire-fd wire))
-		     (mach:unix-close (wire-fd wire))
-		     (dolist (pending *pending-returns*)
-		       (when (eq (car pending)
-				 wire)
-			 (unless (maybe-nuke-remote-wait (cdr pending))
-			   (setf (remote-wait-abort (cdr pending))
-				 t))))
-		     (when on-death
-		       (funcall on-death))
-		     (return-from serve-requests (values))))
-       (wire-error #'(lambda (condition)
-		       (declare (ignore condition))
-		       (system:invalidate-descriptor (wire-fd wire)))))
-    (loop
-      (unless (wire-listen wire)
-	(return))
-      (wire-get-object wire)))
-  (values))
-
-;;; NEW-CONNECTION -- internal
-;;;
-;;;   Maybe build a new wire and add it to the servers list of fds. If the user
-;;; Supplied a function, close the socket if it returns NIL. Otherwise, install
-;;; the wire.
-;;;
-(defun new-connection (socket addr on-connect)
-  (let ((wire (make-wire socket))
-	(on-death nil))
-    (if (or (null on-connect)
-	    (multiple-value-bind (okay death-fn)
-				 (funcall on-connect wire addr)
-	      (setf on-death death-fn)
-	      okay))
-      (system:add-fd-handler socket :input
-	#'(lambda (socket)
-	    (declare (ignore socket))
-	    (serve-requests wire on-death)))
-      (ext:close-socket socket))))
-
-;;; REQUEST-SERVER structure
-;;;
-;;; Just a simple handle on the socket and system:serve-event handler that make
-;;; up a request server.
-;;;
-(defstruct (request-server
-	    (:print-function %print-request-server))
-  socket
-  handler)
-
-(defun %print-request-server (rs stream depth)
-  (declare (ignore depth))
-  (format stream "#<Requst server for ~D>" (request-server-socket rs)))
-
-
-;;; CREATE-REQUEST-SERVER -- Public.
-;;;
-;;; Create a TCP/IP listener on the given port.  If anyone tries to connect to
-;;; it, call NEW-CONNECTION to do the connecting.
-;;;
-(defun create-request-server (port &optional on-connect)
-  "Create a request server on the given port.  Whenevery anyone connects to it
-   call the given function with the newly created wire and the address of the
-   connector.  If the function returns NIL, the connection is destroyed;
-   otherwise, it is accepted.  This returns a manifestation of the server that
-   DESTROY-REQUEST-SERVER accepts to kill the request server."
-  (let* ((socket (ext:create-inet-listener port))
-	 (handler (system:add-fd-handler socket :input
-		    #'(lambda (socket)
-			(multiple-value-bind
-			    (newconn addr)
-			    (ext:accept-tcp-connection socket)
-			  (new-connection newconn addr on-connect))))))
-    (make-request-server :socket socket
-			 :handler handler)))
-
-;;; DESTROY-REQUEST-SERVER -- Public.
-;;;
-;;; Removes the request server from SERVER's list of file descriptors and
-;;; closes the socket behind it.
-;;;
-(defun destroy-request-server (server)
-  "Quit accepting connections to the given request server."
-  (system:remove-fd-handler (request-server-handler server))
-  (ext:close-socket (request-server-socket server))
-  nil)
-
-;;; CONNECT-TO-REMOTE-SERVER -- Public.
-;;;
-;;; Just like the doc string says, connect to a remote server. A handler is
-;;; installed to handle return values, etc.
-;;; 
-(defun connect-to-remote-server (hostname port &optional on-death)
-  "Connect to a remote request server addressed with the given host and port
-   pair.  This returns the created wire."
-  (let* ((socket (ext:connect-to-inet-socket hostname port))
-	 (wire (make-wire socket)))
-    (system:add-fd-handler socket :input
-      #'(lambda (socket)
-	  (declare (ignore socket))
-	  (serve-requests wire on-death)))
-    wire))
diff --git a/code/run-program.lisp b/code/run-program.lisp
deleted file mode 100644
index 3668edab64b665bb3b5e58019c94112a4faee42e..0000000000000000000000000000000000000000
--- a/code/run-program.lisp
+++ /dev/null
@@ -1,651 +0,0 @@
-;;; -*- Package: Extensions; Log: code.log  -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; RUN-PROGRAM and friends.  Factilty for running unix programs from inside
-;;; a lisp.
-;;; 
-;;; Written by Jim Healy and Bill Chiles, November 1987, using an earlier
-;;; version written by David McDonald.
-;;;
-;;; Completely re-written by William Lott, July 1989 - January 1990.
-;;;
-
-(in-package "EXTENSIONS")
-
-(export '(run-program process-status process-exit-code process-core-dumped
-	  process-wait process-kill process-input process-output process-plist
-	  process-pty process-error process-status-hook process-alive-p
-	  process-close process-pid process-p))
-
-
-;;;; Import WAIT3 from unix.
-
-(ext:def-c-pointer *wait (unsigned-byte 32))
-
-(ext:def-c-routine ("wait3" c-wait3)
-		   (int)
-    (status *wait :out)
-    (options int)
-    (rusage int))
-
-(eval-when (load eval compile)
-  (defconstant wait-wstopped #o177)
-  (defconstant wait-wnohang 1)
-  (defconstant wait-wuntraced 2))
-
-(defun wait3 (&optional do-not-hang check-for-stopped)
-  "Return any available status information on child processed. "
-  (multiple-value-bind (pid status)
-		       (c-wait3 (logior (if do-not-hang
-					  wait-wnohang
-					  0)
-					(if check-for-stopped
-					  wait-wuntraced
-					  0))
-				0)
-    (cond ((or (minusp pid)
-	       (zerop pid))
-	   nil)
-	  ((eql (ldb (byte 8 0) status)
-		wait-wstopped)
-	   (values pid
-		   :stopped
-		   (ldb (byte 8 8) status)))
-	  ((zerop (ldb (byte 7 0) status))
-	   (values pid
-		   :exited
-		   (ldb (byte 8 8) status)))
-	  (t
-	   (let ((signal (ldb (byte 7 0) status)))
-	     (values pid
-		     (if (or (eql signal mach:sigstop)
-			     (eql signal mach:sigtstp)
-			     (eql signal mach:sigttin)
-			     (eql signal mach:sigttou))
-		       :stopped
-		       :signaled)
-		     signal
-		     (not (zerop (ldb (byte 1 7) status)))))))))
-
-
-
-;;;; Process control stuff.
-
-(defvar *active-processes* nil
-  "List of process structures for all active processes.")
-
-(defstruct (process (:print-function %print-process))
-  pid			      ; PID of child process.
-  %status		      ; Either :RUNNING, :STOPPED, :EXITED, or :SIGNALED.
-  exit-code		      ; Either exit code or signal
-  core-dumped		      ; T if a core image was dumped.
-  pty			      ; Stream to child's pty or nil.
-  input			      ; Stream to child's input or nil.
-  output		      ; Stream from child's output or nil.
-  error			      ; Stream from child's error output or nil.
-  status-hook		      ; Closure to call when PROC changes status.
-  plist			      ; Place for clients to stash tings.
-  )
-
-(defun %print-process (proc stream depth)
-  (declare (ignore depth))
-  (format stream "#<process ~D ~S>"
-	  (process-pid proc)
-	  (process-status proc)))
-
-;;; PROCESS-STATUS -- Public.
-;;;
-(defun process-status (proc)
-  "Return the current status of process.  The result is one of :running,
-   :stopped, :exited, :signaled."
-  (get-processes-status-changes)
-  (process-%status proc))
-
-
-;;; PROCESS-WAIT -- Public.
-;;;
-(defun process-wait (proc &optional check-for-stopped)
-  "Wait for PROC to quit running for some reason.  Returns PROC."
-  (loop
-    (unless (or (eq (process-status proc) :running)
-		(and check-for-stopped
-		     (eq (process-status proc) :stopped)))
-      (return))
-    (system:serve-all-events 1))
-  proc)
-
-;;; FIND-CURRENT-FOREGROUND-PROCESS -- internal
-;;;
-;;; Finds the current foreground process group id.
-;;; 
-(defun find-current-foreground-process (proc)
-  (mach:with-trap-arg-block mach::int1 pgrp
-    (multiple-value-bind
-	(wonp error)
-	(mach:unix-ioctl (system:fd-stream-fd (ext:process-pty proc))
-			 mach:TIOCGPGRP
-			 (lisp::alien-value-sap mach::int1))
-      (unless wonp
-	(error "TIOCPGRP ioctl failed: ~S"
-	       (mach:get-unix-error-msg error)))
-      (system:alien-access (mach::int1-int (system:alien-value pgrp))))))
-
-;;; PROCESS-KILL -- public
-;;;
-;;; Hand a process a signal.
-;;;
-(defun process-kill (proc signal &optional (whom :pid))
-  "Hand SIGNAL to PROC.  If whom is :pid, use the kill Unix system call.  If
-  whom is :process-group, use the killpg Unix system call.  If whom is
-  :pty-process-group deliver the signal to whichever process group is currently
-  in the foreground."
-  (let ((pid (ecase whom
-	       ((:pid :process-group)
-		(process-pid proc))
-	       (:pty-process-group
-		(find-current-foreground-process proc)))))
-    (multiple-value-bind (okay errno)
-			 (if (eq whom :pty-process-group)
-			   (mach:unix-killpg pid signal)
-			   (mach:unix-kill pid signal))
-      (cond ((not okay)
-	     (values nil errno))
-	    ((and (eql pid (process-pid proc))
-		  (= (unix-signal-number signal) mach:sigcont))
-	     (setf (process-%status proc) :running)
-	     (setf (process-exit-code proc) nil)
-	     (when (process-status-hook proc)
-	       (funcall (process-status-hook proc) proc))
-	     t)
-	    (t
-	     t)))))
-
-;;; PROCESS-ALIVE-P -- public
-;;;
-;;; Returns T if the process is still alive, NIL otherwise.
-;;; 
-(defun process-alive-p (proc)
-  "Returns T if the process is still alive, NIL otherwise."
-  (let ((status (process-status proc)))
-    (if (or (eq status :running)
-	    (eq status :stopped))
-      t
-      nil)))
-
-;;; PROCESS-CLOSE -- public
-;;;
-;;; Close all the streams held open by PROC.
-;;; 
-(defun process-close (proc)
-  "Close all streams connected to PROC and stop maintaining the status slot."
-  (macrolet ((frob (stream)
-	       `(when ,stream (close ,stream))))
-    (frob (process-pty proc))
-    (frob (process-input proc))
-    (frob (process-output proc))
-    (frob (process-error proc))
-    (system:without-interrupts
-      (setf *active-processes* (delete proc *active-processes*)))
-    proc))
-
-;;; SIGCHLD-HANDLER -- Internal.
-;;;
-;;; This should be the handler for sigchld signals that RUN-PROGRAM establishes.
-;;;
-;;; Since interrupts are so broken in the current RT system, we don't turn on
-;;; sigchld signals for now.  We call this by hand whenever we need to check
-;;; the status of a process.
-;;;
-(defun sigchld-handler (ignore1 ignore2 ignore3)
-  (declare (ignore ignore1 ignore2 ignore3))
-  (get-processes-status-changes))
-
-;;; GET-PROCESSES-STATUS-CHANGES -- Internal.
-;;;
-(defun get-processes-status-changes ()
-  (loop
-    (multiple-value-bind (pid what code core)
-			 (wait3 t t)
-      (unless pid
-	(return))
-      (let ((proc (find pid *active-processes* :key #'process-pid)))
-	(when proc
-	  (setf (process-%status proc) what)
-	  (setf (process-exit-code proc) code)
-	  (setf (process-core-dumped proc) core)
-	  (when (process-status-hook proc)
-	    (funcall (process-status-hook proc) proc))
-	  (when (or (eq what :exited)
-		    (eq what :signaled))
-	    (system:without-interrupts
-	      (setf *active-processes*
-		    (delete proc *active-processes*)))))))))
-
-
-
-;;;; RUN-PROGRAM and close friends.
-
-(defvar *close-on-error* nil
-  "List of file descriptors to close when RUN-PROGRAM exits due to an error.")
-(defvar *close-in-parent* nil
-  "List of file descriptors to close when RUN-PROGRAM returns in the parent.")
-(defvar *handlers-installed* nil
-  "List of handlers installed by RUN-PROGRAM.")
-
-
-;;; FIND-A-PTY -- internal
-;;;
-;;;   Finds a pty that is not in use. Returns three values: the file descriptor
-;;; for the master side of the pty, the file descriptor for the slave side of
-;;; the pty, and the name of the tty device for the slave side.
-;;; 
-(defun find-a-pty ()
-  "Returns the master fd, the slave fd, and the name of the tty"
-  (dolist (char '(#\p #\q))
-    (dotimes (digit 16)
-      (let* ((master-name (format nil "/dev/pty~C~X" char digit))
-	     (master-fd (mach:unix-open master-name
-					mach:o_rdwr
-					#o666)))
-	(when master-fd
-	  (let* ((slave-name (format nil "/dev/tty~C~X" char digit))
-		 (slave-fd (mach:unix-open slave-name
-					   mach:o_rdwr
-					   #o666)))
-	    (when slave-fd
-	      ; Maybe put a vhangup here?
-	      (mach:unix-ioctl slave-fd
-			       mach:TIOCGETP
-			       (system:alien-sap mach:sgtty))
-	      (setf (system:alien-access (mach::sgtty-flags mach:sgtty))
-		    #o6300) ; XTABS|EVENP|ODDP
-	      (mach:unix-ioctl slave-fd
-			       mach:TIOCSETP
-			       (system:alien-sap mach:sgtty))
-	      (mach:unix-ioctl master-fd
-			       mach:TIOCGETP
-			       (system:alien-sap mach:sgtty))
-	      (setf (system:alien-access (mach::sgtty-flags mach:sgtty))
-		    (logand (system:alien-access (mach::sgtty-flags mach:sgtty))
-			    (lognot 8))) ; ~ECHO
-	      (mach:unix-ioctl master-fd
-			       mach:TIOCSETP
-			       (system:alien-sap mach:sgtty))
-	      (return-from find-a-pty
-			   (values master-fd
-				   slave-fd
-				   slave-name))))
-	  (mach:unix-close master-fd)))))
-  (error "Could not find a pty."))
-
-;;; OPEN-PTY -- internal
-;;;
-(defun open-pty (pty)
-  (when pty
-    (multiple-value-bind
-	(master slave name)
-	(find-a-pty)
-      (push master *close-on-error*)
-      (push slave *close-in-parent*)
-      (when (streamp pty)
-	(multiple-value-bind (won new-fd) (mach:unix-dup master)
-	  (unless won
-	    (error "Could not MACH:UNIX-DUP ~D: ~A"
-		   master (mach:get-unix-error-msg new-fd)))
-	  (push new-fd *close-on-error*)
-	  (copy-descriptor-to-stream new-fd pty)))
-      (values name
-	      (system:make-fd-stream master :input t :output t)))))
-
-;;; SETUP-CHILD -- internal
-;;;
-;;;   Execs the program after setting up the environment correctly. This
-;;; routine never returns under any condition.
-;;;
-(defun setup-child (pfile args env stdin stdout stderr pty-name before-execve)
-  (unwind-protect
-      (handler-bind ((error #'(lambda (condition)
-				(declare (ignore condition))
-				(mach:unix-exit 2))))
-	;; Put us in our own pgrp.
-	(mach:unix-setpgrp 0 (mach:unix-getpid))
-	;; If we want a pty, set it up.
-	(when pty-name
-	  (let ((old-tty (mach:unix-open "/dev/tty" mach:o_rdwr 0)))
-	    (when old-tty
-	      (mach:unix-ioctl old-tty mach:TIOCNOTTY 0)
-	      (mach:unix-close old-tty)))
-	  (let ((new-tty (mach:unix-open pty-name mach:o_rdwr 0)))
-	    (when new-tty
-	      (mach:unix-dup2 new-tty 0)
-	      (mach:unix-dup2 new-tty 1)
-	      (mach:unix-dup2 new-tty 2))))
-	;; Setup the three standard descriptors.
-	(when stdin
-	  (mach:unix-dup2 stdin 0))
-	(when stdout
-	  (mach:unix-dup2 stdout 1))
-	(when stderr
-	  (mach:unix-dup2 stderr 2))
-	;; Close all other descriptors.
-	(do ((fd (1- (mach:unix-getdtablesize))
-		 (1- fd)))
-	    ((= fd 3))
-	  (mach:unix-close fd))
-	;; Do the before-execve
-	(when before-execve
-	  (funcall before-execve))
-	;; Exec the program
-	(mach:unix-execve pfile args env))
-    ;; If exec returns, we lose.
-    (mach:unix-exit 1)))
-
-;;; RUN-PROGRAM -- public
-;;;
-;;;   RUN-PROGRAM uses fork and execve to run a different program. Strange stuff
-;;; happens to keep the unix state of the world coherent.
-;;;
-;;; The child process needs to get it's input from somewhere, and send it's
-;;; output (both standard and error) to somewhere. We have to do different
-;;; things depending on where these somewheres really are.
-;;;
-;;; For input, there are five options:
-;;; - T: Just leave fd 0 alone. Pretty simple.
-;;; - "file": Read from the file. We need to open the file and pull the
-;;; descriptor out of the stream. The parent should close this stream after
-;;; the child is up and running to free any storage used in the parent.
-;;; - NIL: Same as "file", but use "/dev/null" as the file.
-;;; - :STREAM: Use unix-pipe to create two descriptors. Use system:make-fd-stream
-;;; to create the output stream on the writeable descriptor, and pass the
-;;; readable descriptor to the child. The parent must close the readable
-;;; descriptor for EOF to be passed up correctly.
-;;; - a stream: If it's a fd-stream, just pull the descriptor out of it.
-;;; Otherwise make a pipe as in :STREAM, and copy everything across.
-;;;
-;;; For output, there are n options:
-;;; - T: Leave descriptor 1 alone.
-;;; - "file": dump output to the file.
-;;; - NIL: dump output to /dev/null.
-;;; - :STREAM: return a stream that can be read from.
-;;; - a stream: if it's a fd-stream, use the descriptor in it. Otherwise, copy
-;;; stuff from output to stream.
-;;;
-;;; For error, there are all the same options as output plus:
-;;; - :OUTPUT: redirect to the same place as output.
-;;;
-;;; RUN-PROGRAM returns a process struct for the process if the fork worked,
-;;; and NIL if it did not.
-;;;
-(defun run-program (program args
-		    &key (env *environment-list*) (wait t) pty input
-		    if-input-does-not-exist output (if-output-exists :error)
-		    (error :output) (if-error-exists :error) status-hook
-		    before-execve)
-  "Run-program creates a new process and runs the unix progam in the
-   file specified by the simple-string program.  Args are the standard
-   arguments that can be passed to a Unix program, for no arguments
-   use NIL (which means just the name of the program is passed as arg 0).
-
-   Run program will either return NIL or a PROCESS structure.  See the CMU
-   Common Lisp Users Manual for details about the PROCESS structure.
-
-   The keyword arguments have the following meanings:
-     :env -
-        An A-LIST mapping keyword environment variables to simple-string
-	values.
-     :wait -
-        If non-NIL (default), wait until the created process finishes.  If
-        NIL, continue running Lisp until the program finishes.
-     :pty -
-        Either T, NIL, or a stream.  Unless NIL, the subprocess is established
-	under a PTY.  If :pty is a stream, all output to this pty is sent to
-	this stream, otherwise the PROCESS-PTY slot is filled in with a stream
-	connected to pty that can read output and write input.
-     :input -
-        Either T, NIL, a pathname, a stream, or :STREAM.  If T, the standard
-	input for the current process is inherited.  If NIL, /dev/null
-	is used.  If a pathname, the file so spesified is used.  If a stream,
-	all the input is read from that stream and send to the subprocess.  If
-	:STREAM, the PROCESS-INPUT slot is filled in with a stream that sends 
-	its output to the process. Defaults to NIL.
-     :if-input-does-not-exist (when :input is the name of a file) -
-        can be one of:
-           :error - generate an error.
-           :create - create an empty file.
-           nil (default) - return nil from run-program.
-     :output -
-        Either T, NIL, a pathname, a stream, or :STREAM.  If T, the standard
-	input for the current process is inherited.  If NIL, /dev/null
-	is used.  If a pathname, the file so spesified is used.  If a stream,
-	all the output from the process is written to this stream. If
-	:STREAM, the PROCESS-OUTPUT slot is filled in with a stream that can
-	be read to get the output. Defaults to NIL.
-     :if-output-exists (when :input is the name of a file) -
-        can be one of:
-           :error (default) - generates an error if the file already exists.
-           :supersede - output from the program supersedes the file.
-           :append - output from the program is appended to the file.
-           nil - run-program returns nil without doing anything.
-     :error and :if-error-exists - 
-        Same as :output and :if-output-exists, except that :error can also be
-	spesified as :output in which case all error output is routed to the
-	same place as normal output.
-     :status-hook -
-        This is a function the system calls whenever the status of the
-        process changes.  The function takes the process as an argument.
-     :before-execve -
-        This is a function, without arguments, RUN-PROGRAM runs in the child
-        process just before turning it into the specified program."
-
-  ;; Make sure the interrupt handler is installed.
-  ;(system:enable-interrupt mach:sigchld #'sigchld-handler)
-  ;; Make sure all the args are okay.
-  (unless (every #'simple-string-p args)
-    (error "All args to program must be simple strings -- ~S." args))
-  ;; Pre-pend the program to the argument list.
-  (push (namestring program) args)
-  ;; Clear random specials used by GET-DESCRIPTOR-FOR to communicate cleanup
-  ;; info.  Also, establish proc at this level so we can return it.
-  (let (*close-on-error* *close-in-parent* *handlers-installed* proc)
-    (unwind-protect
-	(let ((pfile (namestring (truename (merge-pathnames program "path:")))))
-	  (multiple-value-bind
-	      (stdin input-stream)
-	      (get-descriptor-for input :direction :input
-				  :if-does-not-exist if-input-does-not-exist)
-	    (multiple-value-bind
-		(stdout output-stream)
-		(get-descriptor-for output :direction :output
-				    :if-exists if-output-exists)
-	      (multiple-value-bind
-		  (stderr error-stream)
-		  (if (eq error :output)
-		      (values stdout output-stream)
-		      (get-descriptor-for error :direction :output
-					  :if-exists if-error-exists))
-		(multiple-value-bind (pty-name pty-stream)
-				     (open-pty pty)
-		  ;; Make sure we are not notified about the child death before
-		  ;; we have installed the process struct in *active-processes*
-		  (system:without-interrupts
-		    (multiple-value-bind
-			(child-pid errno)
-			(mach:unix-fork)
-		      (cond ((zerop child-pid)
-			     ;; We are the child. Note: setup-child NEVER returns
-			     (setup-child pfile args env stdin stdout stderr
-					  pty-name before-execve))
-			    ((null child-pid)
-			     ;; This should only happen if the bozo has too
-			     ;; many running procs.
-			     (error "Could not fork child process: ~A"
-				    (mach:get-unix-error-msg errno)))
-			    (t
-			     ;; We are the parent.
-			     (setf proc (make-process :pid child-pid
-						      :%status :running
-						      :pty pty-stream
-						      :input input-stream
-						      :output output-stream
-						      :error error-stream
-						      :status-hook status-hook))
-			     (push proc *active-processes*))))))))))
-      (dolist (fd *close-in-parent*)
-	(mach:unix-close fd))
-      (unless proc
-	(dolist (fd *close-on-error*)
-	  (mach:unix-close fd))
-	(dolist (handler *handlers-installed*)
-	  (system:remove-fd-handler handler))))
-    (when (and wait proc)
-      (process-wait proc))
-    proc))
-
-;;; COPY-DESCRIPTOR-TO-STREAM -- internal
-;;;
-;;;   Installs a handler for any input that shows up on the file descriptor.
-;;; The handler reads the data and writes it to the stream.
-;;; 
-(defun copy-descriptor-to-stream (descriptor stream)
-  (let ((string (make-string 256))
-	handler)
-    (setf handler
-	  (system:add-fd-handler descriptor :input
-	    #'(lambda (fd)
-		(declare (ignore fd))
-		(loop
-		  (multiple-value-bind
-		      (result readable/errno)
-		      (mach:unix-select (1+ descriptor) (ash 1 descriptor)
-					0 0 0)
-		    (cond ((null result)
-			   (error "Could not select on sub-process: ~A"
-				  (mach:get-unix-error-msg readable/errno)))
-			  ((zerop result)
-			   (return))))
-		  (multiple-value-bind
-		      (count errno)
-		      (mach:unix-read descriptor
-				      string
-				      (length string))
-		    (cond ((or (and (null count)
-				    (eql errno mach:eio))
-			       (eql count 0))
-			   (system:remove-fd-handler handler)
-			   (mach:unix-close descriptor)
-			   (return))
-			  ((null count)
-			   (system:remove-fd-handler handler)
-			   (error "Could not read input from sub-process: ~A"
-				  (mach:get-unix-error-msg errno)))
-			  (t
-			   (write-string string stream
-					 :end count))))))))))
-
-;;; GET-DESCRIPTOR-FOR -- internal
-;;;
-;;;   Find a file descriptor to use for object given the direction. Returns
-;;; the descriptor. If object is :STREAM, returns the created stream as the
-;;; second value.
-;;; 
-(defun get-descriptor-for (object &rest keys &key direction &allow-other-keys)
-  (cond ((eq object t)
-	 ;; No new descriptor is needed.
-	 (values nil nil))
-	((eq object nil)
-	 ;; Use /dev/null.
-	 (multiple-value-bind
-	     (fd errno)
-	     (mach:unix-open "/dev/null"
-			     (case direction
-			       (:input mach:o_rdonly)
-			       (:output mach:o_wronly)
-			       (t mach:o_rdwr))
-			     #o666)
-	   (unless fd
-	     (error "Could not open \"/dev/null\": ~A"
-		    (mach:get-unix-error-msg errno)))
-	   (push fd *close-in-parent*)
-	   (values fd nil)))
-	((eq object :stream)
-	 (multiple-value-bind
-	     (read-fd write-fd)
-	     (mach:unix-pipe)
-	   (unless read-fd
-	     (error "Could not create pipe: ~A"
-		    (mach:get-unix-error-msg write-fd)))
-	   (case direction
-	     (:input
-	      (push read-fd *close-in-parent*)
-	      (push write-fd *close-on-error*)
-	      (let ((stream (system:make-fd-stream write-fd :output t)))
-		(values read-fd stream)))
-	     (:output
-	      (push read-fd *close-on-error*)
-	      (push write-fd *close-in-parent*)
-	      (let ((stream (system:make-fd-stream read-fd :input t)))
-		(values write-fd stream)))
-	     (t
-	      (mach:unix-close read-fd)
-	      (mach:unix-close write-fd)
-	      (error "Direction must be either :INPUT or :OUTPUT, not ~S"
-		     direction)))))
-	((stringp object)
-	 (with-open-stream (file (apply #'open object keys))
-	   (multiple-value-bind (won fd)
-				(mach:unix-dup (system:fd-stream-fd file))
-	     (cond (won
-		    (push fd *close-in-parent*)
-		    (values fd nil))
-		   (t
-		    (error "Could not duplicate file descriptor: ~A"
-			   (mach:get-unix-error-msg fd)))))))
-	((system:fd-stream-p object)
-	 (values (system:fd-stream-fd object) nil))
-	((streamp object)
-	 (ecase direction
-	   (:input
-	    (dotimes (count
-		      256
-		      (error "Could not open a temporary file in /tmp"))
-	      (let* ((name (format nil "/tmp/.run-program-~D" count))
-		     (fd (mach:unix-open name
-					 (logior mach:o_rdwr
-						 mach:o_creat
-						 mach:o_excl)
-					 #o666)))
-		(mach:unix-unlink name)
-		(when fd
-		  (let ((newline (string #\Newline)))
-		    (loop
-		      (multiple-value-bind
-			  (line no-cr)
-			  (read-line object nil nil)
-			(unless line
-			  (return))
-			(mach:unix-write fd line 0 (length line))
-			(if no-cr
-			  (return)
-			  (mach:unix-write fd newline 0 1)))))
-		  (mach:unix-lseek fd 0 mach:l_set)
-		  (push fd *close-in-parent*)
-		  (return (values fd nil))))))
-	   (:output
-	    (multiple-value-bind (read-fd write-fd)
-				 (mach:unix-pipe)
-	      (unless read-fd
-		(error "Cound not create pipe: ~A"
-		       (mach:get-unix-error-msg write-fd)))
-	      (copy-descriptor-to-stream read-fd object)
-	      (push read-fd *close-on-error*)
-	      (push write-fd *close-in-parent*)
-	      (values write-fd nil)))))
-	(t
-	 (error "Invalid option to run-program: ~S" object))))
-
diff --git a/code/save.lisp b/code/save.lisp
deleted file mode 100644
index bc6926cb2a008337c7fffe156022800931a7729e..0000000000000000000000000000000000000000
--- a/code/save.lisp
+++ /dev/null
@@ -1,114 +0,0 @@
-;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; Spice Lisp is currently incomplete and under active development.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; Spice Lisp routines to suspend a process and create a core file.
-;;; 
-;;; Written David B. McDonald.
-;;;
-;;;**********************************************************************
-;;;
-;;; To see the format of Spice Lisp core files look at the document
-;;; prva:<slisp.docs>core.mss.
-(in-package "LISP")
-
-(in-package "EXTENSIONS")
-(export '(*environment-list*))
-(defvar *environment-list* nil)
-(in-package "LISP")
-
-
-(proclaim '(special *task-self*))
-
-(defconstant save-block-size (* 64 1024)
-  "Amount to write for each call to write.  This is due to RFS limitations.")
-
-(defvar lisp-environment-list)
-(defvar original-lisp-environment)
-
-;;;; Global state:
-
-(defun save (file)
-  "Save the current lisp core image in a core file.  When it returns in
-  the current process, the number of bytes written is returned.
-  When the saved core image is resumed, Nil is returned."
-  (declare (optimize (speed 3) (safety 0)))
-  (format t "~&[Building saved core image: ")
-  (finish-output)
-  (let ((size-to-allocate (* (current-space-usage) 2)))
-    (declare (fixnum size-to-allocate))
-    (let* ((addr (int-sap (gr-call* mach::vm_allocate *task-self*
-				    0 size-to-allocate t)))
-	   (byte-size (%primitive save *current-alien-free-pointer*
-				  NIL addr)))
-      (cond ((null byte-size)
-	     (mach::vm_deallocate *task-self* addr size-to-allocate)
-	     (error "Save failed."))
-	    ((eq byte-size T)
-	     (dolist (f *before-save-initializations*) (funcall f))
-	     (dolist (f *after-save-initializations*) (funcall f))
-	     (reinit)
-	     (setq original-lisp-environment lisp-environment-list)
-	     (let ((result nil))
-	       (dolist (ele lisp-environment-list
-			    (setf *environment-list* result))
-		 (let ((=pos (position #\= (the simple-string ele))))
-		   ;;
-		   ;; This is dubious since all the strings have an =.
-		   ;; What if one doesn't?  What does that mean?
-		   (when =pos
-		     (push (cons (intern (string-upcase (subseq ele 0 =pos))
-					 *keyword-package*)
-				 (subseq ele (1+ =pos)))
-			   result)))))
-	     NIL)
-	    (T
-	     (format t "~D bytes.~%" byte-size)
-	     (format t "Writing to file: ~A~%" file)
-	     (finish-output)
-	     (multiple-value-bind (fd err) (mach:unix-creat file #o644)
-	       (if (null fd)
-		   (error "Failed to open file ~A, unix error: ~A"
-			  file (mach:get-unix-error-msg err)))
-	       
-	       (do ((left byte-size (- left save-block-size))
-		    (index 0 (+ index save-block-size)))
-		   ((< left save-block-size)
-		    (when (> left 0)
-		      (multiple-value-bind (res err)
-					   (mach:unix-write fd addr index left)
-			(if (null res)
-			    (error "Failed to write file ~A, unix error: ~A"
-				   file (mach:get-unix-error-msg err))))))
-		 (declare (fixnum left index))
-		 (multiple-value-bind (res err)
-				      (mach:unix-write fd addr index
-						       save-block-size)
-		   (if (null res)
-		       (error "Failed to write file ~A, unix error: ~A"
-			      file (mach:get-unix-error-msg err)))))
-	       (multiple-value-bind (res err) (mach:unix-close fd)
-		 (if (null res)
-		     (error "Failed to close file ~A, unix error: ~A"
-			    file (mach:get-unix-error-msg err)))))
-	     (format t "done.]~%")
-	     (mach::vm_deallocate *task-self* addr size-to-allocate)
-	     (finish-output)
-	     byte-size)))))
-
-(defun current-space-usage ()
-  (declare (optimize (speed 3) (safety 0)))
-  (do ((sum 0)
-       (type 0 (1+ type)))
-      ((> type %last-pointer-type) sum)
-    (declare (fixnum type sum))
-    (if (not (or (eq type %short-+-float-type) (eq type %short---float-type)))
-	(multiple-value-bind (dyn stat ro) (space-usage type)
-	  (declare (fixnum dyn stat ro))
-	  (setq sum (+ sum dyn stat ro))))))
diff --git a/code/search-list.lisp b/code/search-list.lisp
deleted file mode 100644
index ffa7c6244a28a82bc677d9df8c8961cffb9fe72f..0000000000000000000000000000000000000000
--- a/code/search-list.lisp
+++ /dev/null
@@ -1,154 +0,0 @@
-;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; Logical name (search list) hackery for Lisp'ers.
-;;;
-;;; Written by Bill Chiles.
-
-(in-package 'lisp)
-(in-package "EXTENSIONS")
-(export 'search-list)
-(in-package 'lisp)
-
-
-(defvar *search-list-table* (make-hash-table :test #'equal))
-(defvar *rsl-circularity-check* (make-hash-table :test #'equal))
-
-
-(defun search-list (name)
-  "Returns a list of strings that are the of name.
-   This is setf'able.  If any provided string in a setting value
-   does end with a colon or slash, a slash is added.  Also, the
-   list is copied."
-  (let ((dev (pathname-device name)))
-    (unless dev (error "No device in ~S." name))
-    (copy-list (gethash dev *search-list-table*))))
-
-(defun %set-search-list (name new-value)
-  (unless (listp new-value)
-    (error "New value for search-list ~S not a list -- ~S."
-	   name new-value))
-  (let ((dev (pathname-device name)))
-    (unless dev (error "No device in ~S." name))
-    (nstring-downcase dev)
-    (setf (gethash dev *search-list-table*)
-	  (mapcar #'(lambda (x)
-		      (declare (simple-string x))
-		      (let* ((len (length x))
-			     (char (schar x (1- len))))
-			(if (or (char= char #\:) (char= char #\/))
-			    x
-			    (concatenate 'simple-string x "/"))))
-		  new-value)))
-  new-value)
-
-
-(defun resolve-search-list (name first-only-p)
-  "This takes a Sesame search-list name (\"default\") instead of the form
-   taken by SEARCH-LIST (\"default:\").  If first-only-p is non-nil, then
-   only the first complete expansion of name is returned.  If, during the
-   expansion of name, an undefined search list is encountered, an error
-   is signaled."
-  (setf name (string-downcase name))
-  (setf (gethash name *rsl-circularity-check*) t)
-  (unwind-protect
-    (resolve-search-list-aux name first-only-p)
-    (clrhash *rsl-circularity-check*)))
-
-
-;;; RESOLVE-SEARCH-LIST-BODY is used in RESOLVE-SEARCH-LIST-AUX and
-;;; RSL-FIRST.  This means the former is recursive, and the former and
-;;; latter are mutually recursive.  This form first looks at an element of
-;;; a list of expansions for a search list for a colon which means that the
-;;; element needs to be further resolved.  If there is no colon, execute
-;;; the already-form.  If there is a colon, grab the new element to resolve
-;;; recursively.  If this new element has been seen already, we have an
-;;; infinite recursion brewing.  Recursively expand this new element.  If
-;;; there are no expansions, signal an error with the offending search list;
-;;; otherwise, execute the expanded-form if the argument element was only a
-;;; search list, or the concat-form if the argument element was a search
-;;; list followed by a directory sequence.  The locals pos, len, and res
-;;; are meant to be referenced at the call sites.
-;;; 
-(eval-when (compile eval)
-(defmacro resolve-search-list-body (first-only-p element expanded-form
-						 concat-form already-form)
-  `(let ((pos (position #\: ,element :test #'char=))
-	 (len (length ,element)))
-     (declare (fixnum len))
-     (if pos
-	 (let ((dev (nstring-downcase (subseq ,element 0 pos))))
-	   (if (gethash dev *rsl-circularity-check*)
-	       (error "Circularity in search list -- ~S." dev)
-	       (setf (gethash dev *rsl-circularity-check*) t))
-	   (let ((res (resolve-search-list-aux dev ,first-only-p)))
-	     (remhash dev *rsl-circularity-check*)
-	     (if res
-		 (if (= (the fixnum pos) (the fixnum (1- len)))
-		     ,expanded-form
-		     ,concat-form)
-		 (error "Undefined search list -- ~S"
-			(subseq ,element 0 (1+ pos))))))
-	 ,already-form)))
-) ; eval-when
-
-;;; RESOLVE-SEARCH-LIST-AUX takes a device/search-list string (that is,
-;;; without the colon) and whether it should return the first expansion
-;;; found.  If dev is not defined, signal an error with the offending
-;;; search list.  If dev is defined, and first-only-p is non-nil, then just
-;;; resolve the first possible expansion.  Otherwise, we loop over all of
-;;; the possible expansions resolving each one completely, appending the
-;;; results in order as they appear in entry.  If entry is just another
-;;; search list, then append the result (res) of its expansion onto result.
-;;; If entry is a search list followed by a directory spec, then
-;;; concatenate each of the expansions of the search list with the
-;;; directory, appending this to result.  If entry is just a directory
-;;; spec, then append the list of entry to result.
-;;; 
-(defun resolve-search-list-aux (dev first-only-p)
-  (let ((entry (gethash dev *search-list-table*)))
-    (if entry
-	(if first-only-p
-	    (rsl-first (car entry))
-	    (do ((entries entry (cdr entries))
-		 (result (cons nil nil)))
-		((null entries) (cdr result))
-	      (let ((entry (car entries)))
-		(declare (simple-string entry))
-		(resolve-search-list-body
-		 nil entry (nconc result res)
-		 (nconc result (rsl-concat res (subseq entry (1+ pos) len)))
-		 (nconc result (list entry))))))
-	(error "Undefined search list -- ~S" 
-	       (concatenate 'simple-string dev ":")))))
-
-;;; RSL-FIRST takes a possible expansion and resolves it if necessary.
-;;; If first is just another search list, then return the expansions
-;;; of this search list.  If first is another search list followed by
-;;; directory spec, then concatenate each of the expansions of the
-;;; search list with the directory, returning this list.  If first is
-;;; just a directory spec, then return the list of it.
-;;; 
-(defun rsl-first (first)
-  (declare (simple-string first))
-  (resolve-search-list-body t first res
-			    (rsl-concat res (subseq first (1+ pos) len))
-			    (list first)))
-
-;;; RSL-CONCAT takes a list of expansions (prefixes) for a search list
-;;; that was concatenated with a directory spec (suffix).  Each prefix
-;;; is concatenated with the suffix and stored back where the prefix
-;;; was.  The destructively modified prefixes is returned.
-;;; 
-(defun rsl-concat (prefixes suffix)
-  (declare (simple-string suffix))
-  (do ((ptr prefixes (cdr ptr)))
-      ((null ptr) prefixes)
-    (setf (car ptr)
-	  (concatenate 'simple-string (the simple-string (car ptr)) suffix))))
diff --git a/code/seq.lisp b/code/seq.lisp
deleted file mode 100644
index 10f16043e626c49efebcd264617a9bb8b04b00ef..0000000000000000000000000000000000000000
--- a/code/seq.lisp
+++ /dev/null
@@ -1,2267 +0,0 @@
-;;; -*- Log: code.log; Package: Lisp -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; Functions to implement generic sequences for Spice Lisp.
-;;; Written by Skef Wholey.
-;;; Fixed up by Jim Muller on Friday the 13th, January, 1984.
-;;; Gone over again by Bill Chiles.  Next?
-;;;
-;;; Be careful when modifying code.  A lot of the structure of the code is
-;;; affected by the fact that compiler transforms use the lower level support
-;;; functions.  If transforms are written for some sequence operation, note
-;;; how the end argument is handled in other operations with transforms.
-
-(in-package 'lisp)
-(export '(elt subseq copy-seq coerce
-	  length reverse nreverse make-sequence concatenate map some every
-	  notany notevery reduce fill replace remove remove-if remove-if-not
-	  delete delete-if delete-if-not remove-duplicates delete-duplicates
-	  substitute substitute-if substitute-if-not nsubstitute nsubstitute-if
-	  nsubstitute-if-not find find-if find-if-not position position-if
-	  position-if-not count count-if count-if-not mismatch search
-          identity)) ; Yep, thet's whar it is.
-
-	  
-;;; Spice-Lisp specific stuff and utilities:
-	  
-(eval-when (compile)
-
-;;; Seq-Dispatch does an efficient type-dispatch on the given Sequence.
-
-(defmacro seq-dispatch (sequence list-form array-form)
-  `(if (listp ,sequence)
-       ,list-form
-       ,array-form))
-
-(defmacro elt-slice (sequences n)
-  "Returns a list of the Nth element of each of the sequences.  Used by MAP
-   and friends."
-  `(mapcar #'(lambda (seq) (elt seq ,n)) ,sequences))
-
-(defmacro make-sequence-like (sequence length)
-  "Returns a sequence of the same type as SEQUENCE and the given LENGTH."
-  `(make-sequence-of-type (type-of ,sequence) ,length))
-
-(defmacro type-specifier (type)
-  "Returns the broad class of which TYPE is a specific subclass."
-  `(if (atom ,type) ,type (car ,type)))
-
-) ; eval-when
-
-
-
-(defun make-sequence-of-type (type length)
-  "Returns a sequence of the given TYPE and LENGTH."
-  (declare (fixnum length))
-  (case (type-specifier type)
-    (list (make-list length))
-    ((bit-vector simple-bit-vector) (make-array length :element-type '(mod 2)))
-    ((string simple-string) (make-string length))
-    (simple-vector (make-array length))
-    ((array simple-array vector)
-     (if (listp type)
-	 (make-array length :element-type (cadr type))
-	 (make-array length)))
-    ((bit-vector simple-bit-vector)
-     (make-array length :element-type '(mod 2)))
-    (t (error "~S is a bad type specifier for sequence functions." type))))
-
-(defun elt (sequence index)
-  "Returns the element of SEQUENCE specified by INDEX."
-  (if (listp sequence)
-      (if (< index 0)
-	  (error "~S: index too small." index)
-	  (do ((count index (1- count)))
-	      ((= count 0) (car sequence))
-	    (declare (fixnum count))
-	    (if (atom sequence)
-		(error "~S: index too large." index)
-		(setq sequence (cdr sequence)))))
-      (aref sequence index)))
-
-(defun %setelt (sequence index newval)
-  "Store NEWVAL as the component of SEQUENCE specified by INDEX."
-  (if (listp sequence)
-      (if (< index 0)
-	  (error "~S: index too small." index)
-	  (do ((count index (1- count))
-	       (seq sequence))
-	      ((= count 0) (rplaca seq newval) sequence)
-	    (declare (fixnum count))
-	    (if (atom (cdr seq))
-		(error "~S: index too large." index)
-		(setq seq (cdr seq)))))
-      (setf (aref sequence index) newval)))
-
-(defun length (sequence)
-  "Returns an integer that is the length of SEQUENCE."
-  (%primitive length sequence))
-
-(defun list-length* (sequence)
-  (do ((count 0 (1+ count)))
-      ((atom sequence) count)
-    (declare (fixnum count))
-    (setq sequence (cdr sequence))))
-
-(defun make-sequence (type length &key (initial-element NIL iep))
-  "Returns a sequence of the given Type and Length, with elements initialized
-  to :Initial-Element."
-  (declare (fixnum length))
-  (let ((type (type-expand type)))
-    (cond ((subtypep type 'list)
-	   (make-list length :initial-element initial-element))
-	  ((subtypep type 'string)
-	   (if iep
-	       (make-string length :initial-element initial-element)
-	       (make-string length)))
-	  ((subtypep type 'simple-vector)
-	   (make-array length :initial-element initial-element))
-	  ((subtypep type 'bit-vector)
-	   (if iep
-	       (make-array length :element-type '(mod 2)
-			   :initial-element initial-element)
-	       (make-array length :element-type '(mod 2))))
-	  ((subtypep type 'vector)
-	   (if (listp type)
-	       (if iep
-		   (make-array length :element-type (cadr type)
-			       :initial-element initial-element)
-		   (make-array length :element-type (cadr type)
-			       :initial-element
-			       (if (subtypep (cadr type) 'number)
-				   0
-				   NIL)))
-	       (make-array length :initial-element initial-element)))
-	  (t (error "~S is a bad type specifier for sequences." type)))))
-
-
-
-;;; Subseq:
-;;;
-;;; The support routines for SUBSEQ are used by compiler transforms, so we
-;;; worry about dealing with end being supplied as or defaulting to nil
-;;; at this level.
-
-(defun vector-subseq* (sequence start &optional end)
-  (declare (vector sequence) (fixnum start))
-  (when (null end) (setf end (length sequence)))
-  (do ((old-index start (1+ old-index))
-       (new-index 0 (1+ new-index))
-       (copy (make-sequence-like sequence (- end start))))
-      ((= old-index end) copy)
-    (declare (fixnum old-index new-index))
-    (setf (aref copy new-index) (aref sequence old-index))))
-
-(defun list-subseq* (sequence start &optional end)
-  (declare (list sequence) (fixnum start))
-  (if (and end (>= start (the fixnum end)))
-      ()
-      (let* ((groveled (nthcdr start sequence))
-	     (result (list (car groveled))))
-	(if groveled
-	    (do ((list (cdr groveled) (cdr list))
-		 (splice result (cdr (rplacd splice (list (car list)))))
-		 (index (1+ start) (1+ index)))
-		((or (atom list) (and end (= index (the fixnum end))))
-		 result)
-	      (declare (fixnum index)))
-	    ()))))
-
-;;; SUBSEQ cannot default end to the length of sequence since it is not
-;;; an error to supply nil for its value.  We must test for end being nil
-;;; in the body of the function, and this is actually done in the support
-;;; routines for other reasons (see above).
-(defun subseq (sequence start &optional end)
-  "Returns a copy of a subsequence of SEQUENCE starting with element number 
-   START and continuing to the end of SEQUENCE or the optional END."
-  (seq-dispatch sequence
-		(list-subseq* sequence start end)
-		(vector-subseq* sequence start end)))
-
-
-;;; Copy-seq:
-
-(eval-when (compile eval)
-
-(defmacro vector-copy-seq (sequence type)
-  `(let ((length (length (the vector ,sequence))))
-     (declare (fixnum length))
-     (do ((index 0 (1+ index))
-	  (copy (make-sequence-of-type ,type length)))
-	 ((= index length) copy)
-       (declare (fixnum index))
-       (setf (aref copy index) (aref ,sequence index)))))
-
-(defmacro list-copy-seq (list)
-  `(if (atom ,list) '()
-       (let ((result (cons (car ,list) '()) ))
-	 (do ((x (cdr ,list) (cdr x))
-	      (splice result
-		      (cdr (rplacd splice (cons (car x) '() ))) ))
-	     ((atom x) (unless (null x)
-			       (rplacd splice x))
-		       result)))))
-
-)
-
-(defun copy-seq (sequence)
-  "Returns a copy of SEQUENCE which is EQUAL to SEQUENCE but not EQ."
-  (seq-dispatch sequence
-		(list-copy-seq* sequence)
-		(vector-copy-seq* sequence)))
-
-;;; Internal Frobs:
-
-(defun list-copy-seq* (sequence)
-  (list-copy-seq sequence))
-
-(defun vector-copy-seq* (sequence)
-  (vector-copy-seq sequence (type-of sequence)))
-
-
-;;; Fill:
-
-(eval-when (compile eval)
-
-(defmacro vector-fill (sequence item start end)
-  `(do ((index ,start (1+ index)))
-       ((= index (the fixnum ,end)) ,sequence)
-     (declare (fixnum index))
-     (setf (aref ,sequence index) ,item)))
-
-(defmacro list-fill (sequence item start end)
-  `(do ((current (nthcdr ,start ,sequence) (cdr current))
-	(index ,start (1+ index)))
-       ((or (atom current) (and end (= index (the fixnum ,end))))
-	sequence)
-     (declare (fixnum index))
-     (rplaca current ,item)))
-
-)
-
-;;; The support routines for FILL are used by compiler transforms, so we
-;;; worry about dealing with end being supplied as or defaulting to nil
-;;; at this level.
-
-(defun list-fill* (sequence item start end)
-  (declare (list sequence))
-  (list-fill sequence item start end))
-
-(defun vector-fill* (sequence item start end)
-  (declare (vector sequence))
-  (when (null end) (setq end (length sequence)))
-  (vector-fill sequence item start end))
-
-;;; FILL cannot default end to the length of sequence since it is not
-;;; an error to supply nil for its value.  We must test for end being nil
-;;; in the body of the function, and this is actually done in the support
-;;; routines for other reasons (see above).
-(defun fill (sequence item &key (start 0) end)
-  "Replace the specified elements of SEQUENCE with ITEM."
-  (seq-dispatch sequence
-		(list-fill* sequence item start end)
-		(vector-fill* sequence item start end)))
-
-
-
-;;; Replace:
-
-(eval-when (compile eval)
-
-;;; If we are copying around in the same vector, be careful not to copy the
-;;; same elements over repeatedly.  We do this by copying backwards.
-(defmacro mumble-replace-from-mumble ()
-  `(if (and (eq target-sequence source-sequence) (> target-start source-start))
-       (let ((nelts (min (- target-end target-start) (- source-end source-start))))
-	 (do ((target-index (+ (the fixnum target-start) (the fixnum nelts) -1)
-			    (1- target-index))
-	      (source-index (+ (the fixnum source-start) (the fixnum nelts) -1)
-			    (1- source-index)))
-	     ((= target-index (the fixnum (1- target-start))) target-sequence)
-	   (declare (fixnum target-index source-index))
-	   (setf (aref target-sequence target-index)
-		 (aref source-sequence source-index))))
-       (do ((target-index target-start (1+ target-index))
-	    (source-index source-start (1+ source-index)))
-	   ((or (= target-index (the fixnum target-end))
-		(= source-index (the fixnum source-end)))
-	    target-sequence)
-	 (declare (fixnum target-index source-index))
-	 (setf (aref target-sequence target-index)
-	       (aref source-sequence source-index)))))
-
-(defmacro list-replace-from-list ()
-  `(if (and (eq target-sequence source-sequence) (> target-start source-start))
-       (let ((new-elts (subseq source-sequence source-start
-			       (+ (the fixnum source-start)
-				  (the fixnum
-				       (min (- (the fixnum target-end)
-					       (the fixnum target-start))
-					    (- (the fixnum source-end)
-					       (the fixnum source-start))))))))
-	 (do ((n new-elts (cdr n))
-	      (o (nthcdr target-start target-sequence) (cdr o)))
-	     ((null n) target-sequence)
-	   (rplaca o (car n))))
-       (do ((target-index target-start (1+ target-index))
-	    (source-index source-start (1+ source-index))
-	    (target-sequence-ref (nthcdr target-start target-sequence)
-				 (cdr target-sequence-ref))
-	    (source-sequence-ref (nthcdr source-start source-sequence)
-				 (cdr source-sequence-ref)))
-	   ((or (= target-index (the fixnum target-end))
-		(= source-index (the fixnum source-end))
-		(null target-sequence-ref) (null source-sequence-ref))
-	    target-sequence)
-	 (declare (fixnum target-index source-index))
-	 (rplaca target-sequence-ref (car source-sequence-ref)))))
-
-(defmacro list-replace-from-mumble ()
-  `(do ((target-index target-start (1+ target-index))
-	(source-index source-start (1+ source-index))
-	(target-sequence-ref (nthcdr target-start target-sequence)
-			     (cdr target-sequence-ref)))
-       ((or (= target-index (the fixnum target-end))
-	    (= source-index (the fixnum source-end))
-	    (null target-sequence-ref))
-	target-sequence)
-     (declare (fixnum source-index target-index))
-     (rplaca target-sequence-ref (aref source-sequence source-index))))
-
-(defmacro mumble-replace-from-list ()
-  `(do ((target-index target-start (1+ target-index))
-	(source-index source-start (1+ source-index))
-	(source-sequence (nthcdr source-start source-sequence)
-			 (cdr source-sequence)))
-       ((or (= target-index (the fixnum target-end))
-	    (= source-index (the fixnum source-end))
-	    (null source-sequence))
-	target-sequence)
-     (declare (fixnum target-index source-index))
-     (setf (aref target-sequence target-index) (car source-sequence))))
-
-) ; eval-when
-
-;;; The support routines for REPLACE are used by compiler transforms, so we
-;;; worry about dealing with end being supplied as or defaulting to nil
-;;; at this level.
-
-(defun list-replace-from-list* (target-sequence source-sequence target-start
-				target-end source-start source-end)
-  (when (null target-end) (setq target-end (length target-sequence)))
-  (when (null source-end) (setq source-end (length source-sequence)))
-  (list-replace-from-list))
-
-(defun list-replace-from-vector* (target-sequence source-sequence target-start
-				  target-end source-start source-end)
-  (when (null target-end) (setq target-end (length target-sequence)))
-  (when (null source-end) (setq source-end (length source-sequence)))
-  (list-replace-from-mumble))
-
-(defun vector-replace-from-list* (target-sequence source-sequence target-start
-				  target-end source-start source-end)
-  (when (null target-end) (setq target-end (length target-sequence)))
-  (when (null source-end) (setq source-end (length source-sequence)))
-  (mumble-replace-from-list))
-
-(defun vector-replace-from-vector* (target-sequence source-sequence
-				    target-start target-end source-start
-				    source-end)
-  (when (null target-end) (setq target-end (length target-sequence)))
-  (when (null source-end) (setq source-end (length source-sequence)))
-  (mumble-replace-from-mumble))
-
-;;; REPLACE cannot default end arguments to the length of sequence since it
-;;; is not an error to supply nil for their values.  We must test for ends
-;;; being nil in the body of the function.
-(defun replace (target-sequence source-sequence &key
-	        ((:start1 target-start) 0)
-		((:end1 target-end))
-		((:start2 source-start) 0)
-		((:end2 source-end)))
-  "The target sequence is destructively modified by copying successive
-   elements into it from the source sequence."
-  (unless target-end (setq target-end (length target-sequence)))
-  (unless source-end (setq source-end (length source-sequence)))
-  (seq-dispatch target-sequence
-		(seq-dispatch source-sequence
-			      (list-replace-from-list)
-			      (list-replace-from-mumble))
-		(seq-dispatch source-sequence
-			      (mumble-replace-from-list)
-			      (mumble-replace-from-mumble))))
-
-
-;;; Reverse:
-
-(eval-when (compile eval)
-
-(defmacro vector-reverse (sequence type)
-  `(let ((length (length ,sequence)))
-     (declare (fixnum length))
-     (do ((forward-index 0 (1+ forward-index))
-	  (backward-index (1- length) (1- backward-index))
-	  (new-sequence (make-sequence-of-type ,type length)))
-	 ((= forward-index length) new-sequence)
-       (declare (fixnum forward-index backward-index))
-       (setf (aref new-sequence forward-index)
-	     (aref ,sequence backward-index)))))
-
-(defmacro list-reverse-macro (sequence)
-  `(do ((new-list ()))
-       ((atom ,sequence) new-list)
-     (push (pop ,sequence) new-list)))
-
-)
-
-(defun reverse (sequence)
-  "Returns a new sequence containing the same elements but in reverse order."
-  (seq-dispatch sequence
-		(list-reverse* sequence)
-		(vector-reverse* sequence)))
-
-;;; Internal Frobs:
-
-(defun list-reverse* (sequence)
-  (list-reverse-macro sequence))
-
-(defun vector-reverse* (sequence)
-  (vector-reverse sequence (type-of sequence)))
-
-
-;;; Nreverse:
-
-(eval-when (compile eval)
-
-(defmacro vector-nreverse (sequence)
-  `(let ((length (length (the vector ,sequence))))
-     (declare (fixnum length))
-     (do ((left-index 0 (1+ left-index))
-	  (right-index (1- length) (1- right-index))
-	  (half-length (truncate length 2)))
-	 ((= left-index half-length) ,sequence)
-       (declare (fixnum left-index right-index half-length))
-       (rotatef (aref ,sequence left-index)
-		(aref ,sequence right-index)))))
-
-(defmacro list-nreverse-macro (list)
-  `(do ((1st (cdr ,list) (if (atom 1st) 1st (cdr 1st)))
-	(2nd ,list 1st)
-	(3rd '() 2nd))
-       ((atom 2nd) 3rd)
-     (rplacd 2nd 3rd)))
-
-)
-
-
-(defun list-nreverse* (sequence)
-  (list-nreverse-macro sequence))
-
-(defun vector-nreverse* (sequence)
-  (vector-nreverse sequence))
-
-(defun nreverse (sequence)
-  "Returns a sequence of the same elements in reverse order; the argument
-   is destroyed."
-  (seq-dispatch sequence
-		(list-nreverse* sequence)
-		(vector-nreverse* sequence)))
-
-
-;;; Concatenate:
-
-(eval-when (compile eval)
-
-(defmacro concatenate-to-list (sequences)
-  `(let ((result (list nil)))
-     (do ((sequences ,sequences (cdr sequences))
-	  (splice result))
-	 ((null sequences) (cdr result))
-       (let ((sequence (car sequences)))
-	 (seq-dispatch sequence
-		       (do ((sequence sequence (cdr sequence)))
-			   ((atom sequence))
-			 (setq splice
-			       (cdr (rplacd splice (list (car sequence))))))
-		       (do ((index 0 (1+ index))
-			    (length (length sequence)))
-			   ((= index length))
-			 (declare (fixnum index length))
-			 (setq splice
-			       (cdr (rplacd splice
-					    (list (aref sequence index)))))))))))
-
-(defmacro concatenate-to-mumble (output-type-spec sequences)
-  `(do ((seqs ,sequences (cdr seqs))
-	(total-length 0)
-	(lengths ()))
-       ((null seqs)
-	(do ((sequences ,sequences (cdr sequences))
-	     (lengths lengths (cdr lengths))
-	     (index 0)
-	     (result (make-sequence-of-type ,output-type-spec total-length)))
-	    ((= index total-length) result)
-	  (declare (fixnum index))
-	  (let ((sequence (car sequences)))
-	    (seq-dispatch sequence
-			  (do ((sequence sequence (cdr sequence)))
-			      ((atom sequence))
-			    (setf (aref result index) (car sequence))
-			    (setq index (1+ index)))
-			  (do ((jndex 0 (1+ jndex))
-			       (this-length (car lengths)))
-			      ((= jndex this-length))
-			    (declare (fixnum jndex this-length))
-			    (setf (aref result index)
-				  (aref sequence jndex))
-			    (setq index (1+ index)))))))
-     (let ((length (length (car seqs))))
-       (declare (fixnum length))
-       (setq lengths (nconc lengths (list length)))
-       (setq total-length (+ total-length length)))))
-
-)
-
-(defun concatenate (output-type-spec &rest sequences)
-  "Returns a new sequence of all the argument sequences concatenated together
-   which shares no structure with the original argument sequences of the
-   specified OUTPUT-TYPE-SPEC."
-  (case (type-specifier output-type-spec)
-    (list (apply #'concat-to-list* sequences))
-    ((simple-vector simple-string vector string array simple-array
-		    bit-vector simple-bit-vector)
-     (apply #'concat-to-simple* output-type-spec sequences))
-    (t (error "~S: invalid output type specification." output-type-spec))))
-
-;;; Internal Frobs:
-
-(defun concat-to-list* (&rest sequences)
-  (concatenate-to-list sequences))
-
-(defun concat-to-simple* (type &rest sequences)
-  (concatenate-to-mumble type sequences))
-
-
-;;; Map:
-
-(eval-when (compile eval)
-
-(defmacro map-to-list (function sequences)
-  `(do ((seqs more-sequences (cdr seqs))
-	(min-length (length first-sequence)))
-       ((null seqs)
-	(let ((result (list nil)))
-	  (do ((index 0 (1+ index))
-	       (splice result))
-	      ((= index min-length) (cdr result))
-	    (declare (fixnum index))
-	    (setq splice
-		  (cdr (rplacd splice
-			       (list (apply ,function (elt-slice ,sequences
-								 index)))))))))
-     (declare (fixnum min-length))
-     (let ((length (length (car seqs))))
-       (declare (fixnum length))
-       (if (< length min-length)
-	   (setq min-length length)))))
-
-(defmacro map-to-simple (output-type-spec function sequences)
-  `(do ((seqs more-sequences (cdr seqs))
-	(min-length (length first-sequence)))
-       ((null seqs)
-	(do ((index 0 (1+ index))
-	     (result (make-sequence-of-type ,output-type-spec min-length)))
-	    ((= index min-length) result)
-	  (declare (fixnum index))
-	  (setf (aref result index)
-		(apply ,function (elt-slice ,sequences index)))))
-     (declare (fixnum min-length))
-     (let ((length (length (car seqs))))
-       (declare (fixnum length))
-       (if (< length min-length)
-	   (setq min-length length)))))
-
-(defmacro map-for-effect (function sequences)
-  `(do ((seqs more-sequences (cdr seqs))
-	(min-length (length first-sequence)))
-       ((null seqs)
-	(do ((index 0 (1+ index)))
-	    ((= index min-length) nil)
-	  (apply ,function (elt-slice ,sequences index))))
-     (declare (fixnum min-length))
-     (let ((length (length (car seqs))))
-       (declare (fixnum length))
-       (if (< length min-length)
-	   (setq min-length length)))))
-
-
-)
-
-(defun map (output-type-spec function first-sequence &rest more-sequences)
-  "FUNCTION must take as many arguments as there are sequences provided.  The 
-   result is a sequence such that element i is the result of applying FUNCTION
-   to element i of each of the argument sequences."
-  (let ((sequences (cons first-sequence more-sequences)))
-    (case (type-specifier output-type-spec)
-      ((nil) (map-for-effect function sequences))
-      (list (map-to-list function sequences))
-      ((simple-vector simple-string vector string array simple-array
-		    bit-vector simple-bit-vector)
-       (map-to-simple output-type-spec function sequences))
-      (t (error "~S: invalid output type specifier." output-type-spec)))))
-
-
-;;; Quantifiers:
-
-(eval-when (compile eval)
-(defmacro defquantifier (name doc-string every-result abort-sense abort-value)
-  `(defun ,name (predicate first-sequence &rest more-sequences)
-     ,doc-string
-     (do ((seqs more-sequences (cdr seqs))
-	  (length (length first-sequence))
-	  (sequences (cons first-sequence more-sequences)))
-	 ((null seqs)
-	  (do ((index 0 (1+ index)))
-	      ((= index length) ,every-result)
-	    (declare (fixnum index))
-	    (let ((result (apply predicate (elt-slice sequences index))))
-	      (if ,(if abort-sense 'result '(not result))
-		  (return ,abort-value)))))
-       (declare (fixnum length))
-       (let ((this (length (car seqs))))
-	 (declare (fixnum this))
-	 (if (< this length) (setq length this))))))
-) ; eval-when
-
-(defquantifier some
-  "PREDICATE is applied to the elements with index 0 of the sequences, then 
-   possibly to those with index 1, and so on.  SOME returns the first 
-   non-() value encountered, or () if the end of a sequence is reached."
-  nil t result)
-
-(defquantifier every
-  "PREDICATE is applied to the elements with index 0 of the sequences, then
-   possibly to those with index 1, and so on.  EVERY returns () as soon
-   as any invocation of PREDICATE returns (), or T if every invocation
-   is non-()."
-  t nil nil)
-
-(defquantifier notany
-  "PREDICATE is applied to the elements with index 0 of the sequences, then 
-   possibly to those with index 1, and so on.  NOTANY returns () as soon
-   as any invocation of PREDICATE returns a non-() value, or T if the end
-   of a sequence is reached."
-  t t nil)
-
-(defquantifier notevery
-  "PREDICATE is applied to the elements with index 0 of the sequences, then
-   possibly to those with index 1, and so on.  NOTEVERY returns T as soon
-   as any invocation of PREDICATE returns (), or () if every invocation
-   is non-()."
-  nil nil t)
-
-
-
-;;; Reduce:
-
-(eval-when (compile eval)
-
-(defmacro mumble-reduce (function sequence start end initial-value ref)
-  `(do ((index ,start (1+ index))
-	(value ,initial-value))
-       ((= index (the fixnum ,end)) value)
-     (declare (fixnum index))
-     (setq value (funcall ,function value (,ref ,sequence index)))))
-
-(defmacro mumble-reduce-from-end (function sequence start end initial-value ref)
-  `(do ((index (1- ,end) (1- index))
-	(value ,initial-value)
-	(terminus (1- ,start)))
-       ((= index terminus) value)
-     (declare (fixnum index terminus))
-     (setq value (funcall ,function (,ref ,sequence index) value))))
-
-(defmacro list-reduce (function sequence start end initial-value ivp)
-  `(let ((sequence (nthcdr ,start ,sequence)))
-     (do ((count (if ,ivp ,start (1+ (the fixnum ,start)))
-		 (1+ count))
-	  (sequence (if ,ivp sequence (cdr sequence))
-		    (cdr sequence))
-	  (value (if ,ivp ,initial-value (car sequence))
-		 (funcall ,function value (car sequence))))
-	 ((= count (the fixnum ,end)) value)
-       (declare (fixnum count)))))
-
-(defmacro list-reduce-from-end (function sequence start end initial-value ivp)
-  `(let ((sequence (nthcdr (- (the fixnum (length ,sequence)) (the fixnum ,end))
-			   (reverse ,sequence))))
-     (do ((count (if ,ivp ,start (1+ (the fixnum ,start)))
-		 (1+ count))
-	  (sequence (if ,ivp sequence (cdr sequence))
-		    (cdr sequence))
-	  (value (if ,ivp ,initial-value (car sequence))
-		 (funcall ,function (car sequence) value)))
-	 ((= count (the fixnum ,end)) value)
-       (declare (fixnum count)))))
-
-)
-
-(defun reduce (function sequence &key from-end (start 0)
-			end (initial-value nil ivp))
-  "The specified Sequence is ``reduced'' using the given Function.
-  See manual for details."
-  (declare (fixnum start))
-  (when (null end) (setf end (length sequence)))
-  (cond ((= (the fixnum end) start)
-	 (if ivp initial-value (funcall function)))
-	((listp sequence)
-	 (if from-end
-	     (list-reduce-from-end function sequence start end initial-value ivp)
-	     (list-reduce function sequence start end initial-value ivp)))
-	(from-end
-	 (when (not ivp)
-	   (setq end (1- (the fixnum end)))
-	   (setq initial-value (aref sequence end)))
-	 (mumble-reduce-from-end function sequence start end initial-value aref))
-	(t
-	 (when (not ivp)
-	   (setq initial-value (aref sequence start))
-	   (setq start (1+ start)))
-	 (mumble-reduce function sequence start end initial-value aref))))
-
-
-;;; Coerce:
-
-(defun coerce (object output-type-spec)
-  "Coerces the Object to an object of type Output-Type-Spec."
-  (cond
-   ((typep object output-type-spec)
-    object)
-   ((eq output-type-spec 'character)
-    (character object))
-   ((eq output-type-spec 'function)
-    (eval `#',object))
-   ((numberp object)
-    (case output-type-spec
-      (short-float (%primitive float-short object))
-      ((single-float float) (%primitive float-single object))
-      ((double-float long-float) (%primitive float-long object))
-      (complex
-       (complex object))
-      (t
-       (error "~S can't be converted to type ~S." object output-type-spec))))
-   (t
-    (typecase object
-      (list
-       (case (type-specifier output-type-spec)
-	 ((simple-string string) (list-to-string* object))
-	 ((simple-bit-vector bit-vector) (list-to-bit-vector* object))
-	 ((simple-vector vector array simple-array)
-	  (list-to-vector* object output-type-spec))
-	 (t (error "Can't coerce ~S to type ~S." object output-type-spec))))
-      (simple-string
-       (case (type-specifier output-type-spec)
-	 (list (vector-to-list* object))
-	 ;; Can't coerce a string to a bit-vector!
-	 ((simple-vector vector array simple-array)
-	  (vector-to-vector* object output-type-spec))
-	 (t (error "Can't coerce ~S to type ~S." object output-type-spec))))
-      (simple-bit-vector
-       (case (type-specifier output-type-spec)
-	 (list (vector-to-list* object))
-	 ;; Can't coerce a bit-vector to a string!
-	 ((simple-vector vector array simple-array)
-	  (vector-to-vector* object output-type-spec))
-	 (t (error "Can't coerce ~S to type ~S." object output-type-spec))))
-      (simple-vector
-       (case (type-specifier output-type-spec)
-	 (list (vector-to-list* object))
-	 ((simple-string string) (vector-to-string* object))
-	 ((simple-bit-vector bit-vector) (vector-to-bit-vector* object))
-	 ((vector array simple-array) (vector-to-vector* object output-type-spec))
-	 (t (error "Can't coerce ~S to type ~S." object output-type-spec))))
-      (string
-       (case (type-specifier output-type-spec)
-	 (list (vector-to-list* object))
-	 (simple-string (string-to-simple-string* object))
-	 ;; Can't coerce a string to a bit-vector!
-	 ((simple-vector vector simple-array array)
-	  (vector-to-vector* object output-type-spec))
-	 (t (error "Can't coerce ~S to type ~S." object output-type-spec))))
-      (bit-vector
-       (case (type-specifier output-type-spec)
-	 (list (vector-to-list* object))
-	 ;; Can't coerce a bit-vector to a string!
-	 (simple-bit-vector (bit-vector-to-simple-bit-vector* object))
-	 ((simple-vector vector array simple-array)
-	  (vector-to-vector* object output-type-spec))
-	 (t (error "Can't coerce ~S to type ~S." object output-type-spec))))
-      (vector
-       (case (type-specifier output-type-spec)
-	 (list (vector-to-list* object))
-	 ((simple-string string) (vector-to-string* object))
-	 ((simple-bit-vector bit-vector) (vector-to-bit-vector* object))
-	 ((simple-vector vector array simple-array)
-	  (vector-to-vector* object output-type-spec))
-	 (t (error "Can't coerce ~S to type ~S." object output-type-spec))))
-      (t (error "~S is an inappropriate type of object for coerce." object))))))
-
-
-;;; Internal Frobs:
-
-(macrolet ((frob (name result access src-type &optional typep)
-		 `(defun ,name (object ,@(if typep '(type) ()))
-		    (do* ((index 0 (1+ index))
-			  (length (,(case src-type
-				      (:list 'list-length*)
-				      (:vector 'length))
-				   object))
-			  (result ,result))
-			 ((= index length) result)
-		      (declare (fixnum length index))
-		      (setf (,access result index)
-			    ,(case src-type
-			       (:list '(pop object))
-			       (:vector '(aref object index))))))))
-
-  (frob list-to-string* (make-string length) schar :list)
-
-  (frob list-to-bit-vector* (make-array length :element-type '(mod 2))
-	sbit :list)
-
-  (frob list-to-vector* (make-sequence-of-type type length)
-	aref :list t)
-
-  (frob vector-to-vector* (make-sequence-of-type type length)
-	aref :vector t)
-
-  (frob vector-to-string* (make-string length) schar :vector)
-
-  (frob vector-to-bit-vector* (make-array length :element-type '(mod 2))
-	sbit :vector))
-
-(defun vector-to-list* (object)
-  (let ((result (list nil))
-	(length (length object)))
-    (declare (fixnum length))
-    (do ((index 0 (1+ index))
-	 (splice result (cdr splice)))
-	((= index length) (cdr result))
-      (declare (fixnum index))
-      (rplacd splice (list (aref object index))))))
-
-(defun string-to-simple-string* (object)
-  (if (simple-string-p object)
-      object
-      (with-array-data ((data object)
-			(start)
-			(end (%primitive header-ref object
-					 %array-fill-pointer-slot)))
-	(declare (simple-string data))
-	(subseq data start end))))
-
-(defun bit-vector-to-simple-bit-vector* (object)
-  (if (simple-bit-vector-p object)
-      object
-      (with-array-data ((data object)
-			(start)
-			(end (%primitive header-ref object
-					 %array-fill-pointer-slot)))
-	(declare (simple-bit-vector data))
-	(subseq data start end))))
-
-
-;;; Delete:
-
-(eval-when (compile eval)
-
-(defmacro mumble-delete (pred)
-  `(do ((index start (1+ index))
-	(jndex start)
-	(number-zapped 0))
-       ((or (= index (the fixnum end)) (= number-zapped (the fixnum count)))
-	(do ((index index (1+ index))		; copy the rest of the vector
-	     (jndex jndex (1+ jndex)))
-	    ((= index (the fixnum length))
-	     (shrink-vector sequence jndex))
-	  (declare (fixnum index jndex))
-	  (setf (aref sequence jndex) (aref sequence index))))
-     (declare (fixnum index jndex number-zapped))
-     (setf (aref sequence jndex) (aref sequence index))
-     (if ,pred
-	 (setq number-zapped (1+ number-zapped))
-	 (setq jndex (1+ jndex)))))
-
-(defmacro mumble-delete-from-end (pred)
-  `(do ((index (1- (the fixnum end)) (1- index)) ; find the losers
-	(number-zapped 0)
-	(losers ())
-        this-element
-	(terminus (1- start)))
-       ((or (= index terminus) (= number-zapped (the fixnum count)))
-	(do ((losers losers)			 ; delete the losers
-	     (index start (1+ index))
-	     (jndex start))
-	    ((or (null losers) (= index (the fixnum end)))
-	     (do ((index index (1+ index))	 ; copy the rest of the vector
-		  (jndex jndex (1+ jndex)))
-		 ((= index (the fixnum length))
-		  (shrink-vector sequence jndex))
-	       (declare (fixnum index jndex))
-	       (setf (aref sequence jndex) (aref sequence index))))
-	  (declare (fixnum index jndex))
-	  (setf (aref sequence jndex) (aref sequence index))
-	  (if (= index (the fixnum (car losers)))
-	      (pop losers)
-	      (setq jndex (1+ jndex)))))
-     (declare (fixnum index number-zapped terminus))
-     (setq this-element (aref sequence index))
-     (when ,pred
-       (setq number-zapped (1+ number-zapped))
-       (push index losers))))
-
-(defmacro normal-mumble-delete ()
-  `(mumble-delete
-    (if test-not
-	(not (funcall test-not item (apply-key key (aref sequence index))))
-	(funcall test item (apply-key key (aref sequence index))))))
-
-(defmacro normal-mumble-delete-from-end ()
-  `(mumble-delete-from-end
-    (if test-not
-	(not (funcall test-not item (apply-key key this-element)))
-	(funcall test item (apply-key key this-element)))))
-
-(defmacro list-delete (pred)
-  `(let ((handle (cons nil sequence)))
-     (do ((current (nthcdr start sequence) (cdr current))
-	  (previous (nthcdr start handle))
-	  (index start (1+ index))
-	  (number-zapped 0))
-	 ((or (= index (the fixnum end)) (= number-zapped (the fixnum count)))
-	  (cdr handle))
-       (declare (fixnum index number-zapped))
-       (cond (,pred
-	      (rplacd previous (cdr current))
-	      (setq number-zapped (1+ number-zapped)))
-	     (t
-	      (setq previous (cdr previous)))))))
-
-(defmacro list-delete-from-end (pred)
-  `(let* ((reverse (nreverse (the list sequence)))
-	  (handle (cons nil reverse)))
-     (do ((current (nthcdr (- (the fixnum length) (the fixnum end)) reverse)
-		   (cdr current))
-	  (previous (nthcdr (- (the fixnum length) (the fixnum end)) handle))
-	  (index start (1+ index))
-	  (number-zapped 0))
-	 ((or (= index (the fixnum end)) (= number-zapped (the fixnum count)))
-	  (nreverse (cdr handle)))
-       (declare (fixnum index number-zapped))
-       (cond (,pred
-	      (rplacd previous (cdr current))
-	      (setq number-zapped (1+ number-zapped)))
-	     (t
-	      (setq previous (cdr previous)))))))
-
-(defmacro normal-list-delete ()
-  '(list-delete
-    (if test-not
-	(not (funcall test-not item (apply-key key (car current))))
-	(funcall test item (apply-key key (car current))))))
-
-(defmacro normal-list-delete-from-end ()
-  '(list-delete-from-end
-    (if test-not
-	(not (funcall test-not item (apply-key key (car current))))
-	(funcall test item (apply-key key (car current))))))
-)
-
-(defun delete (item sequence &key from-end (test #'eql) test-not (start 0)
-		end (count most-positive-fixnum) key)
-  "Returns a sequence formed by destructively removing the specified Item from
-  the given Sequence."
-  (declare (fixnum start count))
-  (when (null end) (setf end (length sequence)))
-  (let ((length (length sequence)))
-    (declare (fixnum length))
-    (seq-dispatch sequence
-		  (if from-end
-		      (normal-list-delete-from-end)
-		      (normal-list-delete))
-		  (if from-end
-		      (normal-mumble-delete-from-end)
-		      (normal-mumble-delete)))))
-
-(eval-when (compile eval)
-
-(defmacro if-mumble-delete ()
-  `(mumble-delete
-    (funcall predicate (apply-key key (aref sequence index)))))
-
-(defmacro if-mumble-delete-from-end ()
-  `(mumble-delete-from-end
-    (funcall predicate (apply-key key this-element))))
-
-(defmacro if-list-delete ()
-  '(list-delete
-    (funcall predicate (apply-key key (car current)))))
-
-(defmacro if-list-delete-from-end ()
-  '(list-delete-from-end
-    (funcall predicate (apply-key key (car current)))))
-
-)
-
-(defun delete-if (predicate sequence &key from-end (start 0) key
-			    end (count most-positive-fixnum))
-  "Returns a sequence formed by destructively removing the elements satisfying
-  the specified Predicate from the given Sequence."
-  (declare (fixnum start count))
-  (when (null end) (setf end (length sequence)))
-  (let ((length (length sequence)))
-    (declare (fixnum length))
-    (seq-dispatch sequence
-		  (if from-end
-		      (if-list-delete-from-end)
-		      (if-list-delete))
-		  (if from-end
-		      (if-mumble-delete-from-end)
-		      (if-mumble-delete)))))
-
-(eval-when (compile eval)
-
-(defmacro if-not-mumble-delete ()
-  `(mumble-delete
-    (not (funcall predicate (apply-key key (aref sequence index))))))
-
-(defmacro if-not-mumble-delete-from-end ()
-  `(mumble-delete-from-end
-    (not (funcall predicate (apply-key key this-element)))))
-
-(defmacro if-not-list-delete ()
-  '(list-delete
-    (not (funcall predicate (apply-key key (car current))))))
-
-(defmacro if-not-list-delete-from-end ()
-  '(list-delete-from-end
-    (not (funcall predicate (apply-key key (car current))))))
-
-)
-
-(defun delete-if-not (predicate sequence &key from-end (start 0) 
-			end key (count most-positive-fixnum))
-  "Returns a sequence formed by destructively removing the elements not
-  satisfying the specified Predicate from the given Sequence."
-  (declare (fixnum start count))
-  (when (null end) (setf end (length sequence)))
-  (let ((length (length sequence)))
-    (declare (fixnum length))
-    (seq-dispatch sequence
-		  (if from-end
-		      (if-not-list-delete-from-end)
-		      (if-not-list-delete))
-		  (if from-end
-		      (if-not-mumble-delete-from-end)
-		      (if-not-mumble-delete)))))
-
-
-;;; Remove:
-
-(eval-when (compile eval)
-
-;;; MUMBLE-REMOVE-MACRO does not include (removes) each element that
-;;; satisfies the predicate.
-(defmacro mumble-remove-macro (bump left begin finish right pred)
-  `(do ((index ,begin (,bump index))
-	(result
-	 (do ((index ,left (,bump index))
-	      (result (make-sequence-like sequence length)))
-	     ((= index (the fixnum ,begin)) result)
-	   (declare (fixnum index))
-	   (setf (aref result index) (aref sequence index))))
-	(new-index ,begin)
-	(number-zapped 0)
-	(this-element))
-       ((or (= index (the fixnum ,finish)) (= number-zapped (the fixnum count)))
-	(do ((index index (,bump index))
-	     (new-index new-index (,bump new-index)))
-	    ((= index (the fixnum ,right)) (shrink-vector result new-index))
-	  (declare (fixnum index new-index))
-	  (setf (aref result new-index) (aref sequence index))))
-     (declare (fixnum index new-index number-zapped))
-     (setq this-element (aref sequence index))
-     (cond (,pred (setq number-zapped (1+ number-zapped)))
-	   (t (setf (aref result new-index) this-element)
-	      (setq new-index (,bump new-index))))))
-
-(defmacro mumble-remove (pred)
-  `(mumble-remove-macro 1+ 0 start end length ,pred))
-
-(defmacro mumble-remove-from-end (pred)
-  `(let ((sequence (copy-seq sequence)))
-     (mumble-delete-from-end ,pred)))
-
-(defmacro normal-mumble-remove ()
-  `(mumble-remove 
-    (if test-not
-	(not (funcall test-not item (apply-key key this-element)))
-	(funcall test item (apply-key key this-element)))))
-
-(defmacro normal-mumble-remove-from-end ()
-  `(mumble-remove-from-end 
-    (if test-not
-	(not (funcall test-not item (apply-key key this-element)))
-	(funcall test item (apply-key key this-element)))))
-
-(defmacro if-mumble-remove ()
-  `(mumble-remove (funcall predicate (apply-key key this-element))))
-
-(defmacro if-mumble-remove-from-end ()
-  `(mumble-remove-from-end (funcall predicate (apply-key key this-element))))
-
-(defmacro if-not-mumble-remove ()
-  `(mumble-remove (not (funcall predicate (apply-key key this-element)))))
-
-(defmacro if-not-mumble-remove-from-end ()
-  `(mumble-remove-from-end
-    (not (funcall predicate (apply-key key this-element)))))
-
-;;; LIST-REMOVE-MACRO does not include (removes) each element that satisfies
-;;; the predicate.
-(defmacro list-remove-macro (pred reverse?)
-  `(let* (,@(if reverse? '((sequence (reverse (the list sequence)))))
-	  (splice (list nil))
-	  (results (do ((index 0 (1+ index))
-			(before-start splice))
-		       ((= index (the fixnum start)) before-start)
-		     (declare (fixnum index))
-		     (setq splice
-			   (cdr (rplacd splice (list (pop sequence))))))))
-     (do ((index start (1+ index))
-	  (this-element)
-	  (number-zapped 0))
-	 ((or (= index (the fixnum end)) (= number-zapped (the fixnum count)))
-	  (do ((index index (1+ index)))
-	      ((null sequence)
-	       ,(if reverse?
-		    '(nreverse (the list (cdr results)))
-		    '(cdr results)))
-	    (declare (fixnum index))
-	    (setq splice (cdr (rplacd splice (list (pop sequence)))))))
-       (declare (fixnum index number-zapped))
-       (setq this-element (pop sequence))
-       (if ,pred
-	   (setq number-zapped (1+ number-zapped))
-	   (setq splice (cdr (rplacd splice (list this-element))))))))
-
-(defmacro list-remove (pred)
-  `(list-remove-macro ,pred nil))
-
-(defmacro list-remove-from-end (pred)
-  `(list-remove-macro ,pred t))
-
-(defmacro normal-list-remove ()
-  `(list-remove
-    (if test-not
-	(not (funcall test-not item (apply-key key this-element)))
-	(funcall test item (apply-key key this-element)))))
-
-(defmacro normal-list-remove-from-end ()
-  `(list-remove-from-end
-    (if test-not
-	(not (funcall test-not item (apply-key key this-element)))
-	(funcall test item (apply-key key this-element)))))
-
-(defmacro if-list-remove ()
-  `(list-remove
-    (funcall predicate (apply-key key this-element))))
-
-(defmacro if-list-remove-from-end ()
-  `(list-remove-from-end
-    (funcall predicate (apply-key key this-element))))
-
-(defmacro if-not-list-remove ()
-  `(list-remove
-    (not (funcall predicate (apply-key key this-element)))))
-
-(defmacro if-not-list-remove-from-end ()
-  `(list-remove-from-end
-    (not (funcall predicate (apply-key key this-element)))))
-
-)
-
-(defun remove (item sequence &key from-end (test #'eql) test-not (start 0)
-		end (count most-positive-fixnum) key)
-  "Returns a copy of SEQUENCE with elements satisfying the test (default is
-   EQL) with ITEM removed."
-  (declare (fixnum start count))
-  (when (null end) (setf end (length sequence)))
-  (let ((length (length sequence)))
-    (declare (fixnum length))
-    (seq-dispatch sequence
-		  (if from-end
-		      (normal-list-remove-from-end)
-		      (normal-list-remove))
-		  (if from-end
-		      (normal-mumble-remove-from-end)
-		      (normal-mumble-remove)))))
-
-(defun remove-if (predicate sequence &key from-end (start 0)
-		    end (count most-positive-fixnum) key)
-  "Returns a copy of sequence with elements such that predicate(element)
-   is non-null are removed"
-  (declare (fixnum start count))
-  (when (null end) (setf end (length sequence)))
-  (let ((length (length sequence)))
-    (declare (fixnum length))
-    (seq-dispatch sequence
-		  (if from-end
-		      (if-list-remove-from-end)
-		      (if-list-remove))
-		  (if from-end
-		      (if-mumble-remove-from-end)
-		      (if-mumble-remove)))))
-
-(defun remove-if-not (predicate sequence &key
-				from-end (start 0) end
-				(count most-positive-fixnum) key)
-  "Returns a copy of sequence with elements such that predicate(element)
-   is null are removed"
-  (declare (fixnum start count))
-  (when (null end) (setf end (length sequence)))
-  (let ((length (length sequence)))
-    (declare (fixnum length))
-    (seq-dispatch sequence
-		  (if from-end
-		      (if-not-list-remove-from-end)
-		      (if-not-list-remove))
-		  (if from-end
-		      (if-not-mumble-remove-from-end)
-		      (if-not-mumble-remove)))))
-
-
-;;; Remove-Duplicates:
-     
-;;; Remove duplicates from a list. If from-end, remove the later duplicates,
-;;; not the earlier ones. Thus if we check from-end we don't copy an item
-;;; if we look into the already copied structure (from after :start) and see
-;;; the item. If we check from beginning we check into the rest of the 
-;;; original list up to the :end marker (this we have to do by running a
-;;; do loop down the list that far and using our test.
-(defun list-remove-duplicates* (list test test-not start end key from-end)
-  (declare (fixnum start))
-  (let* ((result (list ())) ; Put a marker on the beginning to splice with.
-	 (splice result)
-	 (current list))
-    (do ((index 0 (1+ index)))
-	((= index start))
-      (declare (fixnum index))
-      (setq splice (cdr (rplacd splice (list (car current)))))
-      (setq current (cdr current)))
-    (do ((index 0 (1+ index)))
-	((or (and end (= index (the fixnum end)))
-	     (atom current)))
-      (declare (fixnum index))
-      (if (or (and from-end 
-	           (not (member (apply-key key (car current))
-				(nthcdr start result)
-				:test test
-				:test-not test-not
-				:key (if key key #'identity))))
-	      (and (not from-end)
-		   (not (do ((it (apply-key key (car current)))
-			     (l (cdr current) (cdr l))
-			     (i (1+ index) (1+ i)))
-			    ((or (atom l) (and end (= i (the fixnum end))))
-			     ())
-			  (declare (fixnum i))
-			  (if (if test-not
-				  (not (funcall test-not (apply-key key (car l)) it))
-				  (funcall test (apply-key key (car l)) it))
-			      (return t))))))
-	  (setq splice (cdr (rplacd splice (list (car current))))))
-      (setq current (cdr current)))
-    (do ()
-	((atom current))
-      (setq splice (cdr (rplacd splice (list (car current)))))
-      (setq current (cdr current)))
-    (cdr result)))
-
-
-
-(defun vector-remove-duplicates* (vector test test-not start end key from-end
-					 &optional (length (length vector)))
-  (declare (vector vector) (fixnum start length))
-  (when (null end) (setf end (length vector)))
-  (let ((result (make-sequence-like vector length))
-	(index 0)
-	(jndex start))
-    (declare (fixnum index jndex))
-    (do ()
-	((= index start))
-      (setf (aref result index) (aref vector index))
-      (setq index (1+ index)))
-    (do ((elt))
-	((= index end))
-      (setq elt (aref vector index))
-      (unless (or (and from-end
-		        (position (apply-key key elt) result :start start
-			   :end jndex :test test :test-not test-not :key key))
-		  (and (not from-end)
-		        (position (apply-key key elt) vector :start (1+ index)
-			   :end end :test test :test-not test-not :key key)))
-	(setf (aref result jndex) elt)
-	(setq jndex (1+ jndex)))
-      (setq index (1+ index)))
-    (do ()
-	((= index length))
-      (setf (aref result jndex) (aref vector index))
-      (setq index (1+ index))
-      (setq jndex (1+ jndex)))
-    (shrink-vector result jndex)))
-
-
-(defun remove-duplicates (sequence &key (test #'eql) test-not (start 0) from-end
-				   end key)
-  "The elements of Sequence are examined, and if any two match, one is
-   discarded.  The resulting sequence is returned."
-  (declare (fixnum start))
-  (seq-dispatch sequence
-		(if sequence
-		    (list-remove-duplicates* sequence test test-not
-					      start end key from-end))
-		(vector-remove-duplicates* sequence test test-not
-					    start end key from-end)))
-
-
-
-;;; Delete-Duplicates:
-
-
-(defun list-delete-duplicates* (list test test-not key from-end start end)
-  (declare (fixnum start))
-  (let ((handle (cons nil list)))
-    (do ((current (nthcdr start list) (cdr current))
-	 (previous (nthcdr start handle))
-	 (index start (1+ index)))
-	((or (and end (= index (the fixnum end))) (null current))
-	 (cdr handle))
-      (declare (fixnum index))
-      (if (do ((x (if from-end 
-		      (nthcdr (1+ start) handle)
-		      (cdr current))
-		  (cdr x))
-	       (i (1+ index) (1+ i)))
-	      ((or (null x)
-		   (and (not from-end) end (= i (the fixnum end)))
-		   (eq x current))
-	       nil)
-	    (declare (fixnum i))
-	    (if (if test-not
-		    (not (funcall test-not 
-				  (apply-key key (car current))
-				  (apply-key key (car x))))
-		    (funcall test 
-			     (apply-key key (car current)) 
-			     (apply-key key (car x))))
-		(return t)))
-	  (rplacd previous (cdr current))
-	  (setq previous (cdr previous))))))
-
-
-(defun vector-delete-duplicates* (vector test test-not key from-end start end 
-					 &optional (length (length vector)))
-  (declare (vector vector) (fixnum start length))
-  (when (null end) (setf end (length vector)))
-  (do ((index start (1+ index))
-       (jndex start))
-      ((= index end)
-       (do ((index index (1+ index))		; copy the rest of the vector
-	    (jndex jndex (1+ jndex)))
-	   ((= index length)
-	    (shrink-vector vector jndex)
-	    vector)
-	 (setf (aref vector jndex) (aref vector index))))
-    (declare (fixnum index jndex))
-    (setf (aref vector jndex) (aref vector index))
-    (unless (position (apply-key key (aref vector index)) vector :key key
-		      :start (if from-end start (1+ index)) :test test
-		      :end (if from-end jndex end) :test-not test-not)
-      (setq jndex (1+ jndex)))))
-
-
-(defun delete-duplicates (sequence &key (test #'eql) test-not (start 0) from-end
-			    end key)
-  "The elements of Sequence are examined, and if any two match, one is
-   discarded.  The resulting sequence, which may be formed by destroying the
-   given sequence, is returned."
-  (seq-dispatch sequence
-    (if sequence
-	(list-delete-duplicates* sequence test test-not key from-end start end))
-  (vector-delete-duplicates* sequence test test-not key from-end start end)))
-
-(defun list-substitute* (pred new list start end count key test test-not old)
-  (declare (fixnum start end count))
-  (let* ((result (list nil))
-	 elt
-	 (splice result)
-	 (list list))           ; Get a local list for a stepper.
-    (do ((index 0 (1+ index)))
-	((= index start))
-      (declare (fixnum index))
-      (setq splice (cdr (rplacd splice (list (car list)))))
-      (setq list (cdr list)))
-    (do ((index start (1+ index)))
-	((or (= index end) (null list) (= count 0)))
-      (declare (fixnum index))
-      (setq elt (car list))
-      (setq splice
-	    (cdr (rplacd splice
-			 (list
-			  (cond
-			   ((case pred
-				   (normal
-				    (if test-not
-					(not 
-					 (funcall test-not (apply-key key elt) old))
-					(funcall test (apply-key key elt) old)))
-				   (if (funcall test (apply-key key elt)))
-				   (if-not (not (funcall test (apply-key key elt)))))
-			    (setq count (1- count))
-			    new)
-				(t elt))))))
-      (setq list (cdr list)))
-    (do ()
-	((null list))
-      (setq splice (cdr (rplacd splice (list (car list)))))
-      (setq list (cdr list)))
-    (cdr result)))
-
-;;; Replace old with new in sequence moving from left to right by incrementer
-;;; on each pass through the loop. Called by all three substitute functions.
-(defun vector-substitute* (pred new sequence incrementer left right length
-			   start end count key test test-not old)
-  (declare (fixnum start count end incrementer right))
-  (let ((result (make-sequence-like sequence length))
-	(index left))
-    (declare (fixnum index))
-    (do ()
-	((= index start))
-      (setf (aref result index) (aref sequence index))
-      (setq index (+ index incrementer)))
-    (do ((elt))
-	((or (= index end) (= count 0)))
-      (setq elt (aref sequence index))
-      (setf (aref result index) 
-	    (cond ((case pred
-			  (normal
-			    (if test-not
-				(not (funcall test-not (apply-key key elt) old))
-				(funcall test (apply-key key elt) old)))
-			  (if (funcall test (apply-key key elt)))
-			  (if-not (not (funcall test (apply-key key elt)))))
-		   (setq count (1- count))
-		   new)
-		  (t elt)))
-      (setq index (+ index incrementer)))
-    (do ()
-	((= index right))
-      (setf (aref result index) (aref sequence index))
-      (setq index (+ index incrementer)))
-    result))
-
-(eval-when (compile eval)
-
-
-(defmacro subst-dispatch (pred)
- `(if (listp sequence)
-      (if from-end
-	  (nreverse (list-substitute* ,pred new (reverse sequence)
-				      (- (the fixnum length) (the fixnum end))
-				      (- (the fixnum length) (the fixnum start))
-				      count key test test-not old))
-	  (list-substitute* ,pred new sequence start end count key test test-not
-			    old))
-      (if from-end
-	  (vector-substitute* ,pred new sequence -1 (1- (the fixnum length))
-			      -1 length (1- (the fixnum end))
-			      (1- (the fixnum start)) count key test test-not old)
-	  (vector-substitute* ,pred new sequence 1 0 length length
-	   start end count key test test-not old))))
-
-)
-
-
-;;; Substitute:
-
-(defun substitute (new old sequence &key from-end (test #'eql) test-not
-		   (start 0) (count most-positive-fixnum)
-		   end key)
-  "Returns a sequence of the same kind as Sequence with the same elements
-  except that all elements equal to Old are replaced with New.  See manual
-  for details."
-  (declare (fixnum start count))
-  (when (null end) (setf end (length sequence)))
-  (let ((length (length sequence))
-	(old (apply-key key old)))
-    (declare (fixnum length))
-    (subst-dispatch 'normal)))
-
-
-;;; Substitute-If:
-
-(defun substitute-if (new test sequence &key from-end (start 0)
-		       end (count most-positive-fixnum) key)
-  "Returns a sequence of the same kind as Sequence with the same elements
-  except that all elements satisfying the Test are replaced with New.  See
-  manual for details."
-  (declare (fixnum start count))
-  (when (null end) (setf end (length sequence)))
-  (let ((length (length sequence))
-	test-not
-	old)
-    (declare (fixnum length))
-    (subst-dispatch 'if)))
-  
-
-;;; Substitute-If-Not:
-
-(defun substitute-if-not (new test sequence &key from-end (start 0)
-			   end (count most-positive-fixnum) key)
-  "Returns a sequence of the same kind as Sequence with the same elements
-  except that all elements not satisfying the Test are replaced with New.
-  See manual for details."
-  (declare (fixnum start count))
-  (when (null end) (setf end (length sequence)))
-  (let ((length (length sequence))
-	test-not
-	old)
-    (declare (fixnum length))
-    (subst-dispatch 'if-not)))
-
-
-
-;;; NSubstitute:
-
-(defun nsubstitute (new old sequence &key from-end (test #'eql) test-not 
-		     end (count most-positive-fixnum) key (start 0))
-  "Returns a sequence of the same kind as Sequence with the same elements
-  except that all elements equal to Old are replaced with New.  The Sequence
-  may be destroyed.  See manual for details."
-  (declare (fixnum count start))
-  (when (null end) (setf end (length sequence)))
-  (let ((incrementer 1))
-    (declare (fixnum incrementer))
-    (if from-end
-	(psetq start (1- end)
-	       end (1- start)
-	       incrementer -1))
-    (if (listp sequence)
-	(if from-end
-	    (nreverse (nlist-substitute*
-		       new old (nreverse (the list sequence))
-		       test test-not start end count key))
-	    (nlist-substitute* new old sequence
-			       test test-not start end count key))
-	(nvector-substitute* new old sequence incrementer
-			     test test-not start end count key))))
-
-(defun nlist-substitute* (new old sequence test test-not start end count key)
-  (declare (fixnum start count end))
-  (do ((list (nthcdr start sequence) (cdr list))
-       (index start (1+ index)))
-      ((or (= index end) (null list) (= count 0)) sequence)
-    (declare (fixnum index))
-    (when (if test-not
-	      (not (funcall test-not (apply-key key (car list)) old))
-	      (funcall test (apply-key key (car list)) old))
-      (rplaca list new)
-      (setq count (1- count)))))
-
-(defun nvector-substitute* (new old sequence incrementer
-			    test test-not start end count key)
-  (declare (fixnum start incrementer count end))
-  (do ((index start (+ index incrementer)))
-      ((or (= index end) (= count 0)) sequence)
-    (declare (fixnum index))
-    (when (if test-not
-	      (not (funcall test-not (apply-key key (aref sequence index)) old))
-	      (funcall test (apply-key key (aref sequence index)) old))
-      (setf (aref sequence index) new)
-      (setq count (1- count)))))
-
-
-;;; NSubstitute-If:
-
-(defun nsubstitute-if (new test sequence &key from-end (start 0)
-			end (count most-positive-fixnum) key)
-  "Returns a sequence of the same kind as Sequence with the same elements
-  except that all elements satisfying the Test are replaced with New.  The
-  Sequence may be destroyed.  See manual for details."
-  (declare (fixnum start count))
-  (when (null end) (setf end (length sequence)))
-  (let ((incrementer 1))
-    (declare (fixnum incrementer))
-    (if from-end
-	(psetq start (1- end)
-	       end (1- start)
-	       incrementer -1))
-    (if (listp sequence)
-	(if from-end
-	    (nreverse (nlist-substitute-if*
-		       new test (nreverse (the list sequence))
-		       start end count key))
-	    (nlist-substitute-if* new test sequence
-				  start end count key))
-	(nvector-substitute-if* new test sequence incrementer
-				start end count key))))
-
-(defun nlist-substitute-if* (new test sequence start end count key)
-  (declare (fixnum end))
-  (do ((list (nthcdr start sequence) (cdr list))
-       (index start (1+ index)))
-      ((or (= index end) (null list) (= count 0)) sequence)
-    (when (funcall test (apply-key key (car list)))
-      (rplaca list new)
-      (setq count (1- count)))))
-
-(defun nvector-substitute-if* (new test sequence incrementer
-			       start end count key)
-  (do ((index start (+ index incrementer)))
-      ((or (= index end) (= count 0)) sequence)
-    (when (funcall test (apply-key key (aref sequence index)))
-      (setf (aref sequence index) new)
-      (setq count (1- count)))))
-
-
-;;; NSubstitute-If-Not:
-
-(defun nsubstitute-if-not (new test sequence &key from-end (start 0)
-			    end (count most-positive-fixnum) key)
-  "Returns a sequence of the same kind as Sequence with the same elements
-  except that all elements not satisfying the Test are replaced with New.
-  The Sequence may be destroyed.  See manual for details."
-  (declare (fixnum start end count))
-  (when (null end) (setf end (length sequence)))
-  (let ((incrementer 1))
-    (if from-end
-	(psetq start (1- end)
-	       end (1- start)
-	       incrementer -1))
-    (if (listp sequence)
-	(if from-end
-	    (nreverse (nlist-substitute-if-not*
-		       new test (nreverse (the list sequence))
-		       start end count key))
-	    (nlist-substitute-if-not* new test sequence
-				      start end count key))
-	(nvector-substitute-if-not* new test sequence incrementer
-				    start end count key))))
-
-(defun nlist-substitute-if-not* (new test sequence start end count key)
-  (declare (fixnum end))
-  (do ((list (nthcdr start sequence) (cdr list))
-       (index start (1+ index)))
-      ((or (= index end) (null list) (= count 0)) sequence)
-    (when (not (funcall test (apply-key key (car list))))
-      (rplaca list new)
-      (setq count (1- count)))))
-
-(defun nvector-substitute-if-not* (new test sequence incrementer
-				   start end count key)
-  (do ((index start (+ index incrementer)))
-      ((or (= index end) (= count 0)) sequence)
-    (when (not (funcall test (apply-key key (aref sequence index))))
-      (setf (aref sequence index) new)
-      (setq count (1- count)))))
-
-
-;;; Locater macros used by FIND and POSITION.
-
-(eval-when (compile eval)
-
-(defmacro vector-locater-macro (sequence body-form return-type)
-  `(let ((incrementer (if from-end -1 1))
-	 (start (if from-end (1- (the fixnum end)) start))
-	 (end (if from-end (1- (the fixnum start)) end)))
-     (declare (fixnum start end incrementer))
-     (do ((index start (+ index incrementer))
-	  ,@(case return-type (:position nil) (:element '(current))))
-	 ((= index end) ())
-       (declare (fixnum index))
-       ,@(case return-type
-	   (:position nil)
-	   (:element `((setf current (aref ,sequence index)))))
-       ,body-form)))
-
-(defmacro locater-test-not (item sequence seq-type return-type)
-  (let ((seq-ref (case return-type
-		   (:position
-		    (case seq-type
-		      (:vector `(aref ,sequence index))
-		      (:list `(pop ,sequence))))
-		   (:element 'current)))
-	(return (case return-type
-		  (:position 'index)
-		  (:element 'current))))
-    `(if test-not
-	 (if (not (funcall test-not ,item (apply-key key ,seq-ref)))
-	     (return ,return))
-	 (if (funcall test ,item (apply-key key ,seq-ref))
-	     (return ,return)))))
-
-(defmacro vector-locater (item sequence return-type)
-  `(vector-locater-macro ,sequence
-			 (locater-test-not ,item ,sequence :vector ,return-type)
-			 ,return-type))
-
-(defmacro locater-if-test (test sequence seq-type return-type sense)
-  (let ((seq-ref (case return-type
-		   (:position
-		    (case seq-type
-		      (:vector `(aref ,sequence index))
-		      (:list `(pop ,sequence))))
-		   (:element 'current)))
-	(return (case return-type
-		  (:position 'index)
-		  (:element 'current))))
-    (if sense
-	`(if (funcall ,test (apply-key key ,seq-ref))
-	     (return ,return))
-	`(if (not (funcall ,test (apply-key key ,seq-ref)))
-	     (return ,return)))))
-
-(defmacro vector-locater-if-macro (test sequence return-type sense)
-  `(vector-locater-macro ,sequence
-			 (locater-if-test ,test ,sequence :vector ,return-type ,sense)
-			 ,return-type))
-
-(defmacro vector-locater-if (test sequence return-type)
-  `(vector-locater-if-macro ,test ,sequence ,return-type t))
-
-(defmacro vector-locater-if-not (test sequence return-type)
-  `(vector-locater-if-macro ,test ,sequence ,return-type nil))
-
-
-(defmacro list-locater-macro (sequence body-form return-type)
-  `(if from-end
-       (do ((sequence (nthcdr (- (the fixnum (length sequence))
-				 (the fixnum end))
-			      (reverse (the list ,sequence))))
-	    (index (1- (the fixnum end)) (1- index))
-	    (terminus (1- (the fixnum start)))
-	    ,@(case return-type (:position nil) (:element '(current))))
-	   ((or (= index terminus) (null sequence)) ())
-	 (declare (fixnum index terminus))
-	 ,@(case return-type
-	     (:position nil)
-	     (:element `((setf current (pop ,sequence)))))
-	 ,body-form)
-       (do ((sequence (nthcdr start ,sequence))
-	    (index start (1+ index))
-	    ,@(case return-type (:position nil) (:element '(current))))
-	   ((or (= index (the fixnum end)) (null sequence)) ())
-	 (declare (fixnum index))
-	 ,@(case return-type
-	     (:position nil)
-	     (:element `((setf current (pop ,sequence)))))
-	 ,body-form)))
-
-(defmacro list-locater (item sequence return-type)
-  `(list-locater-macro ,sequence
-		       (locater-test-not ,item ,sequence :list ,return-type)
-		       ,return-type))
-
-(defmacro list-locater-if-macro (test sequence return-type sense)
-  `(list-locater-macro ,sequence
-		       (locater-if-test ,test ,sequence :list ,return-type ,sense)
-		       ,return-type))
-
-(defmacro list-locater-if (test sequence return-type)
-  `(list-locater-if-macro ,test ,sequence ,return-type t))
-
-(defmacro list-locater-if-not (test sequence return-type)
-  `(list-locater-if-macro ,test ,sequence ,return-type nil))
-
-) ; eval-when
-
-
-;;; Position:
-
-(eval-when (compile eval)
-
-(defmacro vector-position (item sequence)
-  `(vector-locater ,item ,sequence :position))
-
-(defmacro list-position (item sequence)
-  `(list-locater ,item ,sequence :position))
-
-) ; eval-when
-
-
-;;; POSITION cannot default end to the length of sequence since it is not
-;;; an error to supply nil for its value.  We must test for end being nil
-;;; in the body of the function, and this is actually done in the support
-;;; routines for other reasons (see below).
-(defun position (item sequence &key from-end (test #'eql) test-not (start 0)
-		  end key)
-  "Returns the zero-origin index of the first element in SEQUENCE
-   satisfying the test (default is EQL) with the given ITEM"
-  (seq-dispatch sequence
-    (list-position* item sequence from-end test test-not start end key)
-    (vector-position* item sequence from-end test test-not start end key)))
-
-
-;;; The support routines for SUBSEQ are used by compiler transforms, so we
-;;; worry about dealing with end being supplied as or defaulting to nil
-;;; at this level.
-
-(defun list-position* (item sequence from-end test test-not start end key)
-  (declare (fixnum start))
-  (when (null end) (setf end (length sequence)))
-  (list-position item sequence))
-
-(defun vector-position* (item sequence from-end test test-not start end key)
-  (declare (fixnum start))
-  (when (null end) (setf end (length sequence)))
-  (vector-position item sequence))
-
-
-;;; Position-if:
-
-(eval-when (compile eval)
-
-(defmacro vector-position-if (test sequence)
-  `(vector-locater-if ,test ,sequence :position))
-
-
-(defmacro list-position-if (test sequence)
-  `(list-locater-if ,test ,sequence :position))
-
-)
-
-(defun position-if (test sequence &key from-end (start 0) key end)
-  "Returns the zero-origin index of the first element satisfying test(el)"
-  (declare (fixnum start))
-  (when (null end) (setf end (length sequence)))
-  (seq-dispatch sequence
-		(list-position-if test sequence)
-		(vector-position-if test sequence)))
-
-
-;;; Position-if-not:
-
-(eval-when (compile eval)
-
-(defmacro vector-position-if-not (test sequence)
-  `(vector-locater-if-not ,test ,sequence :position))
-
-(defmacro list-position-if-not (test sequence)
-  `(list-locater-if-not ,test ,sequence :position))
-
-)
-
-(defun position-if-not (test sequence &key from-end (start 0) key end)
-  "Returns the zero-origin index of the first element not satisfying test(el)"
-  (declare (fixnum start))
-  (when (null end) (setf end (length sequence)))
-  (seq-dispatch sequence
-		(list-position-if-not test sequence)
-		(vector-position-if-not test sequence)))
-
-
-;;; Find:
-
-(eval-when (compile eval)
-
-(defmacro vector-find (item sequence)
-  `(vector-locater ,item ,sequence :element))
-
-(defmacro list-find (item sequence)
-  `(list-locater ,item ,sequence :element))
-
-)
-
-;;; FIND cannot default end to the length of sequence since it is not
-;;; an error to supply nil for its value.  We must test for end being nil
-;;; in the body of the function, and this is actually done in the support
-;;; routines for other reasons (see above).
-(defun find (item sequence &key from-end (test #'eql) test-not (start 0)
-	       end key)
-  "Returns the first element in SEQUENCE satisfying the test (default
-   is EQL) with the given ITEM"
-  (declare (fixnum start))
-  (seq-dispatch sequence
-    (list-find* item sequence from-end test test-not start end key)
-    (vector-find* item sequence from-end test test-not start end key))))
-
-
-;;; The support routines for FIND are used by compiler transforms, so we
-;;; worry about dealing with end being supplied as or defaulting to nil
-;;; at this level.
-
-(defun list-find* (item sequence from-end test test-not start end key)
-  (when (null end) (setf end (length sequence)))
-  (list-find item sequence))
-
-(defun vector-find* (item sequence from-end test test-not start end key)
-  (when (null end) (setf end (length sequence)))
-  (vector-find item sequence))
-
-
-;;; Find-if:
-
-(eval-when (compile eval)
-
-(defmacro vector-find-if (test sequence)
-  `(vector-locater-if ,test ,sequence :element))
-
-(defmacro list-find-if (test sequence)
-  `(list-locater-if ,test ,sequence :element))
-
-)
-
-(defun find-if (test sequence &key from-end (start 0) end key)
-  "Returns the zero-origin index of the first element satisfying the test."
-  (declare (fixnum start))
-  (when (null end) (setf end (length sequence)))
-  (seq-dispatch sequence
-		(list-find-if test sequence)
-		(vector-find-if test sequence)))
-
-
-;;; Find-if-not:
-
-(eval-when (compile eval)
-
-(defmacro vector-find-if-not (test sequence)
-  `(vector-locater-if-not ,test ,sequence :element))
-
-(defmacro list-find-if-not (test sequence)
-  `(list-locater-if-not ,test ,sequence :element))
-
-)
-
-(defun find-if-not (test sequence &key from-end (start 0) end key)
-  "Returns the zero-origin index of the first element not satisfying the test."
-  (declare (fixnum start))
-  (when (null end) (setf end (length sequence)))
-  (seq-dispatch sequence
-		(list-find-if-not test sequence)
-		(vector-find-if-not test sequence)))
-
-
-;;; Count:
-
-(eval-when (compile eval)
-
-(defmacro vector-count (item sequence)
-  `(do ((index start (1+ index))
-	(count 0))
-       ((= index (the fixnum end)) count)
-     (declare (fixnum index count))
-     (if test-not
-	 (if (funcall test-not ,item (apply-key key (aref ,sequence index)))
-	     (setq count (1+ count)))
-	 (if (funcall test ,item (apply-key key (aref ,sequence index)))
-	     (setq count (1+ count))))))
-
-(defmacro list-count (item sequence)
-  `(do ((sequence (nthcdr start ,sequence))
-	(index start (1+ index))
-	(count 0))
-       ((or (= index (the fixnum end)) (null sequence)) count)
-     (declare (fixnum index count))
-     (if test-not
-	 (if (funcall test-not ,item (apply-key key (pop sequence)))
-	     (setq count (1+ count)))
-	 (if (funcall test ,item (apply-key key (pop sequence)))
-	     (setq count (1+ count))))))
-
-)
-
-(defun count (item sequence &key from-end (test #'eql) test-not (start 0)
-		end key)
-  "Returns the number of elements in SEQUENCE satisfying a test with ITEM,
-   which defaults to EQL."
-  (declare (ignore from-end) (fixnum start))
-  (when (null end) (setf end (length sequence)))
-  (seq-dispatch sequence
-		(list-count item sequence)
-		(vector-count item sequence)))
-
-
-;;; Count-if:
-
-(eval-when (compile eval)
-
-(defmacro vector-count-if (predicate sequence)
-  `(do ((index start (1+ index))
-	(count 0))
-       ((= index (the fixnum end)) count)
-     (declare (fixnum index count))
-     (if (funcall ,predicate (apply-key key (aref ,sequence index)))
-	 (setq count (1+ count)))))
-
-(defmacro list-count-if (predicate sequence)
-  `(do ((sequence (nthcdr start ,sequence))
-	(index start (1+ index))
-	(count 0))
-       ((or (= index (the fixnum end)) (null sequence)) count)
-     (declare (fixnum index count))
-     (if (funcall ,predicate (apply-key key (pop sequence)))
-	 (setq count (1+ count)))))
-
-)
-
-(defun count-if (test sequence &key from-end (start 0) end key)
-  "Returns the number of elements in SEQUENCE satisfying TEST(el)."
-  (declare (ignore from-end) (fixnum start))
-  (when (null end) (setf end (length sequence)))
-  (seq-dispatch sequence
-		(list-count-if test sequence)
-		(vector-count-if test sequence)))
-
-
-;;; Count-if-not:
-
-(eval-when (compile eval)
-
-(defmacro vector-count-if-not (predicate sequence)
-  `(do ((index start (1+ index))
-	(count 0))
-       ((= index (the fixnum end)) count)
-     (declare (fixnum index count))
-     (if (not (funcall ,predicate (apply-key key (aref ,sequence index))))
-	 (setq count (1+ count)))))
-
-(defmacro list-count-if-not (predicate sequence)
-  `(do ((sequence (nthcdr start ,sequence))
-	(index start (1+ index))
-	(count 0))
-       ((or (= index (the fixnum end)) (null sequence)) count)
-     (declare (fixnum index count))
-     (if (not (funcall ,predicate (apply-key key (pop sequence))))
-	 (setq count (1+ count)))))
-
-)
-
-(defun count-if-not (test sequence &key from-end (start 0) end key)
-  "Returns the number of elements in SEQUENCE not satisfying TEST(el)."
-  (declare (ignore from-end) (fixnum start))
-  (when (null end) (setf end (length sequence)))
-  (seq-dispatch sequence
-		(list-count-if-not test sequence)
-		(vector-count-if-not test sequence)))
-
-
-;;; Mismatch utilities:
-
-(eval-when (compile eval)
-
-
-(defmacro match-vars (&rest body)
-  `(let ((inc (if from-end -1 1))
-	 (start1 (if from-end (1- (the fixnum end1)) start1))
-	 (start2 (if from-end (1- (the fixnum end2)) start2))
-	 (end1 (if from-end (1- (the fixnum start1)) end1))
-	 (end2 (if from-end (1- (the fixnum start2)) end2)))
-     (declare (fixnum inc start1 start2 end1 end2))
-     ,@body))
-
-(defmacro matchify-list (sequence start length end)
-  `(setq ,sequence
-	 (if from-end
-	     (nthcdr (- (the fixnum ,length) (the fixnum ,start) 1)
-		     (reverse (the list ,sequence)))
-	     (nthcdr ,start ,sequence))))
-
-)
-
-;;; Mismatch:
-
-(eval-when (compile eval)
-
-(defmacro if-mismatch (elt1 elt2)
-  `(cond ((= (the fixnum index1) (the fixnum end1))
-	  (return (if (= (the fixnum index2) (the fixnum end2))
-		      nil
-		      (if from-end
-			  (1+ (the fixnum index1))
-			  (the fixnum index1)))))
-	 ((= (the fixnum index2) (the fixnum end2))
-	  (return (if from-end (1+ (the fixnum index1)) index1)))
-	 (test-not
-	  (if (funcall test-not (apply-key key ,elt1) (apply-key key ,elt2))
-	      (return (if from-end (1+ (the fixnum index1)) index1))))
-	 (t (if (not (funcall test (apply-key key ,elt1) (apply-key key ,elt2)))
-		(return (if from-end (1+ (the fixnum index1)) index1))))))
-
-(defmacro mumble-mumble-mismatch ()
-  `(do ((index1 start1 (+ index1 (the fixnum inc)))
-	(index2 start2 (+ index2 (the fixnum inc))))
-       (())
-     (declare (fixnum index1 index2))
-     (if-mismatch (aref sequence1 index1) (aref sequence2 index2))))
-
-(defmacro mumble-list-mismatch ()
-  `(do ((index1 start1 (+ index1 (the fixnum inc)))
-	(index2 start2 (+ index2 (the fixnum inc))))
-       (())
-     (declare (fixnum index1 index2))
-     (if-mismatch (aref sequence1 index1) (pop sequence2))))
-
-(defmacro list-mumble-mismatch ()
-  `(do ((index1 start1 (+ index1 (the fixnum inc)))
-	(index2 start2 (+ index2 (the fixnum inc))))
-       (())
-     (declare (fixnum index1 index2))
-     (if-mismatch (pop sequence1) (aref sequence2 index2))))
-
-(defmacro list-list-mismatch ()
-  `(do ((index1 start1 (+ index1 (the fixnum inc)))
-	(index2 start2 (+ index2 (the fixnum inc))))
-       (())
-     (declare (fixnum index1 index2))
-     (if-mismatch (pop sequence1) (pop sequence2))))
-
-)
-
-(defun mismatch (sequence1 sequence2 &key from-end (test #'eql) test-not 
-			   (start1 0) end1 (start2 0) end2 key)
-  "The specified subsequences of Sequence1 and Sequence2 are compared
-  element-wise.  If they are of equal length and match in every element, the
-  result is Nil.  Otherwise, the result is a non-negative integer, the index
-  within Sequence1 of the leftmost position at which they fail to match; or, if
-  one is shorter than and a matching prefix of the other, the index within
-  Sequence1 beyond the last position tested is returned.  If a non-Nil :From-End
-  keyword argument is given, then one plus the index of the rightmost position in
-  which the sequences differ is returned."
-  (declare (fixnum start1 start2))
-  (when (null end1) (setf end1 (length sequence1)))
-  (when (null end2) (setf end2 (length sequence2)))
-  (let ((length1 (length sequence1))
-	(length2 (length sequence2)))
-    (declare (fixnum length1 length2))
-    (match-vars
-     (seq-dispatch sequence1
-      (progn (matchify-list sequence1 start1 length1 end1)
-	     (seq-dispatch sequence2
-			   (progn (matchify-list sequence2 start2 length2 end2)
-				  (list-list-mismatch))
-			   (list-mumble-mismatch)))
-      (seq-dispatch sequence2
-		    (progn (matchify-list sequence2 start2 length2 end2)
-			   (mumble-list-mismatch))
-		    (mumble-mumble-mismatch))))))
-
-
-;;; Search comparison functions:
-
-(eval-when (compile eval)
-
-;;; Compare two elements and return if they don't match:
-
-(defmacro compare-elements (elt1 elt2)
-  `(if test-not
-       (if (funcall test-not (apply-key key ,elt1) (apply-key key ,elt2))
-	   (return nil)
-	   t)
-       (if (not (funcall test (apply-key key ,elt1) (apply-key key ,elt2)))
-	   (return nil)
-	   t)))
-
-(defmacro search-compare-list-list (main sub)
-  `(do ((main ,main (cdr main))
-	(jndex start1 (1+ jndex))
-	(sub (nthcdr start1 ,sub) (cdr sub)))
-       ((or (null main) (null sub) (= (the fixnum end1) jndex))
-	t)
-     (declare (fixnum jndex))
-     (compare-elements (car main) (car sub))))
-
-(defmacro search-compare-list-vector (main sub)
-  `(do ((main ,main (cdr main))
-	(index start1 (1+ index)))
-       ((or (null main) (= index (the fixnum end1))) t)
-     (declare (fixnum index))
-     (compare-elements (car main) (aref ,sub index))))
-
-(defmacro search-compare-vector-list (main sub index)
-  `(do ((sub (nthcdr start1 ,sub) (cdr sub))
-	(jndex start1 (1+ jndex))
-	(index ,index (1+ index)))
-       ((or (= (the fixnum end1) jndex) (null sub)) t)
-     (declare (fixnum jndex index))
-     (compare-elements (aref ,main index) (car sub))))
-
-(defmacro search-compare-vector-vector (main sub index)
-  `(do ((index ,index (1+ index))
-	(sub-index start1 (1+ sub-index)))
-       ((= sub-index (the fixnum end1)) t)
-     (declare (fixnum sub-index index))
-     (compare-elements (aref ,main index) (aref ,sub sub-index))))
-
-(defmacro search-compare (main-type main sub index)
-  (if (eq main-type 'list)
-      `(seq-dispatch ,sub
-		     (search-compare-list-list ,main ,sub)
-		     (search-compare-list-vector ,main ,sub))
-      `(seq-dispatch ,sub
-		     (search-compare-vector-list ,main ,sub ,index)
-		     (search-compare-vector-vector ,main ,sub ,index))))
-
-)
-
-(eval-when (compile eval)
- 
-(defmacro list-search (main sub)
-  `(do ((main (nthcdr start2 ,main) (cdr main))
-	(index2 start2 (1+ index2))
-	(terminus (- (the fixnum end2)
-		     (the fixnum (- (the fixnum end1)
-				    (the fixnum start1)))))
-	(last-match ()))
-       ((> index2 terminus) last-match)
-     (declare (fixnum index2 terminus))
-     (if (search-compare list main ,sub index2)
-	 (if from-end
-	     (setq last-match index2)
-	     (return index2)))))
-
-
-(defmacro vector-search (main sub)
-  `(do ((index2 start2 (1+ index2))
-	(terminus (- (the fixnum end2)
-		     (the fixnum (- (the fixnum end1)
-				    (the fixnum start1)))))
-	(last-match ()))
-       ((> index2 terminus) last-match)
-     (declare (fixnum index2 terminus))
-     (if (search-compare vector ,main ,sub index2)
-	 (if from-end
-	     (setq last-match index2)
-	     (return index2)))))
-
-)
-
-
-(defun search (sequence1 sequence2 &key from-end (test #'eql) test-not 
-		(start1 0) end1 (start2 0) end2 key)
-  "A search is conducted using EQL for the first subsequence of sequence2 
-   which element-wise matches sequence1.  If there is such a subsequence in 
-   sequence2, the index of the its leftmost element is returned; 
-   otherwise () is returned."
-  (declare (fixnum start1 start2))
-  (when (null end1) (setf end1 (length sequence1)))
-  (when (null end2) (setf end2 (length sequence2)))
-  (seq-dispatch sequence2
-    (list-search sequence2 sequence1)
-    (vector-search sequence2 sequence1)))
diff --git a/code/serve-event.lisp b/code/serve-event.lisp
deleted file mode 100644
index ee453df6ff141842e34e9fad7596098405cc5c5c..0000000000000000000000000000000000000000
--- a/code/serve-event.lisp
+++ /dev/null
@@ -1,365 +0,0 @@
-;;; -*- Log: code.log; Package: LISP -*-
-
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; SYSTEM:SERVE-EVENT, now in it's own file.
-;;;
-;;; Re-written by William Lott, July 1989 - January 1990.
-;;; 
-;;; **********************************************************************
-
-(in-package "SYSTEM")
-
-(export '(with-fd-handler add-fd-handler remove-fd-handler invalidate-descriptor
-	  serve-event serve-all-events wait-until-fd-usable))
-
-(in-package "LISP")
-
-
-
-;;;; MACH Message receiving noise.
-
-(defvar *in-server* NIL
-  "*In-server* is set to T when the SIGMSG interrupt has been enabled
-  in Server.")
-
-(defvar server-unique-object (cons 1 2)
-  "Object thrown by the message interrupt handler.")
-
-(defconstant server-message-size 4096)
-(defalien server-message server-message (bytes server-message-size) 0)
-
-(define-alien-stack server-message server-message (bytes server-message-size))
-
-(defrecord server-message
-  (msg mach:msg #.(record-size 'mach:msg)))
-  
-;;; Grab-message-loop calls the appropiate handler for an IPC message.
-(defun grab-message-loop ()
-  (let ((done-any nil))
-    (loop
-      (if (eql (server-grab-message)
-	       mach:rcv-timed-out)
-	(return done-any)
-	(setf done-any t)))))
-
-
-(defun server-grab-message ()
-  (with-stack-alien (sm server-message)
-    (alien-bind ((msg (server-message-msg (alien-value sm))))
-      (setf (alien-access (mach:msg-msgsize (alien-value msg)))
-	    server-message-size)
-      (setf (alien-access (mach:msg-localport (alien-value msg)))
-	    mach::port-enabled)
-      (let ((gr (mach:msg-receive (alien-value sm) mach::rcv-timeout 0)))
-	(when (eql gr mach:rcv-timed-out)
-	  (return-from server-grab-message gr))
-	(unless (eql gr mach:rcv-success)
-	  (gr-error 'mach:msg-receive gr))
-	(let* ((server-message (alien-value sm))
-	       (port (alien-access (mach:msg-localport (alien-value msg))))
-	       (id (alien-access (mach:msg-id (alien-value msg))))
-	       (x (gethash port *port-table*))
-	       (set (cdr x)))
-	  (unless x
-	    (error "~D is not known to server (operation: ~D)." port id))
-	  (let ((gr (funcall (gethash id (object-set-table set)
-				      (object-set-default-handler set))
-			     (car x))))
-	    (unless (eql gr mach:kern-success)
-	      (gr-error 'server gr)))))))
-  mach:kern-success)
-
-
-;;;; File descriptor IO noise.
-
-(defstruct (handler
-	    (:print-function %print-handler)
-	    (:constructor make-handler (direction descriptor function)))
-  direction		      ; Either :input or :output
-  descriptor		      ; File descriptor this handler is tied to.
-  active		      ; T iff this handler is running.
-  function		      ; Function to call.
-  bogus			      ; T if this descriptor is bogus. 
-  )
-
-(defun %print-handler (handler stream depth)
-  (declare (ignore depth))
-  (format stream "#<Handler for ~A on ~:[~;BOGUS ~]descriptor ~D: ~S>"
-	  (handler-direction handler)
-	  (handler-bogus handler)
-	  (handler-descriptor handler)
-	  (handler-function handler)))
-
-(defvar *descriptor-handlers* nil
-  "List of all the currently active handlers for file descriptors")
-
-
-;;; ADD-FD-HANDLER -- public
-;;;
-;;;   Add a new handler to *descriptor-handlers*.
-;;;
-(defun add-fd-handler (fd direction function)
-  "Arange to call FUNCTION whenever FD is usable. DIRECTION should be
-  either :INPUT or :OUTPUT. The value returned should be passed to
-  SYSTEM:REMOVE-FD-HANDLER when it is no longer needed."
-  (assert (member direction '(:input :output))
-	  (direction)
-	  "Invalid direction ~S, must be either :INPUT or :OUTPUT" direction)
-  (let ((handler (make-handler direction fd function)))
-    (push handler *descriptor-handlers*)
-    handler))
-
-;;; REMOVE-FD-HANDLER -- public
-;;;
-;;;   Remove an old handler from *descriptor-handlers*.
-;;;
-(defun remove-fd-handler (handler)
-  "Removes HANDLER from the list of active handlers."
-  (setf *descriptor-handlers*
-	(delete handler *descriptor-handlers*
-		:test #'eq)))
-
-;;; INVALIDATE-DESCRIPTOR -- public
-;;;
-;;;   Search *descriptor-handlers* for any reference to fd, and nuke 'em.
-;;; 
-(defun invalidate-descriptor (fd)
-  "Remove any handers refering to fd. This should only be used when attempting
-  to recover from a detected inconsistancy."
-  (setf *descriptor-handlers*
-	(delete fd *descriptor-handlers*
-		:key #'handler-descriptor)))
-
-;;; WITH-FD-HANDLER -- Public.
-;;;
-;;; Add the handler to *descriptor-handlers* for the duration of BODY.
-;;;
-(defmacro with-fd-handler ((fd direction function) &rest body)
-  "Establish a handler with SYSTEM:ADD-FD-HANDLER for the duration of BODY.
-   DIRECTION should be either :INPUT or :OUTPUT, FD is the file descriptor to
-   use, and FUNCTION is the function to call whenever FD is usable."
-  (let ((handler (gensym)))
-    `(let (,handler)
-       (unwind-protect
-	   (progn
-	     (setf ,handler (add-fd-handler ,fd ,direction ,function))
-	     ,@body)
-	 (when ,handler
-	   (remove-fd-handler ,handler))))))
-
-;;; WAIT-UNTIL-FD-USABLE -- Public.
-;;;
-;;; Wait until FD is usable for DIRECTION. The timeout given to serve-event is
-;;; recalculated each time through the loop so that WAIT-UNTIL-FD-USABLE will
-;;; timeout at the correct time irrespective of how many events are handled in
-;;; the meantime.
-;;;
-(defun wait-until-fd-usable (fd direction &optional timeout)
-  "Wait until FD is usable for DIRECTION. DIRECTION should be either :INPUT or
-  :OUTPUT. TIMEOUT, if supplied, is the number of seconds to wait before giving
-  up."
-  (let (usable
-	(stop-at (if timeout
-		   (multiple-value-bind (okay sec usec)
-					(mach:unix-gettimeofday)
-		     (declare (ignore okay))
-		     (+ (* 1000000 timeout sec) usec)))))
-    (with-fd-handler (fd direction #'(lambda (fd)
-				       (declare (ignore fd))
-				       (setf usable t)))
-      (loop
-	(serve-event timeout)
-	
-	(when usable
-	  (return t))
-	
-	(when timeout
-	  (multiple-value-bind (okay sec usec)
-			       (mach:unix-gettimeofday)
-	    (declare (ignore okay))
-	    (let ((now (+ (* sec 1000000) usec)))
-	      (if (> now stop-at)
-		(return nil)
-		(setq timeout
-		      (/ (- stop-at now)
-			 1000000))))))))))
-
-;;; CALC-MASKS -- Internal.
-;;;
-;;; Return the correct masks to use for UNIX-SELECT.  The four return values
-;;; are: fd count, read mask, write mask, and exception mask.  The exception
-;;; mask is currently unused.
-;;;
-(defun calc-masks ()
-  (let ((count 0)
-	(read-mask 0)
-	(write-mask 0)
-	(except-mask 0))
-    (dolist (handler *descriptor-handlers*)
-      (unless (or (handler-active handler)
-		  (handler-bogus handler))
-	(let ((fd (handler-descriptor handler)))
-	  (case (handler-direction handler)
-	    (:input
-	     (setf read-mask (logior read-mask (ash 1 fd))))
-	    (:output
-	     (setf write-mask (logior write-mask (ash 1 fd)))))
-	  (if (> fd count)
-	    (setf count fd)))))
-    (values (1+ count)
-	    read-mask
-	    write-mask
-	    except-mask)))
-
-;;; HANDLER-DESCRIPTORS-ERROR -- Internal.
-;;;
-;;; First, get a list and mark bad file descriptors.  Then signal an error
-;;; offering a few restarts.
-;;;
-(defun handler-descriptors-error ()
-  (let ((bogus-handlers nil))
-    (dolist (handler *descriptor-handlers*)
-      (unless (or (handler-bogus handler)
-		  (mach:unix-fstat (handler-descriptor handler)))
-	(setf (handler-bogus handler) t)
-	(push handler bogus-handlers)))
-    (restart-case (error "~S ~[have~;has a~:;have~] bad file descriptor~:P."
-			 bogus-handlers (length bogus-handlers))
-      (remove-them () :report "Remove bogus handlers."
-       (setf *descriptor-handlers*
-	     (delete-if #'handler-bogus *descriptor-handlers*)))
-      (retry-them () :report "Retry bogus handlers."
-       (dolist (handler bogus-handlers)
-	 (setf (handler-bogus handler) nil)))
-      (continue () :report "Go on, leaving handlers marked as bogus."))))
-
-
-
-;;;; Serve-all-events, serve-event, and friends.
-
-;;; SERVE-ALL-EVENTS -- public
-;;;
-;;;   Wait for up to timeout seconds for an event to happen. Make sure all
-;;; pending events are processed before returning.
-;;;
-(defun serve-all-events (&optional timeout)
-  "SERVE-ALL-EVENTS calls SERVE-EVENT with the specified timeout.  If
-  SERVE-EVENT does something (returns T) it loops over SERVE-EVENT with timeout
-  0 until all events have been served.  SERVE-ALL-EVENTS returns T if
-  SERVE-EVENT did something and NIL if not."
-  (do ((res nil)
-       (sval (serve-event timeout) (serve-event 0)))
-      ((null sval) res)
-    (setq res t)))
-
-;;; SERVE-EVENT -- public
-;;;
-;;;   Serve a single event.
-;;;
-(defun serve-event (&optional timeout)
-  "Receive on all ports and Xevents and dispatch to the appropriate handler
-  function.  If timeout is specified, server will wait the specified time (in
-  seconds) and then return, otherwise it will wait until something happens.
-  Server returns T if something happened and NIL otherwise."
-  ;; First, check any X displays for any pending events.
-  (dolist (d/h ext::*display-event-handlers*)
-    (let ((d (car d/h)))
-      (when (xlib::event-listen d)
-	(handler-bind ((error #'(lambda (condx)
-				  (declare (ignore condx))
-				  (flush-display-events d))))
-	  (funcall (cdr d/h) d))
-	(return-from serve-event t))))
-  ;; Next, wait for something to happen.
-  (multiple-value-bind
-      (value readable writeable)
-      (wait-for-event timeout)
-    ;; Now see what it was (if anything)
-    (cond ((eq value server-unique-object)
-	   ;; The interrupt handler fired.
-	   (grab-message-loop)
-	   t)
-	  ((numberp value)
-	   (unless (zerop value)
-	     ;; Check the descriptors.
-	     (let ((result nil))
-	       (dolist (handler *descriptor-handlers*)
-		 (when (not (zerop (logand (ash 1 (handler-descriptor handler))
-					   (case (handler-direction handler)
-					     (:input readable)
-					     (:output writeable)))))
-		   (unwind-protect
-		       (progn
-			 ;; Doesn't work -- ACK
-			 ;(setf (handler-active handler) t)
-			 (funcall (handler-function handler)
-				  (handler-descriptor handler)))
-		     (setf (handler-active handler) nil))
-		   (macrolet ((frob (var)
-				`(setf ,var
-				       (logand (lognot (ash 1
-							    (handler-descriptor
-							     handler)))
-					       ,var))))
-		     (case (handler-direction handler)
-		       (:input (frob readable))
-		       (:output (frob writeable))))
-		   (setf result t)))
-	       result)))
-	  ((eql readable mach:eintr)
-	   ;; We did an interrupt.
-	   t)
-	  (t
-	   ;; One of the file descriptors is bad.
-	   (handler-descriptors-error)
-	   nil))))
-
-;;; WAIT-FOR-EVENT -- internal
-;;;
-;;;   Wait for something to happen. 
-;;;
-(defun wait-for-event (&optional timeout)
-  "Wait for an something to show up on one of the file descriptors or a message
-  interupt to fire. Timeout is in seconds."
-  (let (old-mask)
-    (multiple-value-bind (timeout-sec timeout-usec)
-			 (if timeout
-			   (truncate (round (* timeout 1000000)) 1000000)
-			   (values nil 0))
-      (multiple-value-bind (count read-mask write-mask except-mask)
-			   (calc-masks)
-	(catch 'server-catch
-	  (unwind-protect
-	      (progn
-		;; Block message interrupts.
-		(multiple-value-bind
-		    (noise mask)
-		    (mach:unix-sigsetmask (mach:sigmask :sigmsg))
-		  (declare (ignore noise))
-		  (setf old-mask mask))
-		;; Check for any pending messages, because we are only signaled
-		;; for newly arived messages. This must be done after the
-		;; unix-sigsetmask.
-		(when (grab-message-loop)
-		  (return-from wait-for-event t))
-		;; Indicate that we are in the server.
-		(let ((*in-server* t))
-		  ;; Establish the interrupt handlers.
-		  (enable-interrupt mach:sigmsg #'ih-sigmsg)
-		  ;; Enable all interrupts.
-		  (mach:unix-sigsetmask 0)
-		  ;; Do the select.
-		  (mach:unix-select count read-mask write-mask except-mask
-				    timeout-sec timeout-usec)))
-	    ;; Restore interrupt handler state.
-	    (mach:unix-sigsetmask (mach:sigmask :sigmsg))
-	    (default-interrupt mach:sigmsg)
-	    (mach:unix-sigsetmask old-mask)))))))
-
-
diff --git a/code/sharpm.lisp b/code/sharpm.lisp
deleted file mode 100644
index 65338fd9a021abc31fefcdca8d9d54a4e5808cf7..0000000000000000000000000000000000000000
--- a/code/sharpm.lisp
+++ /dev/null
@@ -1,456 +0,0 @@
-;;; -*- Log: code.log; Package: Lisp -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; Spice Lisp Interim Sharp Macro
-;;; Written by David Dill
-;;; Runs in the standard Spice Lisp environment.
-;;; This uses the special std-lisp-readtable, which is internal to READER.LISP
-;;;
-;;; ****************************************************************
-(in-package 'lisp)
-
-
-;;; declared in READ.LISP
-
-(proclaim '(special *read-suppress* std-lisp-readtable *bq-vector-flag*))
-
-(defun sharp-backslash (stream backslash font)
-  (unread-char backslash stream)
-  (let* ((*readtable* std-lisp-readtable)
-	 (bitnames ())
-	 (charstring (read-extended-token stream)))
-    (declare (simple-string charstring))
-    (when *read-suppress* (return-from sharp-backslash nil))
-    ;;find bit name prefixes
-    (do ((i (position #\- charstring) (position #\- charstring)))
-	((or (null i) (zerop (the fixnum i))))
-      (let ((bitname (string-upcase (subseq charstring 0 i))))
-	(setq charstring (subseq charstring (1+ (the fixnum i))))
-	;;* symbols in alist are a kludge to circumvent xc bogosity.
-	(let ((expansion (cdr (assoc bitname '(("C" . CONTROL)
-					       ("M" . META)
-					       ("H" . HYPER)
-					       ("S" . SUPER))
-				     :test #'equal))))
-	  (if expansion (setq bitname (symbol-name expansion)))
-	  (cond ((member bitname '("CONTROL" "META" "HYPER" "SUPER")
-			 :test #'EQUAL)
-		 (if (not (member bitname bitnames :test #'EQUAL))
-		     (push bitname bitnames)
-		     (error
-			     "Redundant bit name in character name: ~A"
-			     bitname)))
-		(t (error
-			   "Meaningless bit name in character name: ~A"
-			   bitname))))))
-    ;;build un-hyphenated char, add specified bits:
-    (let ((char (if (= (the fixnum (length charstring)) 1)
-		    (char charstring 0)
-		    (name-char charstring))))
-      (cond (char
-	     (if font
-		 (setq char (make-char char 0 font)))
-	     (if (member "CONTROL" bitnames :test #'EQUAL)
-		 (setq char (set-char-bit char :control t)))
-	     (if (member "META" bitnames :test #'EQUAL)
-		 (setq char (set-char-bit char :meta t)))
-	     (if (member "HYPER" bitnames :test #'EQUAL)
-		 (setq char (set-char-bit char :hyper t)))
-	     (if (member "SUPER" bitnames :test #'EQUAL)
-		 (setq char (set-char-bit char :super t)))
-	     char)
-	    (t (error "Meaningless character name ~A"
-		       charstring))))))
-
-(defun sharp-quote (stream ignore1 ignore2)
-  (declare (ignore ignore1 ignore2))
-  ;; 4th arg tells read that this is a recrusive call.
-  `(function ,(read stream () () t)))
-
-(defun sharp-left-paren (stream ignore length)
-  (declare (ignore ignore))
-  (declare (special *backquote-count*))
-  (let* ((list (read-list stream nil))
-	 (listlength (length list)))
-    (declare (list list)
-	     (fixnum listlength))
-    (cond (*read-suppress*)
-	  ((zerop *backquote-count*)
-	   (if length
-	       (cond ((> listlength (the fixnum length))
-		      (error
-		       "Vector longer than specified length: #~S~S"
-		       length list))
-		     (t
-		      (fill (the simple-vector
-				 (replace (the simple-vector (make-array length))
-					  list))
-			    (car (last list))
-			    :start listlength)))
-	       (coerce list 'vector)))
-	  (t (cons *bq-vector-flag* list)))))
-
-(defun sharp-star (stream ignore numarg)
-  (declare (ignore ignore))
-  (multiple-value-bind (bstring escape-appearedp)
-		       (read-extended-token stream)
-    (declare (simple-string bstring))
-    (cond (*read-suppress*)
-	  (escape-appearedp
-	   (error "Escape character appeared after #*"))
-	  ((and numarg (zerop (length bstring)) (not (zerop numarg)))
-	   (error "You have to give a little bit for non-zero #* bit-vectors."))
-	  ((or (null numarg) (>= (the fixnum numarg) (length bstring)))
-	   (let* ((len1 (length bstring))
-		  (last1 (1- len1))
-		  (len2 (or numarg len1))
-		  (bvec (make-array len2 :element-type 'bit
-				    :initial-element 0)))
-	     (declare (fixnum len1 last1 len2))
-	     (do ((i 0 (1+ i))
-		  (char ()))
-		 ((= i len2))
-	       (declare (fixnum i))
-	       (setq char (elt bstring (if (< i len1) i last1)))
-	       (setf (elt bvec i)
-		     (cond ((char= char #\0) 0)
-			   ((char= char #\1) 1)
-			   (t
-			    (error "Illegal element given for ~
-					  bitvector #~A*~A"
-				    numarg bstring)))))
-	     bvec))
-	  (t
-	   (error "Bit vector is longer than specified length #~A*~A"
-		   numarg bstring)))))
-
-
-(defun sharp-colon (stream ignore1 ignore2)
-  (declare (ignore ignore1 ignore2))
-  (when *read-suppress*
-	(read stream () () t)
-	(return-from sharp-colon nil))
-  (let ((token (read-extended-token stream)))
-    (declare (simple-string token))
-    (cond (*read-suppress*)
-	  ((find #\: token)
-	   (error "Symbol following #: contains a #\: ~S" token))
-	  ((eql (length token) 0)
-	   (let ((ch (read-char stream nil nil t)))
-	     (if ch
-		 (error "Illegal terminating character after a colon, ~S." ch)
-		 (error "Illegal terminating character after a colon."))))
-	  (T (make-symbol token)))))
-
-(defun sharp-dot (stream ignore1 ignore2)
-  (declare (ignore ignore1 ignore2))
-  (let ((token (read stream () () t)))
-    (unless *read-suppress*  (eval token))))
-
-(defun sharp-comma (stream ignore1 ignore2)
-  (declare (ignore ignore1 ignore2))
-  (let ((token (read stream () () t)))
-    (unless *read-suppress*  (eval token))))
-
-(defun sharp-R (stream ignore radix)
-  (declare (ignore ignore))
-  (multiple-value-bind (token escape-appearedp)
-		       (read-extended-token stream)
-    (declare (simple-string token))
-    (when *read-suppress* (return-from sharp-R nil))
-    (let ((numval 0) (denval 0) (resttok 0) (toklength (length token))
-	  (sign 1))
-      (declare (fixnum toklength))
-      (if escape-appearedp
-	  (error "Escape character appears in number."))
-      ;;look for leading sign
-      (let ((firstchar (elt token 0)))
-	(cond ((char= firstchar #\-)
-	       (setq sign -1)
-	       (setq resttok 1))
-	      ((char= firstchar #\+)
-	       (setq resttok 1))))
-      ;;read numerator
-      (do ((position resttok (1+ position))
-	   (dig ()))
-	  ((or (>= position toklength)
-	       (not (setq dig (digit-char-p (elt token position) radix))))
-	   (setq resttok position))
-	(setq numval (+ (* numval radix) dig)))
-      ;;see if we're at the end.
-      (cond ((>= resttok toklength)
-	     ;;just return numerator -- that's all there is.
-	     (* numval sign))
-	    ((char= (elt token resttok) #\/)
-	     ;;it's a ratio.
-	     (do ((position (1+ resttok) (1+ position))
-		  (dig ())
-		  (retval ()))
-		 ((cond ((>= position toklength)
-			 (setq retval (/ (* numval sign) denval)))
-			((not (setq dig (digit-char-p (elt token position)
-						     radix)))
-			 ;;there's bogus stuff at the end
-			 (error
-				 "Illegal digits ~S for radix ~S" token radix)
-			 (setq retval (/ (* numval sign) denval)))
-			;;continue looping
-			(t nil))
-		  retval)
-	       (setq denval (+ (* denval radix) dig))))
-	    ;;it's bogus
-	    (t (error
-		       "Illegal digits ~S for radix ~S" token radix)))))))
-
-(defun sharp-B (stream ignore1 ignore2)
-  (declare (ignore ignore1 ignore2))
-  (sharp-r stream nil 2))
-
-(defun sharp-O (stream ignore1 ignore2)
-  (declare (ignore ignore1 ignore2))
-  (sharp-r stream nil 8))
-
-(defun sharp-X (stream ignore1 ignore2)
-  (declare (ignore ignore1 ignore2))
-  (sharp-r stream nil 16))
-
-(defun sharp-A (stream ignore dimensions)
-  (declare (ignore ignore))
-  (when *read-suppress*
-    (read stream () () t)
-    (return-from sharp-A nil))
-  (unless dimensions (error "No dimensions argument to #A."))
-  (unless (and (integerp dimensions) (>= dimensions 0))
-    (error "Dimensions argument to #A not a non-negative integer: ~S"
-	   dimensions))
-  (if (> dimensions 0)
-      (let ((dlist (make-list dimensions))
-	    (init-list
-	     (if (char= (read-char stream t) #\( #|)|#)
-		 (read-list stream nil)
-		 (error "Array values must be a list."))))
-	(do ((dl dlist (cdr dl))
-	     (il init-list (car il)))
-	    ;; I think the nreverse is causing the problem.
-	    ((null dl))
-	    (if (listp il)
-		(rplaca dl (length il))
-		(error
-		 "Initial contents for #A is inconsistent with ~
-		 dimensions: #~SA~S" dimensions init-list)))
-	(make-array dlist :initial-contents init-list))
-      (make-array nil :initial-element (read stream t nil t))))
-
-
-(defun sharp-S (stream ignore1 ignore2)
-  (declare (ignore ignore1 ignore2))
-  ;;this needs to know about defstruct implementation
-  (when *read-suppress*
-	(read stream () () t)
-	(return-from sharp-S nil))
-  (let ((body
-	 (if (char= (read-char stream t) #\( )
-	     (read-list stream nil)
-	     (error "Non-list following #S"))))
-    (cond ((listp body)
-	   (unless (symbolp (car body))
-	     (error "Structure type is not a symbol: ~S" (car body)))
-	   (let ((defstruct (info type defined-structure-info (car body))))
-	     (unless defstruct
-	       (error "~S is not a defined structure type." (car body)))
-	     (unless (c::dd-constructor defstruct)
-	       (error "The ~S structure does not have a default constructor." (car body)))
-	     (do ((arg (cdr body) (cddr arg))
-		  (res ()))
-		 ((endp arg) (apply (c::dd-constructor defstruct) res))
-	       (push (cadr arg) res)
-	       (push (intern (string (car arg)) *keyword-package*) res))))
-	  (t (error "Non-list following #S: ~S" body))))))
-
-(defmacro int-subst-array (new old array rank var-list)
-  (if (> rank (array-rank array))
-      (let ((new-list (nreverse var-list)))
-       `(if (eq ,old (aref ,array ,@new-list))
-	    (setf (aref ,array ,@new-list) ,new)))
-       (let ((newvar (gensym)))
-	   `(dotimes (,newvar (array-dimension ,array ,rank))
-	      (int-subst-array ,new ,old ,array (1+ ,rank)
-			       (push ,newvar ,var-list))))))
-
-(defmacro subst-array (new old array)
-  `(int-subst-array ,new ,old ,array 0 nil))
-
-(defvar sharp-cons-table ()
-  "Holds the cons cells seen already by circle-subst")
-
-;; This function is the same as nsubst, except that it checks for circular
-;; lists. the first arg is an alist of the things to be replaced assoc'd with
-;; the things to replace them.
-(defun circle-subst (old-new-alist tree)
-  (cond ((and (atom tree)
-	      (not (and (arrayp tree)
-			(eq (array-element-type tree) t))))
-	 (let ((pair (assq tree old-new-alist)))
-	   (if pair (cdr pair) tree)))
-	((null (gethash tree sharp-cons-table))
-	 (setf (gethash tree sharp-cons-table) t)
-	 (cond ((simple-vector-p tree)
-		(do ((i 0 (1+ i))
-		     (len (length tree)))
-		    ((>= i len))
-		  (declare (fixnum i len))
-		  (setf (svref tree i)
-			(circle-subst old-new-alist (svref tree i))))
-		tree)
-	       ((arrayp tree)
-		(with-array-data ((data tree) (start) (end))
-		  (declare (fixnum start end))
-		  (do ((i start (1+ i)))
-		      ((>= i end))
-		    (setf (aref data i)
-			  (circle-subst old-new-alist (aref data i)))))
-		tree)
-	       (T (let ((a (circle-subst old-new-alist (car tree)))
-			(d (circle-subst old-new-alist (cdr tree))))
-		    (if (eq a (car tree))
-			tree
-			(rplaca tree a))
-		    (if (eq d (cdr tree))
-			tree
-			(rplacd tree d)))
-		  tree)))
-	(t tree)))
-
-;; Sharp-equal works as follows.  When a label is assigned
-;; (ie when #= is called) a symbol (ref) is gensym'd and
-;; a cons cell whose car is the label, and cdr is the symbol
-;; is put on the sharp-sharp alist.  When sharp-sharp encounters
-;; a reference to a label it returns the symbol assoc'd with the label.
-;; When an object has been read then a cons cell whose car is the symbol
-;; and cdr is the object is pushed onto the sharp-sharp-alist.  Then
-;; for each cons cell on the sharp-sharp-alist, the current object is searched
-;; and where a symbol eq to the car of the current cons cell is found,
-;; the object is substituted in.
-(defun sharp-equal (stream ignore label &aux (ref (gensym)))
-  (declare (ignore ignore))
-  (declare (special sharp-equal-alist sharp-sharp-alist))
-  (when *read-suppress* (return-from sharp-equal (values)))
-  (unless (integerp label)
-	  (error "non-integer label #~S=" label))
-  (push (cons label ref) sharp-sharp-alist)
-  (let ((obj (read stream () () t)))
-    (push (cons ref obj) sharp-equal-alist)
-    (clrhash sharp-cons-table)
-    (circle-subst sharp-equal-alist obj)))
-
-(defun sharp-sharp (ignore1 ignore2 label)
-  (declare (ignore ignore1 ignore2))
-  (declare (special sharp-equal-alist sharp-sharp-alist))
-  (when *read-suppress* (return-from sharp-sharp nil))
-  (if (integerp label)
-      (let ((pair (assoc label sharp-sharp-alist)))
-	(if pair
-	    (let ((ret-obj (cdr (assoc (cdr pair) sharp-equal-alist))))
-	      (if ret-obj ret-obj
-		  (cdr pair)))
-	    (error "Object is not labelled #~S#" label)))
-      (error "Non-integer label #~S#" label)))
-
-(defun sharp-plus (stream ignore1 ignore2)
-  (declare (ignore ignore1 ignore2))
-  (cond (*read-suppress*
-	 (read stream () () t)
-	 (values))
-	((featurep (let ((*package* *keyword-package*))
-		     (read stream () () t)))
-	 (read stream () () t))
-	(t (let ((*read-suppress* t))
-	     (read stream () () t)
-	     (values)))))
-
-(defun sharp-minus (stream ignore1 ignore2)
-  (declare (ignore ignore1 ignore2))
-  (cond (*read-suppress*
-	 (read stream () () t)
-	 (values))
-	((not (featurep (let ((*package* *keyword-package*))
-			  (read stream () () t))))
-	 (read stream () () t))
-	(t (let ((*read-suppress* t))      
-	     (read stream () () t)
-	     (values)))))
-
-(defun sharp-C (stream ignore1 ignore2)
-  (declare (ignore ignore1 ignore2))
-  ;;next thing better be a list of two numbers.
-  (let ((cnum (read stream () () t)))
-    (when *read-suppress* (return-from sharp-c nil))
-    (if (= (length cnum) 2)
-	(complex (car cnum) (cadr cnum))
-	(error "Illegal complex number format" cnum))))
-
-(defun sharp-vertical-bar (stream ignore1 ignore2)
-  (declare (ignore ignore1 ignore2))
-  (prepare-for-fast-read-char stream
-    (do ((level 1)
-	 (prev (fast-read-char) char)
-	 (char (fast-read-char) (fast-read-char)))
-	(())
-      (cond ((and (char= prev #\|) (char= char #\#))
-	     (setq level (1- level))
-	     (when (zerop level)
-	       (done-with-fast-read-char)
-	       (return (values)))
-	     (setq char (fast-read-char)))
-	    ((and (char= prev #\#) (char= char #\|))
-	     (setq char (fast-read-char))
-	     (setq level (1+ level)))))))
-
-(defun sharp-illegal (ignore1 sub-char ignore2)
-  (declare (ignore ignore1 ignore2))
-  (error "Illegal sharp character ~S" sub-char))
-
-
-(defun sharp-init ()
-  (declare (special std-lisp-readtable))
-  (setq sharp-cons-table (make-hash-table :size 50))
-  (let ((*readtable* std-lisp-readtable))
-    (make-dispatch-macro-character #\#)
-    (set-dispatch-macro-character #\# #\\ #'sharp-backslash)
-    (set-dispatch-macro-character #\# #\' #'sharp-quote)
-    (set-dispatch-macro-character #\# #\( #'sharp-left-paren)
-    (set-dispatch-macro-character #\# #\* #'sharp-star)
-    (set-dispatch-macro-character #\# #\: #'sharp-colon)
-    (set-dispatch-macro-character #\# #\. #'sharp-dot)
-    (set-dispatch-macro-character #\# #\, #'sharp-comma)
-    (set-dispatch-macro-character #\# #\R #'sharp-R)
-    (set-dispatch-macro-character #\# #\r #'sharp-R)
-    (set-dispatch-macro-character #\# #\B #'sharp-B)
-    (set-dispatch-macro-character #\# #\b #'sharp-B)
-    (set-dispatch-macro-character #\# #\O #'sharp-O)
-    (set-dispatch-macro-character #\# #\o #'sharp-O)
-    (set-dispatch-macro-character #\# #\X #'sharp-X)
-    (set-dispatch-macro-character #\# #\x #'sharp-X)
-    (set-dispatch-macro-character #\# #\A #'sharp-A)
-    (set-dispatch-macro-character #\# #\a #'sharp-A)
-    (set-dispatch-macro-character #\# #\S #'sharp-S)
-    (set-dispatch-macro-character #\# #\s #'sharp-S)
-    (set-dispatch-macro-character #\# #\= #'sharp-equal)
-    (set-dispatch-macro-character #\# #\# #'sharp-sharp)
-    (set-dispatch-macro-character #\# #\+ #'sharp-plus)
-    (set-dispatch-macro-character #\# #\- #'sharp-minus)
-    (set-dispatch-macro-character #\# #\C #'sharp-C)
-    (set-dispatch-macro-character #\# #\c #'sharp-C)
-    (set-dispatch-macro-character #\# #\| #'sharp-vertical-bar)
-    (set-dispatch-macro-character #\# #\tab #'sharp-illegal)
-    (set-dispatch-macro-character #\# #\  #'sharp-illegal)
-    (set-dispatch-macro-character #\# #\) #'sharp-illegal)
-    (set-dispatch-macro-character #\# #\< #'sharp-illegal)
-    (set-dispatch-macro-character #\# #\form #'sharp-illegal)
-    (set-dispatch-macro-character #\# #\return #'sharp-illegal)))
diff --git a/code/sort.lisp b/code/sort.lisp
deleted file mode 100644
index c1183a566d3e73f81d982c8bae986060160b1ad9..0000000000000000000000000000000000000000
--- a/code/sort.lisp
+++ /dev/null
@@ -1,442 +0,0 @@
-;;; -*- Log: code.log; Package: Lisp -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at 
-;;; Carnegie-Mellon University, and has been placed in the public domain.  
-;;; If you want to use this code or any part of Spice Lisp, please contact 
-;;; Scott Fahlman (FAHLMAN@CMUC).  
-;;; ********************************************************************** 
-;;;
-;;; Sort functions for Spice Lisp 
-;;;   these functions are part of the standard spice lisp environment.  
-;;; 
-;;; Written by Jim Large 
-;;; Hacked on and maintained by Skef Wholey 
-;;; Rewritten by Bill Chiles
-;;;
-;;; *******************************************************************
-
-(in-package 'lisp)
-
-(export '(sort stable-sort merge))
-
-
-
-(defun sort (sequence predicate &key key)
-  "Destructively sorts sequence.  Predicate should returns non-Nil if
-   Arg1 is to precede Arg2."
-  (typecase sequence
-    (simple-vector
-     (if (> (the fixnum (length (the simple-vector sequence))) 0)
-	 (sort-simple-vector sequence predicate key)
-	 sequence))
-    (list
-     (sort-list sequence predicate key))
-    (vector
-     (if (> (the fixnum (length sequence)) 0)
-	 (sort-vector sequence predicate key)
-	 sequence))
-    (t
-     (error "~S is not a sequence." sequence))))
-
-
-
-;;; Sorting Vectors
-
-;;; Sorting is done with a heap sort.
-
-(eval-when (compile eval)
-
-;;; HEAPIFY, assuming both sons of root are heaps, percolates the root element
-;;; through the sons to form a heap at root.  Root and max are zero based
-;;; coordinates, but the heap algorithm only works on arrays indexed from 1
-;;; through N (not 0 through N-1); This is because a root at I has sons at 2*I
-;;; and 2*I+1 which does not work for a root at 0.  Because of this, boundaries,
-;;; roots, and termination are computed using 1..N indexes.
-
-(defmacro heapify (seq vector-ref root max pred key)
-  (let ((heap-root (gensym))   (heap-max (gensym))     (root-ele (gensym))
-	(root-key (gensym))    (heap-max/2 (gensym))   (heap-l-son (gensym))
-	(one-son (gensym))     (one-son-ele (gensym))  (one-son-key (gensym))
-	(r-son-ele (gensym))   (r-son-key (gensym))    (var-root (gensym)))
-    `(let* ((,var-root ,root) ; necessary to not clobber calling root var.
-	    (,heap-root (1+ ,root))
-	    (,heap-max (1+ ,max))
-	    (,root-ele (,vector-ref ,seq ,root))
-	    (,root-key (apply-key ,key ,root-ele))
-	    (,heap-max/2 (ash ,heap-max -1))) ; (floor heap-max 2)
-       (declare (fixnum ,var-root ,heap-root ,heap-max ,heap-max/2))
-       (loop
-	(if (> ,heap-root ,heap-max/2) (return))
-	(let* ((,heap-l-son (ash ,heap-root 1)) ; (* 2 heap-root)
-	       ;; l-son index in seq (0..N-1) is one less than heap computation
-	       (,one-son (1- ,heap-l-son))
-	       (,one-son-ele (,vector-ref ,seq ,one-son))
-	       (,one-son-key (apply-key ,key ,one-son-ele)))
-	  (declare (fixnum ,heap-l-son ,one-son))
-	  (if (< ,heap-l-son ,heap-max)
-	      ;; there is a right son.
-	      (let* ((,r-son-ele (,vector-ref ,seq ,heap-l-son))
-		     (,r-son-key (apply-key ,key ,r-son-ele)))
-		;; choose the greater of the two sons.
-		(when (funcall ,pred ,one-son-key ,r-son-key)
-		  (setf ,one-son ,heap-l-son)
-		  (setf ,one-son-ele ,r-son-ele)
-		  (setf ,one-son-key ,r-son-key))))
-	  ;; if greater son is less than root, then we've formed a heap again.
-	  (if (funcall ,pred ,one-son-key ,root-key) (return))
-	  ;; else put greater son at root and make greater son node be the root.
-	  (setf (,vector-ref ,seq ,var-root) ,one-son-ele)
-	  (setf ,heap-root (1+ ,one-son)) ; one plus to be in heap coordinates.
-	  (setf ,var-root ,one-son)))     ; actual index into vector for root ele.
-       ;; now really put percolated value into heap at the appropriate root node.
-       (setf (,vector-ref ,seq ,var-root) ,root-ele))))
-
-
-;;; BUILD-HEAP rearranges seq elements into a heap to start heap sorting.
-(defmacro build-heap (seq type len-1 pred key)
-  (let ((i (gensym)))
-    `(do ((,i (floor ,len-1 2) (1- ,i)))
-	 ((minusp ,i) ,seq)
-       (declare (fixnum ,i))
-       (heapify ,seq ,type ,i ,len-1 ,pred ,key))))
-
-) ; eval-when
-
-
-;;; Make simple-vector and miscellaneous vector sorting functions.
-(macrolet ((frob-rob (fun-name vector-ref)
-	     `(defun ,fun-name (seq pred key)
-		(let ((len-1 (1- (length (the vector seq)))))
-		  (declare (fixnum len-1))
-		  (build-heap seq ,vector-ref len-1 pred key)
-		  (do* ((i len-1 i-1)
-			(i-1 (1- i) (1- i-1)))
-		       ((zerop i) seq)
-		    (declare (fixnum i i-1))
-		    (rotatef (,vector-ref seq 0) (,vector-ref seq i))
-		    (heapify seq ,vector-ref 0 i-1 pred key))))))
-
-  (frob-rob sort-vector aref)
-
-  (frob-rob sort-simple-vector svref))
-
-
-
-;;;; Stable Sorting
-
-(defun stable-sort (sequence predicate &key key)
-  "Destructively sorts sequence.  Predicate should returns non-Nil if
-   Arg1 is to precede Arg2."
-  (typecase sequence
-    (simple-vector
-     (stable-sort-simple-vector sequence predicate key))
-    (list
-     (sort-list sequence predicate key))
-    (vector
-     (stable-sort-vector sequence predicate key))
-    (t
-     (error "~S is not a sequence." sequence))))
-
-
-;;; Stable Sorting Lists
-
-
-;;; SORT-LIST uses a bottom up merge sort.  First a pass is made over
-;;; the list grabbing one element at a time and merging it with the next one
-;;; form pairs of sorted elements.  Then n is doubled, and elements are taken
-;;; in runs of two, merging one run with the next to form quadruples of sorted
-;;; elements.  This continues until n is large enough that the inner loop only
-;;; runs for one iteration; that is, there are only two runs that can be merged,
-;;; the first run starting at the beginning of the list, and the second being
-;;; the remaining elements.
-
-(defun sort-list (list pred key)
-  (let ((head (cons :header list))  ; head holds on to everything
-	(n 1)                       ; bottom-up size of lists to be merged
-	unsorted		    ; unsorted is the remaining list to be
-				    ;   broken into n size lists and merged
-	list-1			    ; list-1 is one length n list to be merged
-	last)			    ; last points to the last visited cell
-    (declare (fixnum n))
-    (loop
-     ;; start collecting runs of n at the first element
-     (setf unsorted (cdr head))
-     ;; tack on the first merge of two n-runs to the head holder
-     (setf last head)
-     (let ((n-1 (1- n)))
-       (declare (fixnum n-1))
-       (loop
-	(setf list-1 unsorted)
-	(let ((temp (nthcdr n-1 list-1))
-	      list-2)
-	  (cond (temp
-		 ;; there are enough elements for a second run
-		 (setf list-2 (cdr temp))
-		 (setf (cdr temp) nil)
-		 (setf temp (nthcdr n-1 list-2))
-		 (cond (temp
-			(setf unsorted (cdr temp))
-			(setf (cdr temp) nil))
-		       ;; the second run goes off the end of the list
-		       (t (setf unsorted nil)))
-		 (multiple-value-bind (merged-head merged-last)
-				      (merge-lists* list-1 list-2 pred key)
-		   (setf (cdr last) merged-head)
-		   (setf last merged-last))
-		 (if (null unsorted) (return)))
-		;; if there is only one run, then tack it on to the end
-		(t (setf (cdr last) list-1)
-		   (return)))))
-       (setf n (ash n 1)) ; (+ n n)
-       ;; If the inner loop only executed once, then there were only enough
-       ;; elements for two runs given n, so all the elements have been merged
-       ;; into one list.  This may waste one outer iteration to realize.
-       (if (eq list-1 (cdr head))
-	   (return list-1))))))
-
-
-;;; APPLY-PRED saves us a function call sometimes.
-(eval-when (compile eval)
-  (defmacro apply-pred (one two pred key)
-    `(if ,key
-	 (funcall ,pred (funcall ,key ,one)
-		  (funcall ,key  ,two))
-	 (funcall ,pred ,one ,two)))
-) ; eval-when
-
-(defvar *merge-lists-header* (list :header))
-
-;;; MERGE-LISTS*   originally written by Jim Large.
-;;; 		   modified to return a pointer to the end of the result
-;;; 		      and to not cons header each time its called.
-;;; It destructively merges list-1 with list-2.  In the resulting
-;;; list, elements of list-2 are guaranteed to come after equal elements
-;;; of list-1.
-(defun merge-lists* (list-1 list-2 pred key)
-  (do* ((result *merge-lists-header*)
-	(P result))                            ; P points to last cell of result
-       ((or (null list-1) (null list-2))       ; done when either list used up	
-	(if (null list-1)                      ; in which case, append the
-	    (rplacd p list-2)                  ;   other list
-	    (rplacd p list-1))
-	(do ((drag p lead)
-	     (lead (cdr p) (cdr lead)))
-	    ((null lead)
-	     (values (prog1 (cdr result)       ; return the result sans header
-			    (rplacd result nil)) ; (free memory, be careful)
-		     drag))))		       ; and return pointer to last element
-    (cond ((apply-pred (car list-2) (car list-1) pred key)
-	   (rplacd p list-2)           ; append the lesser list to last cell of
-	   (setq p (cdr p))            ;   result.  Note: test must bo done for
-	   (pop list-2))               ;   list-2 < list-1 so merge will be
-	  (T (rplacd p list-1)         ;   stable for list-1
-	     (setq p (cdr p))
-	     (pop list-1)))))
-
-
-
-;;; Stable Sort Vectors
-
-;;; Stable sorting vectors is done with the same algorithm used for lists,
-;;; using a temporary vector to merge back and forth between it and the
-;;; given vector to sort.
-
-
-(eval-when (compile eval)
-
-;;; STABLE-SORT-MERGE-VECTORS* takes a source vector with subsequences,
-;;;    start-1 (inclusive) ... end-1 (exclusive) and
-;;;    end-1 (inclusive) ... end-2 (exclusive),
-;;; and merges them into a target vector starting at index start-1.
-
-(defmacro stable-sort-merge-vectors* (source target start-1 end-1 end-2
-					     pred key source-ref target-ref)
-  (let ((i (gensym))
-	(j (gensym))
-	(target-i (gensym)))
-    `(let ((,i ,start-1)
-	   (,j ,end-1) ; start-2
-	   (,target-i ,start-1))
-       (declare (fixnum ,i ,j ,target-i))
-       (loop
-	(cond ((= ,i ,end-1)
-	       (loop (if (= ,j ,end-2) (return))
-		     (setf (,target-ref ,target ,target-i)
-			   (,source-ref ,source ,j))
-		     (incf ,target-i)
-		     (incf ,j))
-	       (return))
-	      ((= ,j ,end-2)
-	       (loop (if (= ,i ,end-1) (return))
-		     (setf (,target-ref ,target ,target-i)
-			   (,source-ref ,source ,i))
-		     (incf ,target-i)
-		     (incf ,i))
-	       (return))
-	      ((apply-pred (,source-ref ,source ,j)
-			   (,source-ref ,source ,i)
-			   ,pred ,key)
-	       (setf (,target-ref ,target ,target-i)
-		     (,source-ref ,source ,j))
-	       (incf ,j))
-	      (t (setf (,target-ref ,target ,target-i)
-		       (,source-ref ,source ,i))
-		 (incf ,i)))
-	(incf ,target-i)))))
-
-
-;;; VECTOR-MERGE-SORT is the same algorithm used to stable sort lists, but
-;;; it uses a temporary vector.  Direction determines whether we are merging
-;;; into the temporary (T) or back into the given vector (NIL).
-
-(defmacro vector-merge-sort (vector pred key vector-ref)
-  (let ((vector-len (gensym)) 		(n (gensym))
-	(direction (gensym)) 		(unsorted (gensym))
-	(start-1 (gensym)) 		(end-1 (gensym))
-	(end-2 (gensym)) 		(temp-len (gensym))
-	(i (gensym)))
-    `(let ((,vector-len (length (the vector ,vector)))
-	   (,n 1)         ; bottom-up size of contiguous runs to be merged
-	   (,direction t) ; t vector --> temp    nil temp --> vector
-	   (,temp-len (length (the simple-vector *merge-sort-temp-vector*)))
-	   (,unsorted 0)  ; unsorted..vector-len are the elements that need
-			  ; to be merged for a given n
-	   (,start-1 0))  ; one n-len subsequence to be merged with the next
-       (declare (fixnum ,vector-len ,n ,temp-len ,unsorted ,start-1))
-       (if (> ,vector-len ,temp-len)
-	   (setf *merge-sort-temp-vector*
-		 (make-array (max ,vector-len (+ ,temp-len ,temp-len)))))
-       (loop
-	;; for each n, we start taking n-runs from the start of the vector
-	(setf ,unsorted 0)
-	(loop
-	 (setf ,start-1 ,unsorted)
-	 (let ((,end-1 (+ ,start-1 ,n)))
-	   (declare (fixnum ,end-1))
-	   (cond ((< ,end-1 ,vector-len)
-		  ;; there are enough elements for a second run
-		  (let ((,end-2 (+ ,end-1 ,n)))
-		    (declare (fixnum ,end-2))
-		    (if (> ,end-2 ,vector-len) (setf ,end-2 ,vector-len))
-		    (setf ,unsorted ,end-2)
-		    (if ,direction
-			(stable-sort-merge-vectors*
-			 ,vector *merge-sort-temp-vector*
-			 ,start-1 ,end-1 ,end-2 ,pred ,key ,vector-ref svref)
-			(stable-sort-merge-vectors*
-			 *merge-sort-temp-vector* ,vector
-			 ,start-1 ,end-1 ,end-2 ,pred ,key svref ,vector-ref))
-		    (if (= ,unsorted ,vector-len) (return))))
-		 ;; if there is only one run, copy those elements to the end
-		 (t (if ,direction
-			(do ((,i ,start-1 (1+ ,i)))
-			    ((= ,i ,vector-len))
-			  (declare (fixnum ,i))
-			  (setf (svref *merge-sort-temp-vector* ,i)
-				(,vector-ref ,vector ,i)))
-			(do ((,i ,start-1 (1+ ,i)))
-			    ((= ,i ,vector-len))
-			  (declare (fixnum ,i))
-			  (setf (,vector-ref ,vector ,i)
-				(svref *merge-sort-temp-vector* ,i))))
-		    (return)))))
-	;; If the inner loop only executed once, then there were only enough
-	;; elements for two subsequences given n, so all the elements have
-	;; been merged into one list.  Start-1 will have remained 0 upon exit.
-	(when (zerop ,start-1)
-	  (if ,direction
-	      ;; if we just merged into the temporary, copy it all back
-	      ;; to the given vector.
-	      (dotimes (,i ,vector-len)
-		(setf (,vector-ref ,vector ,i)
-		      (svref *merge-sort-temp-vector* ,i))))
-	  (return ,vector))
-	(setf ,n (ash ,n 1)) ; (* 2 n)
-	(setf ,direction (not ,direction))))))
-
-) ; eval-when
-
-
-;;; Temporary vector for stable sorting vectors.
-(defvar *merge-sort-temp-vector*
-  (make-array 50))
-
-(proclaim '(simple-vector *merge-sort-temp-vector*))
-
-(defun stable-sort-simple-vector (vector pred key)
-  (declare (simple-vector vector))
-  (vector-merge-sort vector pred key svref))
-
-(defun stable-sort-vector (vector pred key)
-  (vector-merge-sort vector pred key aref))
-
-
-
-;;;; Merge
-
-(eval-when (compile eval)
-
-;;; MERGE-VECTORS returns a new vector which contains an interleaving
-;;; of the elements of vector-1 and vector-2.  Elements from vector-2 are
-;;; chosen only if they are strictly less than elements of vector-1,
-;;; (pred elt-2 elt-1), as specified in the manual.
-
-(defmacro merge-vectors (vector-1 length-1 vector-2 length-2
-			 result-vector pred key access)
-  (let ((result-i (gensym))
-	(i (gensym))
-	(j (gensym)))
-    `(let* ((,result-i 0)
-	    (,i 0)
-	    (,j 0))
-       (declare (fixnum ,result-i ,i ,j))
-       (loop
-	(cond ((= ,i ,length-1)
-	       (loop (if (= ,j ,length-2) (return))
-		     (setf (,access ,result-vector ,result-i)
-			   (,access ,vector-2 ,j))
-		     (incf ,result-i)
-		     (incf ,j))
-	       (return ,result-vector))
-	      ((= ,j ,length-2)
-	       (loop (if (= ,i ,length-1) (return))
-		     (setf (,access ,result-vector ,result-i)
-			   (,access ,vector-1 ,i))
-		     (incf ,result-i)
-		     (incf ,i))
-	       (return ,result-vector))
-	      ((apply-pred (,access ,vector-2 ,j) (,access ,vector-1 ,i)
-			   ,pred ,key)
-	       (setf (,access ,result-vector ,result-i)
-		     (,access ,vector-2 ,j))
-	       (incf ,j))
-	      (t (setf (,access ,result-vector ,result-i)
-		       (,access ,vector-1 ,i))
-		 (incf ,i)))
-	(incf ,result-i)))))
-
-) ; eval-when
-
-(defun merge (result-type sequence1 sequence2 predicate &key key)
-  "The sequences Sequence1 and Sequence2 are destructively merged into
-   a sequence of type Result-Type using the Predicate to order the elements."
-  (if (eq result-type 'list)
-      (let ((result (merge-lists* (coerce sequence1 'list)
-				  (coerce sequence2 'list)
-				  predicate key)))
-	result)
-      (let* ((vector-1 (coerce sequence1 'vector))
-	     (vector-2 (coerce sequence2 'vector))
-	     (length-1 (length vector-1))
-	     (length-2 (length vector-2))
-	     (result (make-sequence-of-type result-type (+ length-1 length-2))))
-	(declare (vector vector-1 vector-2)
-		 (fixnum length-1 length-2))
-	(if (and (simple-vector-p result)
-		 (simple-vector-p vector-1)
-		 (simple-vector-p vector-2))
-	    (merge-vectors vector-1 length-1 vector-2 length-2
-			   result predicate key svref)
-	    (merge-vectors vector-1 length-1 vector-2 length-2
-			   result predicate key aref)))))
diff --git a/code/stream.lisp b/code/stream.lisp
deleted file mode 100644
index 438aa6ee09ea9d53ca86a65a79135ef1e0e22790..0000000000000000000000000000000000000000
--- a/code/stream.lisp
+++ /dev/null
@@ -1,1050 +0,0 @@
-;;; -*- Log: code.log; Package: Lisp -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; Stream functions for Spice Lisp.
-;;; Written by Skef Wholey and Rob MacLachlan.
-;;;
-;;; This file contains the machine-independent stream functions.  Another
-;;; file (VAXIO, SPIO, or VMIO) contains functions used by this file for
-;;; a specific machine.
-;;;
-(in-package "LISP")
-
-(export '(make-broadcast-stream make-synonym-stream
-	  make-broadcast-stream make-concatenated-stream make-two-way-stream
-	  make-echo-stream make-string-input-stream make-string-output-stream
-	  get-output-stream-string stream-element-type input-stream-p
-	  output-stream-p close read-line read-char
-	  unread-char peek-char listen read-char-no-hang clear-input read-byte
-	  write-char write-string write-line terpri fresh-line
-	  finish-output force-output clear-output write-byte
-          stream streamp *standard-input* *standard-output*
-          *error-output* *query-io* *debug-io* *terminal-io* *trace-output*))
-
-(in-package 'system)
-(export '(make-indenting-stream read-n-bytes))
-(in-package 'lisp)
-
-;;;; Standard streams:
-;;;
-;;; The initialization of these streams is performed by Stream-Init,
-;;; which lives in the file of machine-specific stream functions.
-;;;
-(defvar *terminal-io* () "Terminal I/O stream.")
-(defvar *standard-input* () "Default input stream.")
-(defvar *standard-output* () "Default output stream.")
-(defvar *error-output* () "Error output stream.")
-(defvar *query-io* () "Query I/O stream.")
-(defvar *trace-output* () "Trace output stream.")
-(defvar *debug-io* () "Interactive debugging stream.")
-
-(defun ill-in (stream &rest ignore)
-  (declare (ignore ignore))
-  (error "~S is not a character input stream." stream))
-(defun ill-out (stream &rest ignore)
-  (declare (ignore ignore))
-  (error "~S is not a character output stream." stream))
-(defun ill-bin (stream &rest ignore)
-  (declare (ignore ignore))
-  (error "~S is not a binary input stream." stream))
-(defun ill-bout (stream &rest ignore)
-  (declare (ignore ignore))
-  (error "~S is not a binary output stream." stream))
-(defun closed-flame (stream &rest ignore)
-  (declare (ignore ignore))
-  (error "~S is closed." stream))
-(defun do-nothing (&rest ignore)
-  (declare (ignore ignore)))
-
-(defun %print-stream (structure stream d)
-  (declare (ignore d structure))
-  (write-string "#<Bare Stream>" stream))
-
-;;; HOW THE STREAM STRUCTURE IS USED:
-;;;
-;;;    Many of the slots of the stream structure contain functions
-;;; which are called to perform some operation on the stream.  Closed
-;;; streams have #'Closed-Flame in all of their function slots.  If
-;;; one side of an I/O or echo stream is closed, the whole stream is
-;;; considered closed.  The functions in the operation slots take
-;;; arguments as follows:
-;;;
-;;; In:			Stream, Eof-Errorp, Eof-Value
-;;; Bin:		Stream, Eof-Errorp, Eof-Value
-;;; N-Bin:		Stream, Buffer, Start, Numbytes, Eof-Errorp
-;;; Out:		Stream, Character
-;;; Bout:		Stream, Integer
-;;; Sout:		Stream, String, Start, End
-;;; Misc:		Stream, Operation, &Optional Arg1, Arg2
-;;;
-;;;    In order to save space, some of the less common stream operations
-;;; are handled by just one function, the Misc method.  This function
-;;; is passed a keyword which indicates the operation to perform.
-;;; The following keywords are used:
-;;;  :read-line		- Do a read-line.
-;;;  :listen 		- Return true if any input waiting.
-;;;  :unread		- Unread the character Arg.
-;;;  :close		- Do any stream specific stuff to close the stream.
-;;;			  The methods are set to closed-flame by the close
-;;;			  function, so that need not be done by this
-;;;			  function.
-;;;  :clear-input 	- Clear any unread input
-;;;  :finish-output,
-;;;  :force-output	- Cause output to happen
-;;;  :clear-output	- Clear any undone output
-;;;  :element-type 	- Return the type of element the stream deals with.
-;;;  :line-length	- Return the length of a line of output.
-;;;  :charpos		- Return current output position on the line.
-;;;  :file-length	- Return the file length of a file stream.
-;;;  :file-position	- Return or change the current position of a file stream.
-;;;  :file-name		- Return the name of an associated file.
-;;;
-;;;    In order to do almost anything useful, it is necessary to
-;;; define a new type of structure that includes stream, so that the
-;;; stream can have some state information.
-;;;
-;;; THE STREAM IN-BUFFER:
-;;;
-;;;    The In-Buffer in the stream holds characters or bytes that
-;;; are ready to be read by some input function.  If there is any
-;;; stuff in the In-Buffer, then the reading function can use it
-;;; without calling any stream method.  Any stream may put stuff in
-;;; the In-Buffer, and may also assume that any input in the In-Buffer
-;;; has been consumed before any in-method is called.  If a text
-;;; stream has in In-Buffer, then the first character should not be
-;;; used to buffer normal input so that it is free for unreading into.
-;;;
-;;;    The In-Buffer slot is a vector In-Buffer-Length long.  The
-;;; In-Index is the index in the In-Buffer of the first available
-;;; object.  The available objects are thus between In-Index and the
-;;; length of the In-Buffer.
-;;;
-;;;    When this buffer is only accessed by the normal stream
-;;; functions, the number of function calls is halved, thus
-;;; potentially doubling the speed of simple operations.  If the
-;;; Fast-Read-Char and Fast-Read-Byte macros are used, nearly all
-;;; function call overhead is removed, vastly speeding up these
-;;; important operations.
-;;;
-;;;    If a stream does not have an In-Buffer, then the In-Buffer slot
-;;; must be nil, and the In-Index must be In-Buffer-Length.  These are
-;;; the default values for the slots. 
-
-;;; Stream manipulation functions.
-
-(defun input-stream-p (stream)
-  "Returns non-nil if the given Stream can perform input operations."
-  (and (streamp stream)
-       (not (eq (stream-in stream) #'closed-flame))
-       (or (not (eq (stream-in stream) #'ill-in))
-	   (not (eq (stream-bin stream) #'ill-bin)))))
-
-(defun output-stream-p (stream)
-  "Returns non-nil if the given Stream can perform output operations."
-  (and (streamp stream)
-       (not (eq (stream-in stream) #'closed-flame))
-       (or (not (eq (stream-out stream) #'ill-out))
-	   (not (eq (stream-bout stream) #'ill-bout)))))
-
-(defun stream-element-type (stream)
-  "Returns a type specifier for the kind of object returned by the Stream."
-  (if (streamp stream)
-      (funcall (stream-misc stream) stream :element-type)
-      (error "~S is not a stream." stream)))
-
-(defun close (stream &key abort)
-  "Closes the given Stream.  No more I/O may be performed, but inquiries
-  may still be made.  If :Abort is non-nil, an attempt is made to clean
-  up the side effects of having created the stream."
-  (if (streamp stream)
-      (unless (eq (stream-in stream) #'closed-flame)
-	(funcall (stream-misc stream) stream :close abort))
-      (error "~S is not a stream." stream))
-  t)
-
-(defun set-closed-flame (stream)
-  (setf (stream-in stream) #'closed-flame)
-  (setf (stream-bin stream) #'closed-flame)
-  (setf (stream-n-bin stream) #'closed-flame)
-  (setf (stream-in stream) #'closed-flame)
-  (setf (stream-out stream) #'closed-flame)
-  (setf (stream-bout stream) #'closed-flame)
-  (setf (stream-sout stream) #'closed-flame)
-  (setf (stream-misc stream) #'closed-flame))
-
-;;; Input functions:
-
-(defun read-line (&optional (stream *standard-input*) (eof-errorp t) eof-value
-			    recursive-p)
-  "Returns a line of text read from the Stream as a string, discarding the
-  newline character."
-  (declare (ignore recursive-p))
-  (let* ((stream (in-synonym-of stream))
-	 (buffer (stream-in-buffer stream))
-	 (index (stream-in-index stream)))
-    (declare (fixnum index))
-    (if (simple-string-p buffer)
-	(let ((nl (%primitive find-character buffer index in-buffer-length
-			      #\newline)))
-	  (if nl
-	      (values (prog1 (subseq (the simple-string buffer) index nl)
-			     (setf (stream-in-index stream) (1+ (the fixnum nl))))
-		      nil)
-	      (multiple-value-bind (str eofp)
-				   (funcall (stream-misc stream) stream
-					    :read-line eof-errorp eof-value)
-		(declare (simple-string str))
-		(if (= index in-buffer-length)
-		    (values str eofp)
-		    (values (prog1
-			     (concatenate 'simple-string
-					  (subseq buffer index in-buffer-length)
-					  str)
-			     (setf (stream-in-index stream) in-buffer-length))
-			    eofp)))))
-	(funcall (stream-misc stream) stream :read-line eof-errorp eof-value))))
-
-;;; We proclaim them inline here, then proclaim them notinline at EOF,
-;;; so, except in this file, they are not inline by default, but they can be.
-;;;
-(proclaim '(inline read-char unread-char read-byte listen))
-(defun read-char (&optional (stream *standard-input*) (eof-errorp t) eof-value
-			    recursive-p)
-  "Inputs a character from Stream and returns it."
-  (declare (ignore recursive-p))
-  (let* ((stream (in-synonym-of stream))
-	 (index (stream-in-index stream)))
-    (declare (fixnum index))
-    (if (eql index in-buffer-length)
-	(funcall (stream-in stream) stream eof-errorp eof-value)
-	(prog1 (aref (stream-in-buffer stream) index)
-	       (setf (stream-in-index stream) (1+ index))))))
-
-(defun unread-char (character &optional (stream *standard-input*))
-  "Puts the Character back on the front of the input Stream."
-  (let* ((stream (in-synonym-of stream))
-	 (index (1- (the fixnum (stream-in-index stream))))
-	 (buffer (stream-in-buffer stream)))
-    (declare (fixnum index))
-    (when (minusp index) (error "Nothing to unread."))
-    (if buffer
-	(setf (aref (the simple-array buffer) index) character
-	      (stream-in-index stream) index)
-	(funcall (stream-misc stream) stream :unread character)))
-  nil)
-
-(defun peek-char (&optional (peek-type nil) (stream *standard-input*)
-			    (eof-errorp t) eof-value recursive-p)
-  "Peeks at the next character in the input Stream.  See manual for details."
-  (declare (ignore recursive-p))
-  (let* ((stream (in-synonym-of stream))
-	 (char (read-char stream eof-errorp eof-value)))
-    (cond ((eq char eof-value) char)
-	  ((characterp peek-type)
-	   (do ((char char (read-char stream eof-errorp eof-value)))
-	       ((or (eq char eof-value) (char= char peek-type))
-		(unless (eq char eof-value)
-		  (unread-char char stream))
-		char)))
-	  ((eq peek-type t)
-	   (do ((char char (read-char stream eof-errorp eof-value)))
-	       ((or (eq char eof-value) (not (whitespace-char-p char)))
-		(unless (eq char eof-value)
-		  (unread-char char stream))
-		char)))
-	  (t
-	   (unread-char char stream)
-	   char))))
-
-(defun listen (&optional (stream *standard-input*))
-  "Returns T if a character is availible on the given Stream."
-  (let ((stream (in-synonym-of stream)))
-    (or (/= (the fixnum (stream-in-index stream)) in-buffer-length)
-	(funcall (stream-misc stream) stream :listen))))
-
-(defun read-char-no-hang (&optional (stream *standard-input*)
-				    (eof-errorp t) eof-value recursive-p)
-  "Returns the next character from the Stream if one is availible, or nil."
-  (declare (ignore recursive-p))
-  (if (listen stream) (read-char stream eof-errorp eof-value) nil))
-
-(defun clear-input (&optional (stream *standard-input*))
-  "Clears any buffered input associated with the Stream."
-  (let ((stream (in-synonym-of stream)))
-    (setf (stream-in-index stream) in-buffer-length)
-    (funcall (stream-misc stream) stream :clear-input)
-    nil))
-
-(defun read-byte (stream &optional (eof-errorp t) eof-value)
-  "Returns the next byte of the Stream."
-  (let* ((stream (in-synonym-of stream))
-	 (index (stream-in-index stream)))
-    (declare (fixnum index))
-    (if (eql index in-buffer-length)
-	(funcall (stream-bin stream) stream eof-errorp eof-value)
-	(prog1 (aref (stream-in-buffer stream) index)
-	       (setf (stream-in-index stream) (1+ index))))))
-
-(defun read-n-bytes (stream buffer start numbytes &optional (eof-errorp t))
-  "Reads Numbytes bytes into the Buffer starting at Start, and returns
-  the number of bytes actually read if the end of file was hit before Numbytes
-  bytes were read (and Eof-Errorp is false)."
-  (declare (fixnum numbytes))
-  (let* ((stream (in-synonym-of stream))
-	 (in-buffer (stream-in-buffer stream))
-	 (index (stream-in-index stream))
-	 (num-buffered (- in-buffer-length index)))
-    (declare (fixnum index num-buffered))
-    (cond
-     ((not in-buffer)
-      (with-in-stream stream stream-n-bin buffer start numbytes eof-errorp))
-     ((not (eql (%primitive get-vector-access-code in-buffer) 3))
-      (error "N-Bin only works on 8-bit-like streams."))
-     ((<= numbytes num-buffered)
-      (%primitive byte-blt in-buffer index buffer start (+ start numbytes))
-      (setf (stream-in-index stream) (+ index numbytes))
-      numbytes)
-     (t
-      (let ((end (+ start num-buffered)))
-	(%primitive byte-blt in-buffer index buffer start end)
-	(setf (stream-in-index stream) in-buffer-length)
-	(+ (with-in-stream stream stream-n-bin buffer end
-				   (- numbytes num-buffered)
-				   eof-errorp)
-	   num-buffered))))))
-
-;;; Output functions:
-
-(defun write-char (character &optional (stream *standard-output*))
-  "Outputs the Character to the Stream."
-  (with-out-stream stream stream-out character)
-  character)
-
-(defun terpri (&optional (stream *standard-output*))
-  "Outputs a new line to the Stream."
-  (with-out-stream stream stream-out #\newline)
-  nil)
-
-(defun fresh-line (&optional (stream *standard-output*))
-  "Outputs a new line to the Stream if it is not positioned at the begining of
-   a line.  Returns T if it output a new line, nil otherwise."
-  (let ((stream (out-synonym-of stream)))
-    (when (/= (or (charpos stream) 1) 0)
-      (funcall (stream-out stream) stream #\newline)
-      t)))
-
-(defun write-string (string &optional (stream *standard-output*)
-			    &key (start 0) (end (length (the vector string))))
-  "Outputs the String to the given Stream."
-  (write-string* string stream start end))
-
-(defun write-string* (string &optional (stream *standard-output*)
-			     (start 0) (end (length (the vector string))))
-  (declare (fixnum start end))
-  (if (array-header-p string)
-      (with-array-data ((data string) (offset-start start) (offset-end end))
-	(with-out-stream stream stream-sout data offset-start offset-end))
-      (with-out-stream stream stream-sout string start end))
-  string)
-
-(defun write-line (string &optional (stream *standard-output*)
-			  &key (start 0) (end (length string)))
-  "Outputs the String to the given Stream, followed by a newline character."
-  (write-line* string stream start end))
-
-(defun write-line* (string &optional (stream *standard-output*)
-			   (start 0) (end (length string)))
-  (declare (fixnum start end))
-  (let ((stream (out-synonym-of stream)))
-    (if (array-header-p string)
-	(with-array-data ((data string) (offset-start start) (offset-end end))
-	  (with-out-stream stream stream-sout data offset-start offset-end))
-	(with-out-stream stream stream-sout string start end))
-    (funcall (stream-out stream) stream #\newline))
-  string)
-
-(defun charpos (&optional (stream *standard-output*))
-  "Returns the number of characters on the current line of output of the given
-  Stream, or Nil if that information is not availible."
-  (with-out-stream stream stream-misc :charpos))
-
-(defun line-length (&optional (stream *standard-output*))
-  "Returns the number of characters that will fit on a line of output on the
-  given Stream, or Nil if that information is not available."
-  (with-out-stream stream stream-misc :line-length))
-
-(defun finish-output (&optional (stream *standard-output*))
-  "Attempts to ensure that all output sent to the the Stream has reached its
-   destination, and only then returns."
-  (with-out-stream stream stream-misc :finish-output)
-  nil)
-
-(defun force-output (&optional (stream *standard-output*))
-  "Attempts to force any buffered output to be sent."
-  (with-out-stream stream stream-misc :force-output)
-  nil)
-
-(defun clear-output (&optional (stream *standard-output*))
-  "Clears the given output Stream."
-  (with-out-stream stream stream-misc :clear-output)
-  nil)
-
-(defun write-byte (integer stream)
-  "Outputs the Integer to the binary Stream."
-  (with-out-stream stream stream-bout integer)
-  integer)
-
-;;;; Broadcast streams:
-
-(defstruct (broadcast-stream (:include stream
-				       (out #'broadcast-out)
-				       (bout #'broadcast-bout)
-				       (sout #'broadcast-sout)
-				       (misc #'broadcast-misc))
-			     (:print-function %print-broadcast-stream)
-			     (:constructor make-broadcast-stream (&rest streams)))
-  ;; This is a list of all the streams we broadcast to.
-  streams)
-
-(setf (documentation 'make-broadcast-stream 'function)
- "Returns an ouput stream which sends its output to all of the given streams.")
-
-(defun %print-broadcast-stream (s stream d)
-  (declare (ignore s d))
-  (write-string "#<Broadcast Stream>" stream))
-
-(macrolet ((out-fun (fun method &rest args)
-	     `(defun ,fun (stream ,@args)
-		(dolist (stream (broadcast-stream-streams stream))
-		  (funcall (,method stream) stream ,@args)))))
-  (out-fun broadcast-out stream-out char)
-  (out-fun broadcast-bout stream-bout byte)
-  (out-fun broadcast-sout stream-sout string start end))
-
-(defun broadcast-misc (stream operation &optional arg1 arg2)
-  (let ((streams (broadcast-stream-streams stream)))
-    (case operation
-      (:charpos
-       (dolist (stream streams)
-	 (let ((charpos (funcall (stream-misc stream) stream :charpos)))
-	   (if charpos (return charpos)))))
-      (:line-length
-       (let ((min nil))
-	 (dolist (stream streams min)
-	   (let ((res (funcall (stream-misc stream) stream :line-length)))
-	     (when res (setq min (if min (min res min) res)))))))
-      (:element-type
-       (let (res)
-	 (dolist (stream streams (if (> (length res) 1) `(and ,@res) res))
-	   (pushnew (funcall (stream-misc stream) stream :element-type) res
-		    :test #'equal))))
-      (t
-       (let ((res nil))
-	 (dolist (stream streams res)
-	   (setq res (funcall (stream-misc stream) stream operation
-			      arg1 arg2))))))))
-
-;;;; Synonym Streams:
-
-(defstruct (synonym-stream (:include stream
-				     (in #'synonym-in)
-				     (bin #'synonym-bin)
-				     (n-bin #'synonym-n-bin)
-				     (out #'synonym-out)
-				     (bout #'synonym-bout)
-				     (sout #'synonym-sout)
-				     (misc #'synonym-misc))
-			   (:print-function %print-synonym-stream)
-			   (:constructor make-synonym-stream (symbol)))
-  ;; This is the symbol, the value of which is the stream we are synonym to.
-  symbol)
-
-(defun %print-synonym-stream (s stream d)
-  (declare (ignore d))
-  (format stream "#<Synonym Stream to ~S>" (synonym-stream-symbol s)))
-
-(setf (documentation 'make-synonym-stream 'function)
-  "Returns a stream which performs its operations on the stream which is the
-   value of the dynamic variable named by Symbol.")
-
-;;; The output simple output methods just call the corresponding method
-;;; in the synonymed stream.
-;;;
-(macrolet ((out-fun (name slot &rest args)
-	     `(defun ,name (stream ,@args)
-		(let ((syn (symbol-value (synonym-stream-symbol stream))))
-		  (funcall (,slot syn) syn ,@args)))))
-  (out-fun synonym-out stream-out ch)
-  (out-fun synonym-bout stream-bout n)
-  (out-fun synonym-sout stream-sout string start end))
-
-
-;;; Bind synonym stream to this so that SPIO can turn on the right frob in
-;;; the icon when we are in a terminal input wait.
-;;;
-(defvar *previous-stream* nil)
-
-;;; For the input methods, we just call the corresponding function on the
-;;; synonymed stream.  These functions deal with getting input out of
-;;; the In-Buffer if there is any.
-;;;
-(macrolet ((in-fun (name fun &rest args)
-	     `(defun ,name (stream ,@args)
-		(let ((*previous-stream* stream))
-		  (,fun (symbol-value (synonym-stream-symbol stream)) ,@args)))))
-  (in-fun synonym-in read-char eof-errorp eof-value)
-  (in-fun synonym-bin read-byte eof-errorp eof-value)
-  (in-fun synonym-n-bin read-n-bytes buffer start numbytes eof-errorp))
-
-
-;;; Synonym-Misc  --  Internal
-;;;
-;;;    We have to special-case the operations which could look at stuff in
-;;; the in-buffer.
-;;;
-(defun synonym-misc (stream operation &optional arg1 arg2)
-  (let ((syn (symbol-value (synonym-stream-symbol stream)))
-	(*previous-stream* stream))
-    (case operation
-      (:read-line (read-line syn))
-      (:listen (or (/= (the fixnum (stream-in-index syn)) in-buffer-length)
-		   (funcall (stream-misc syn) syn :listen)))
-      (t
-       (funcall (stream-misc syn) syn operation arg1 arg2)))))
-
-;;;; Two-Way streams:
-
-(defstruct (two-way-stream
-	    (:include stream
-		      (in #'two-way-in)
-		      (bin #'two-way-bin)
-		      (n-bin #'two-way-n-bin)
-		      (out #'two-way-out)
-		      (bout #'two-way-bout)
-		      (sout #'two-way-sout)
-		      (misc #'two-way-misc))
-	    (:print-function %print-two-way-stream)
-	    (:constructor make-two-way-stream (input-stream output-stream)))
-  ;; We read from this stream...
-  input-stream
-  ;; And write to this one
-  output-stream)
-
-(defun %print-two-way-stream (s stream d)
-  (declare (ignore d))
-  (format stream "#<Two-Way Stream, Input = ~S, Output = ~S>"
-	  (two-way-stream-input-stream s)
-	  (two-way-stream-output-stream s)))
-
-(setf (documentation 'make-two-way-stream 'function)
-  "Returns a bidirectional stream which gets its input from Input-Stream and
-   sends its output to Output-Stream.")
-
-(macrolet ((out-fun (name slot &rest args)
-	     `(defun ,name (stream ,@args)
-		(let ((syn (two-way-stream-output-stream stream)))
-		  (funcall (,slot syn) syn ,@args)))))
-  (out-fun two-way-out stream-out ch)
-  (out-fun two-way-bout stream-bout n)
-  (out-fun two-way-sout stream-sout string start end))
-
-(macrolet ((in-fun (name fun &rest args)
-	     `(defun ,name (stream ,@args)
-		(,fun (two-way-stream-input-stream stream) ,@args))))
-  (in-fun two-way-in read-char eof-errorp eof-value)
-  (in-fun two-way-bin read-byte eof-errorp eof-value)
-  (in-fun two-way-n-bin read-n-bytes buffer start numbytes eof-errorp))
-
-(defun two-way-misc (stream operation &optional arg1 arg2)
-  (let* ((in (two-way-stream-input-stream stream))
-	 (in-method (stream-misc in))
-	 (out (two-way-stream-output-stream stream))
-	 (out-method (stream-misc out)))
-    (case operation
-      (:listen (or (/= (the fixnum (stream-in-index in)) in-buffer-length)
-		   (funcall in-method in :listen)))
-      (:read-line (read-line in arg1 arg2))
-      ((:finish-output :force-output :clear-output)
-       (funcall out-method out operation arg1 arg2))
-      ((:clear-input :unread)
-       (funcall in-method in operation arg1 arg2))
-      (:element-type
-       (let ((in-type (funcall in-method in :element-type))
-	     (out-type (funcall out-method out :element-type)))
-	 (if (equal in-type out-type)
-	     in-type `(and ,in-type ,out-type))))
-      (:close 
-       (funcall in-method in :close arg1)
-       (funcall out-method out :close arg1)
-       (set-closed-flame stream))
-      (t
-       (or (funcall in-method in operation arg1 arg2)
-	   (funcall out-method out operation arg1 arg2))))))
-
-;;;; Concatenated Streams:
-
-(defstruct (concatenated-stream
-	    (:include stream
-		      (in #'concatenated-in)
-		      (bin #'concatenated-bin)
-		      (misc #'concatenated-misc))
-	    (:print-function %print-concatenated-stream)
-	    (:constructor
-	     make-concatenated-stream (&rest streams &aux (current streams))))
-  ;; The car of this is the stream we are reading from now.
-  current
-  ;; This is a list of all the streams.  We need to remember them so that
-  ;; we can close them.
-  streams)
-
-(defun %print-concatenated-stream (s stream d)
-  (declare (ignore d))
-  (format stream "#<Concatenated Stream, Streams = ~S>"
-	  (concatenated-stream-streams s)))
-
-(setf (documentation 'make-concatenated-stream 'function)
-  "Returns a stream which takes its input from each of the Streams in turn,
-   going on to the next at EOF.")
-
-(macrolet ((in-fun (name fun)
-	     `(defun ,name (stream eof-errorp eof-value)
-		(do ((current (concatenated-stream-current stream) (cdr current)))
-		    ((null current)
-		     (eof-or-lose stream eof-errorp eof-value))
-		  (let* ((stream (car current))
-			 (result (,fun stream nil nil)))
-		    (when result (return result)))
-		  (setf (concatenated-stream-current stream) current)))))
-  (in-fun concatenated-in read-char)
-  (in-fun concatenated-bin read-byte))
-
-;;;    Concatenated-Readline is somewhat hairy, since we may need to
-;;; do several readlines and concatenate the result if the lines are
-;;; terminated by eof.
-;;;
-(defun concatenated-readline (stream eof-errorp eof-value)
-  ;; Loop until we find a stream that will give us something or we error
-  ;; out.
-  (do ((current (concatenated-stream-current stream) (cdr current)))
-      ((null current)
-       (eof-or-lose stream eof-errorp eof-value))
-    (setf (concatenated-stream-current stream) current)
-    (let ((this (car current)))
-      (multiple-value-bind (result eofp)
-			   (read-line this nil nil)
-	(declare (simple-string result))
-	;; Once we have found some input, we loop until we either find a 
-	;; line not terminated by eof or hit eof on the last stream.
-	(when result
-	  (do ((current (cdr current) (cdr current))
-	       (new ""))
-	      ((or (not eofp) (null current))
-	       (return-from concatenated-readline (values result eofp)))
-	    (declare (simple-string new))
-	    (setf (concatenated-stream-current stream) current)
-	    (let ((this (car current)))
-	      (multiple-value-setq (new eofp)
-		(read-line this nil nil))
-	      (if new
-		  (setq result (concatenate 'simple-string result new))
-		  (setq eofp t)))))))))
-
-(defun concatenated-misc (stream operation &optional arg1 arg2)
-  (if (eq operation :read-line)
-      (concatenated-readline stream arg1 arg2)
-      (let ((left (concatenated-stream-current stream)))
-	(when left
-	  (let* ((current (car left))
-		 (misc (stream-misc current)))
-	    (case operation
-	      (:listen (or (/= (the fixnum (stream-in-index current)) in-buffer-length)
-			   (funcall misc current :listen)))
-	      (:close
-	       (dolist (stream (concatenated-stream-streams stream))
-		 (funcall (stream-misc stream) stream :close arg1))
-	       (set-closed-flame stream))
-	      (t
-	       (funcall misc current operation arg1 arg2))))))))
-
-;;;; Echo Streams:
-
-(defstruct (echo-stream
-	    (:include two-way-stream
-		      (in #'echo-in)
-		      (bin #'echo-bin)
-		      (misc #'echo-misc)
-		      (n-bin #'ill-bin))
-	    (:print-function %print-echo-stream)
-	    (:constructor make-echo-stream (input-stream output-stream))))
-
-
-(macrolet ((in-fun (name fun out-slot &rest args)
-	     `(defun ,name (stream ,@args)
-		(let* ((in (two-way-stream-input-stream stream))
-		       (out (two-way-stream-output-stream stream))
-		       (result (,fun in ,@args)))
-		  (funcall (,out-slot out) out result)
-		  result))))
-  (in-fun echo-in read-char stream-out eof-errorp eof-value)
-  (in-fun echo-bin read-byte stream-bout eof-errorp eof-value))
-
-(defun echo-misc (stream operation &optional arg1 arg2)
-  (let* ((in (two-way-stream-input-stream stream))
-	 (in-method (stream-misc in))
-	 (out (two-way-stream-output-stream stream))
-	 (out-method (stream-misc out)))
-    (case operation
-      (:listen (or (/= (the fixnum (stream-in-index in)) in-buffer-length)
-		   (funcall in-method in :listen)))
-      (:read-line
-       (multiple-value-bind (result eofp)
-			    (read-line in arg1 arg2)
-	 (if eofp
-	     (write-string result out)
-	     (write-line result out))
-	 (values result eofp)))
-      (:element-type
-       (let ((in-type (funcall in-method in :element-type))
-	     (out-type (funcall out-method out :element-type)))
-	 (if (equal in-type out-type)
-	     in-type `(and ,in-type ,out-type))))
-      (:close
-       (funcall in-method in :close arg1)
-       (funcall out-method out :close arg1)
-       (set-closed-flame stream))
-      (t
-       (or (funcall in-method in operation arg1 arg2)
-	   (funcall out-method out operation arg1 arg2))))))
-
-(defun %print-echo-stream (s stream d)
-  (declare (ignore d))
-  (format stream "#<Echo Stream, Input = ~S, Output = ~S>"
-	  (two-way-stream-input-stream s)
-	  (two-way-stream-output-stream s)))
-
-(setf (documentation 'make-echo-stream 'function)
-  "Returns a bidirectional stream which gets its input from Input-Stream and
-   sends its output to Output-Stream.  In addition, all input is echoed to
-   the output stream")
-
-;;;; String Input Streams:
-
-(defstruct (string-input-stream
-	    (:include stream
-		      (in #'string-inch)
-		      (misc #'string-in-misc))
-	    (:print-function %print-string-input-stream)
-	    (:constructor nil)
-	    (:constructor internal-make-string-input-stream
-			  (string current end)))
-  (string nil :type simple-string)
-  (current nil :type fixnum)
-  (end nil :type fixnum))
-
-(defun %print-string-input-stream (s stream d)
-  (declare (ignore s d))
-  (write-string "#<String-Input Stream>" stream))
-  
-(defun string-inch (stream eof-errorp eof-value)
-  (let ((string (string-input-stream-string stream))
-	(index (string-input-stream-current stream)))
-    (declare (simple-string string) (fixnum index))
-    (cond ((= index (the fixnum (string-input-stream-end stream)))
-	   (eof-or-lose stream eof-errorp eof-value))
-	  (t
-	   (setf (string-input-stream-current stream) (1+ index))
-	   (aref string index)))))
-
-(defun string-in-misc (stream operation &optional arg1 arg2)
-  (case operation
-    (:file-position
-     (if (null arg1)
-       (string-input-stream-current stream)))
-    (:read-line
-     (let ((string (string-input-stream-string stream))
-	   (current (string-input-stream-current stream))
-	   (end (string-input-stream-end stream)))
-       (declare (simple-string string) (fixnum current end))
-       (if (= current end)
-	   (eof-or-lose stream arg1 arg2)
-	   (let ((pos (%primitive find-character string current end #\newline)))
-	     (if pos
-		 (let* ((res-length (- (the fixnum pos) current))
-			(result (make-string res-length)))
-		   (%primitive byte-blt string current result 0 res-length)
-		   (setf (string-input-stream-current stream)
-			 (1+ (the fixnum pos)))
-		   (values result nil))
-		 (let* ((res-length (- end current))
-			(result (make-string res-length)))
-		   (%primitive byte-blt string current result 0 res-length)
-		   (setf (string-input-stream-current stream) end)
-		   (values result t)))))))
-    (:unread (decf (string-input-stream-current stream)))
-    (:listen (not (= (the fixnum (string-input-stream-current stream))
-		     (the fixnum (string-input-stream-end stream)))))
-    (:element-type 'string-char)))
-  
-(defun make-string-input-stream (string &optional
-					(start 0) (end (length string)))
-  "Returns an input stream which will supply the characters of String between
-  Start and End in order."
-  (if (stringp string)
-      (internal-make-string-input-stream (coerce string 'simple-string)
-					 start end)
-      (error "~S is not a string." string)))
-
-;;;; String Output Streams:
-
-(defstruct (string-output-stream
-	    (:include stream
-		      (out #'string-ouch)
-		      (sout #'string-sout)
-		      (misc #'string-out-misc))
-	    (:print-function %print-string-output-stream)
-	    (:constructor make-string-output-stream ()))
-  ;; The string we throw stuff in.
-  (string (make-string 40) :type simple-string)
-  ;; Index of the next location to use.
-  (index 0 :type fixnum))
-
-(defun %print-string-output-stream (s stream d)
-  (declare (ignore s d))
-  (write-string "#<String-Output Stream>" stream))
-
-(setf (documentation 'make-string-output-stream 'function)
-  "Returns an Output stream which will accumulate all output given it for
-   the benefit of the function Get-Output-Stream-String.")
-
-(defun string-ouch (stream character)
-  (let ((current (string-output-stream-index stream))
-	(workspace (string-output-stream-string stream)))
-    (declare (simple-string workspace) (fixnum current))
-    (if (= current (the fixnum (length workspace)))
-	(let ((new-workspace (make-string (* current 2))))
-	  (%primitive byte-blt workspace 0 new-workspace 0 current)
-	  (setf (aref new-workspace current) character)
-	  (setf (string-output-stream-string stream) new-workspace))
-	(setf (aref workspace current) character))
-    (setf (string-output-stream-index stream) (1+ current))))
-
-(defun string-sout (stream string start end)
-  (declare (simple-string string) (fixnum start end))
-  (let* ((current (string-output-stream-index stream))
-	 (length (- end start))
-	 (dst-end (+ length current))
-	 (workspace (string-output-stream-string stream)))
-    (declare (simple-string workspace)
-	     (fixnum current length dst-end))
-    (if (> dst-end (the fixnum (length workspace)))
-	(let ((new-workspace (make-string (+ (* current 2) length))))
-	  (%primitive byte-blt workspace 0 new-workspace 0 current)
-	  (%primitive byte-blt string start new-workspace current dst-end)
-	  (setf (string-output-stream-string stream) new-workspace))
-	(%primitive byte-blt string start workspace current dst-end))
-    (setf (string-output-stream-index stream) dst-end)))
-
-(defun string-out-misc (stream operation &optional arg1 arg2)
-  (declare (ignore arg1 arg2))
-  (case operation
-    (:file-position
-     (if (null arg1)
-       (string-output-stream-index stream)))
-    (:charpos
-     (do ((index (1- (the fixnum (string-output-stream-index stream)))
-		 (1- index))
-	  (count 0 (1+ count))
-	  (string (string-output-stream-string stream)))
-	 ((< index 0) count)
-       (declare (simple-string string)
-		(fixnum index count))
-       (if (char= (schar string index) #\newline)
-	   (return count))))
-    (:element-type 'string-char)))
-
-(defun get-output-stream-string (stream)
-  "Returns a string of all the characters sent to a stream made by
-   Make-String-Output-Stream since the last call to this function."
-  (if (streamp stream)
-      (let* ((length (string-output-stream-index stream))
-	     (result (make-string length)))
-	(%primitive byte-blt (string-output-stream-string stream) 0
-		      result 0 length)
-	(setf (string-output-stream-index stream) 0)
-	result)
-      (error "~S is not a string stream.")))
-
-(defun dump-output-stream-string (in-stream out-stream)
-  "Dumps the characters buffer up in the In-Stream to the Out-Stream as
-  Get-Output-Stream-String would return them."
-  (write-string (string-output-stream-string in-stream) out-stream
-		:start 0 :end (string-output-stream-index in-stream))
-  (setf (string-output-stream-index in-stream) 0))
-
-;;;; Fill-pointer streams:
-;;;
-;;;    Fill pointer string output streams are not explicitly mentioned in
-;;; the CLM, but they are required for the implementation of With-Output-To-String.
-
-(defstruct (fill-pointer-output-stream
- 	    (:include stream
-		      (out #'fill-pointer-ouch)
-		      (sout #'fill-pointer-sout)
-		      (misc #'fill-pointer-misc))
-	    (:print-function
-	     (lambda (s stream d)
-	       (declare (ignore s d))
-	       (write-string "#<Fill-Pointer String Output Stream>" stream)))
-	    (:constructor make-fill-pointer-output-stream (string)))
-  ;; The string we throw stuff in.
-  string)
-
- 
-(defun fill-pointer-ouch (stream character)
-  (let* ((buffer (fill-pointer-output-stream-string stream))
-	 (current (%primitive header-ref buffer %array-fill-pointer-slot))
-	 (current+1 (1+ current)))
-    (declare (fixnum current))
-    (with-array-data ((workspace buffer) (start) (end))
-      (declare (simple-string workspace))
-      (let ((offset-current (+ start current)))
-	(declare (fixnum offset-current))
-	(if (= offset-current end)
-	    (let* ((new-length (* current 2))
-		   (new-workspace (make-string new-length)))
-	      (declare (simple-string new-workspace))
-	      (%primitive byte-blt workspace start new-workspace 0 current)
-	      (setf workspace new-workspace)
-	      (setf offset-current current)
-	      (set-array-header buffer workspace new-length
-				current+1 0 new-length nil))
-	    (%primitive header-set buffer %array-fill-pointer-slot current+1))
-	(setf (schar workspace offset-current) character)))
-    current+1))
-
-
-(defun fill-pointer-sout (stream string start end)
-  (declare (simple-string string) (fixnum start end))
-  (let* ((buffer (fill-pointer-output-stream-string stream))
-	 (current (%primitive header-ref buffer %array-fill-pointer-slot))
-	 (string-len (- end start))
-	 (dst-end (+ string-len current)))
-    (declare (fixnum current dst-end string-len))
-    (with-array-data ((workspace buffer) (dst-start) (dst-length))
-      (declare (simple-string workspace))
-      (let ((offset-dst-end (+ dst-start dst-end))
-	    (offset-current (+ dst-start current)))
-	(declare (fixnum offset-dst-end offset-current))
-	(if (> offset-dst-end dst-length)
-	    (let* ((new-length (+ (the fixnum (* current 2)) string-len))
-		   (new-workspace (make-string new-length)))
-	      (declare (simple-string new-workspace))
-	      (%primitive byte-blt workspace dst-start new-workspace 0 current)
-	      (setf workspace new-workspace)
-	      (setf offset-current current)
-	      (setf offset-dst-end dst-end)
-	      (set-array-header buffer workspace new-length
-				dst-end 0 new-length nil))
-	    (%primitive header-set buffer %array-fill-pointer-slot dst-end))
-	(%primitive byte-blt string start
-		    workspace offset-current offset-dst-end)))
-    dst-end))
-
-
-(defun fill-pointer-misc (stream operation &optional arg1 arg2)
-  (declare (ignore arg1 arg2))
-  (case operation
-    (:charpos
-     (let* ((buffer (fill-pointer-output-stream-string stream))
-	    (current (%primitive header-ref buffer %array-fill-pointer-slot)))
-       (with-array-data ((string buffer) (start) (end current))
-	 (declare (simple-string string) (ignore start))
-	 (let ((found (position #\newline string :test #'char=
-				:end end :from-end t)))
-	   (if found
-	       (- end (the fixnum found))
-	       current)))))
-     (:element-type 'string-char)))
-
-;;;; Indenting streams:
-
-(defstruct (indenting-stream (:include stream
-				       (out #'indenting-out)
-				       (sout #'indenting-sout)
-				       (misc #'indenting-misc))
-			     (:print-function %print-indenting-stream)
-			     (:constructor make-indenting-stream (stream)))
-  ;; The stream we're based on:
-  stream
-  ;; How much we indent on each line:
-  (indentation 0))
-
-(setf (documentation 'make-indenting-stream 'function)
- "Returns an ouput stream which indents its output by some amount.")
-
-(defun %print-indenting-stream (s stream d)
-  (declare (ignore s d))
-  (write-string "#<Indenting Stream>" stream))
-
-;;; Indenting-Indent writes the right number of spaces needed to indent output on
-;;; the given Stream based on the specified Sub-Stream.
-
-(defmacro indenting-indent (stream sub-stream)
-  `(do ((i 0 (+ i 60))
-	(indentation (indenting-stream-indentation ,stream)))
-       ((>= i indentation))
-     (funcall (stream-sout ,sub-stream) ,sub-stream
-	      "                                                            "
-	      0 (min 60 (- indentation i)))))
-
-;;; Indenting-Out writes a character to an indenting stream.
-
-(defun indenting-out (stream char)
-  (let ((sub-stream (indenting-stream-stream stream)))
-    (funcall (stream-out sub-stream) sub-stream char)
-    (if (char= char #\newline)
-	(indenting-indent stream sub-stream))))
-
-;;; Indenting-Sout writes a string to an indenting stream.
-
-(defun indenting-sout (stream string start end)
-  (declare (simple-string string) (fixnum start end))
-  (do ((i start)
-       (sub-stream (indenting-stream-stream stream)))
-      ((= i end))
-    (let ((newline (position #\newline string :start i :end end)))
-      (cond (newline
-	     (funcall (stream-sout sub-stream) sub-stream string i (1+ newline))
-	     (indenting-indent stream sub-stream)
-	     (setq i (+ newline 1)))
-	    (t
-	     (funcall (stream-sout sub-stream) sub-stream string i end)
-	     (setq i end))))))
-
-;;; Indenting-Misc just treats just the :Line-Length message differently.
-;;; Indenting-Charpos says the charpos is the charpos of the base stream minus
-;;; the stream's indentation.
-
-(defun indenting-misc (stream operation &optional arg1 arg2)
-  (let* ((sub-stream (indenting-stream-stream stream))
-	 (method (stream-misc sub-stream)))
-    (case operation
-      (:line-length
-       (let ((line-length (funcall method sub-stream operation)))
-	 (if line-length
-	     (- line-length (indenting-stream-indentation stream)))))
-      (:charpos
-       (let* ((sub-stream (indenting-stream-stream stream))
-	      (charpos (funcall method sub-stream operation)))
-	 (if charpos
-	     (- charpos (indenting-stream-indentation stream)))))       
-      (t
-       (funcall method sub-stream operation arg1 arg2)))))
-
-(proclaim '(notinline read-char unread-char read-byte listen))
diff --git a/code/string.lisp b/code/string.lisp
deleted file mode 100644
index c9c96088043a94515aa091df771fca5a583e0472..0000000000000000000000000000000000000000
--- a/code/string.lisp
+++ /dev/null
@@ -1,608 +0,0 @@
-;;; -*- Log: code.log; Package: Lisp -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; Functions to implement strings for Spice Lisp
-;;; Written by David Dill
-;;; Rewritten and currently maintained by Skef Wholey
-;;;
-;;; Runs in the standard Spice Lisp environment.
-;;;
-;;; ****************************************************************
-;;;
-(in-package 'lisp)
-(export '(char schar string
-	  string= string-equal string< string> string<= string>= string/=
-	  string-lessp string-greaterp string-not-lessp string-not-greaterp
-	  string-not-equal
-	  make-string
-	  string-trim string-left-trim string-right-trim
-	  string-upcase
-	  string-downcase string-capitalize nstring-upcase nstring-downcase
-	  nstring-capitalize))
-
-(eval-when (compile)
-
-;;; %String returns its arg if it is a string, otherwise calls String.
-;;;
-(defmacro %string (thing)
-  `(if (stringp ,thing) ,thing (string ,thing)))
-)
-
-(defun string (X)
-  "Coerces X into a string.  If X is a string, X is returned.  If X is a
-   symbol, X's pname is returned.  If X is a character then a one element
-   string containing that character is returned.  If X cannot be coerced
-   into a string, an error occurs."
-  (cond ((stringp x) x)
-	((symbolp x) (symbol-name x))
-	((characterp x)
-	 (let ((res (make-string 1)))
-	   (setf (schar res 0) x) res))
-	(t
-	 (error "~S cannot be coerced to a string." x))))
-
-
-;;; With-One-String is used to set up some string hacking things.  The keywords
-;;; are parsed, and the string is hacked into a simple-string.
-
-(eval-when (compile)
-
-(defmacro with-one-string (string start end cum-offset &rest forms)
-  (let ((data (gensym))
-	(data-start (gensym))
-	(data-end (gensym))
-	(offset (gensym)))
-    `(progn
-      (if (symbolp ,string) (setq ,string (symbol-name ,string)))
-      (if (array-header-p ,string)
-	  (with-array-data ((,data ,string :offset-var ,offset)
-			    (,data-start ,start)
-			    (,data-end (or ,end
-					   (%primitive header-ref ,string
-						       %array-fill-pointer-slot))))
-			   (psetq ,string ,data
-				  ,cum-offset ,offset
-				  ,start ,data-start
-				  ,end ,data-end))
-	  (if (not ,end) (setq ,end (length (the simple-string ,string)))))
-      ,@forms)))
-
-)
-
-;;; With-String is like With-One-String, but doesn't parse keywords.
-
-(eval-when (compile)
-
-(defmacro with-string (string &rest forms)
-  `(let ((start 0)
-	 (end ()))
-     (if (symbolp ,string) (setq ,string (symbol-name ,string)))
-     (if (array-header-p ,string)
-	 (with-array-data ((data ,string)
-			   (data-start start)
-			   (data-end (%primitive header-ref ,string
-						 %array-fill-pointer-slot)))
-	   (psetq ,string data
-		  start data-start
-		  end data-end))
-	 (setq end (length (the simple-string ,string))))
-     ,@forms))
-
-)
-
-;;; With-Two-Strings is used to set up string comparison operations.  The
-;;; keywords are parsed, and the strings are hacked into simple-strings.
-
-(eval-when (compile)
-
-(defmacro with-two-strings (string1 string2 start1 end1 cum-offset-1
-				    start2 end2 &rest forms)
-  (let ((data (gensym))
-	(data-start (gensym))
-	(data-end (gensym))
-	(offset (gensym)))
-    `(progn
-      (if (symbolp ,string1) (setq ,string1 (symbol-name ,string1)))
-      (if (symbolp ,string2) (setq ,string2 (symbol-name ,string2)))
-      (if (array-header-p ,string1)
-	  (with-array-data ((,data ,string1 :offset-var ,offset)
-			    (,data-start ,start1)
-			    (,data-end (or ,end1
-					   (%primitive header-ref ,string1
-						       %array-fill-pointer-slot))))
-			   (psetq ,string1 ,data
-				  ,cum-offset-1 ,offset
-				  ,start1 ,data-start
-				  ,end1 ,data-end))
-	  (if (not ,end1) (setq ,end1 (length (the simple-string ,string1)))))
-      (if (array-header-p ,string2)
-	  (with-array-data ((,data ,string2)
-			    (,data-start ,start2)
-			    (,data-end (or ,end2
-					   (%primitive header-ref ,string2
-						       %array-fill-pointer-slot))))
-			   (psetq ,string2 ,data
-				  ,start2 ,data-start
-				  ,end2 ,data-end))
-	  (if (not ,end2) (setq ,end2 (length (the simple-string ,string2)))))
-      ,@forms)))
-
-)
-
-(defun char (string index)
-  "Given a string and a non-negative integer index less than the length of
-  the string, returns the character object representing the character at
-  that position in the string."
-  (char string index))
-
-(defun %charset (string index new-el)
-  (setf (char string index) new-el))
-
-(defun schar (string index)
-  "SCHAR returns the character object at an indexed position in a string
-   just as CHAR does, except the string must be a simple-string."
-  (schar string index))
-
-(defun %scharset (string index new-el)
-  (setf (schar string index) new-el))
-
-(defun string=* (string1 string2 start1 end1 start2 end2)
-  (let ((offset1 0))
-    (with-two-strings string1 string2 start1 end1 offset1 start2 end2
-      (not (%sp-string-compare string1 start1 end1 string2 start2 end2)))))
-
-
-(defun string/=* (string1 string2 start1 end1 start2 end2)
-  (let ((offset1 0))
-    (with-two-strings string1 string2 start1 end1 offset1 start2 end2
-      (let ((comparison (%sp-string-compare string1 start1 end1
-					    string2 start2 end2)))
-	(if comparison (- (the fixnum comparison) offset1))))))
-
-(eval-when (compile eval)
-
-;;; Lessp is true if the desired expansion is for string<* or string<=*.
-;;; Equalp is true if the desired expansion is for string<=* or string>=*.
-(defmacro string<>=*-body (lessp equalp)
-  (let ((offset1 (gensym)))
-    `(let ((,offset1 0))
-       (declare (fixnum ,offset1))
-       (with-two-strings string1 string2 start1 end1 ,offset1 start2 end2
-	 (let ((index (%sp-string-compare string1 start1 end1
-					  string2 start2 end2)))
-	   (if index
-	       (cond ((= (the fixnum index)
-			 ,(if lessp `(the fixnum end1) `(the fixnum end2)))
-		      (- (the fixnum index) ,offset1))
-		     ((= (the fixnum index)
-			 ,(if lessp `(the fixnum end2) `(the fixnum end1)))
-		      nil)
-		     ((,(if lessp 'char< 'char>)
-		       (schar string1 index)
-		       (schar string2 (+ (the fixnum index) (- start2 start1))))
-		      (- (the fixnum index) ,offset1))
-		     (t nil))
-	       ,(if equalp `(- (the fixnum end1) ,offset1) 'nil)))))))
-) ; eval-when
-
-(defun string<* (string1 string2 start1 end1 start2 end2)
-  (declare (fixnum start1 start2))
-  (string<>=*-body t nil))
-
-(defun string>* (string1 string2 start1 end1 start2 end2)
-  (declare (fixnum start1 start2))
-  (string<>=*-body nil nil))
-
-(defun string<=* (string1 string2 start1 end1 start2 end2)
-  (declare (fixnum start1 start2))
-  (string<>=*-body t t))
-
-(defun string>=* (string1 string2 start1 end1 start2 end2)
-  (declare (fixnum start1 start2))
-  (string<>=*-body nil t))
-
-
-
-(defun string< (string1 string2 &key (start1 0) end1 (start2 0) end2)
-  "Given two strings, if the first string is lexicographically less than
-  the second string, returns the longest common prefix (using char=)
-  of the two strings. Otherwise, returns ()."
-  (string<* string1 string2 start1 end1 start2 end2))
-
-(defun string> (string1 string2 &key (start1 0) end1 (start2 0) end2)
-  "Given two strings, if the first string is lexicographically greater than
-  the second string, returns the longest common prefix (using char=)
-  of the two strings. Otherwise, returns ()."
-  (string>* string1 string2 start1 end1 start2 end2))
-
-
-(defun string<= (string1 string2 &key (start1 0) end1 (start2 0) end2)
-  "Given two strings, if the first string is lexicographically less than
-  or equal to the second string, returns the longest common prefix
-  (using char=) of the two strings. Otherwise, returns ()."
-  (string<=* string1 string2 start1 end1 start2 end2))
-
-(defun string>= (string1 string2 &key (start1 0) end1 (start2 0) end2)
-  "Given two strings, if the first string is lexicographically greater
-  than or equal to the second string, returns the longest common prefix
-  (using char=) of the two strings. Otherwise, returns ()."
-  (string>=* string1 string2 start1 end1 start2 end2))
-
-(defun string= (string1 string2 &key (start1 0) end1 (start2 0) end2)
-  "Given two strings (string1 and string2), and optional integers start1,
-  start2, end1 and end2, compares characters in string1 to characters in
-  string2 (using char=)."
-  (string=* string1 string2 start1 end1 start2 end2))
-
-(defun string/= (string1 string2 &key (start1 0) end1 (start2 0) end2)
-  "Given two strings, if the first string is not lexicographically equal
-  to the second string, returns the longest common prefix (using char=)
-  of the two strings. Otherwise, returns ()."
-  (string/=* string1 string2 start1 end1 start2 end2))
-
-
-(eval-when (compile eval)
-
-;;; STRING-NOT-EQUAL-LOOP is used to generate character comparison loops for
-;;; STRING-EQUAL and STRING-NOT-EQUAL.
-(defmacro string-not-equal-loop (end end-value
-				     &optional (abort-value nil abortp))
-  (declare (fixnum end))
-  (let ((end-test (if (= end 1)
-		      `(= index1 (the fixnum end1))
-		      `(= index2 (the fixnum end2)))))
-    `(do ((index1 start1 (1+ index1))
-	  (index2 start2 (1+ index2)))
-	 (,(if abortp
-	       end-test
-	       `(or ,end-test
-		    (not (char-equal (schar string1 index1)
-				     (schar string2 index2)))))
-	  ,end-value)
-       (declare (fixnum index1 index2))
-       ,@(if abortp
-	     `((if (not (char-equal (schar string1 index1)
-				    (schar string2 index2)))
-		   (return ,abort-value)))))))
-
-) ; eval-when
-
-(defun string-equal (string1 string2 &key (start1 0) end1 (start2 0) end2)
-  "Given two strings (string1 and string2), and optional integers start1,
-  start2, end1 and end2, compares characters in string1 to characters in
-  string2 (using char-equal)."
-  (declare (fixnum start1 start2))
-  (let ((offset1 0))
-    (with-two-strings string1 string2 start1 end1 offset1 start2 end2
-      (let ((slen1 (- (the fixnum end1) start1))
-	    (slen2 (- (the fixnum end2) start2)))
-	(declare (fixnum slen1 slen2))
-	(if (or (minusp slen1) (minusp slen2))
-	    ;;prevent endless looping later.
-	    (error "Improper bounds for string comparison."))
-	(if (= slen1 slen2)
-	    ;;return () immediately if lengths aren't equal.
-	    (string-not-equal-loop 1 t nil)))))) 
-
-(defun string-not-equal (string1 string2 &key (start1 0) end1 (start2 0) end2)
-  "Given two strings, if the first string is not lexicographically equal
-  to the second string, returns the longest common prefix (using char-equal)
-  of the two strings. Otherwise, returns ()."
-  (let ((offset1 0))
-    (declare (fixnum offset1))
-    (with-two-strings string1 string2 start1 end1 offset1 start2 end2
-      (let ((slen1 (- end1 start1))
-	    (slen2 (- end2 start2)))
-	(declare (fixnum slen1 slen2))
-	(if (or (minusp slen1) (minusp slen2))
-	    ;;prevent endless looping later.
-	    (error "Improper bounds for string comparison."))
-	(cond ((or (minusp slen1) (or (minusp slen2)))
-	       (error "Improper substring for comparison."))
-	      ((= slen1 slen2)
-	       (string-not-equal-loop 1 nil (- index1 offset1)))
-	      ((< slen1 slen2)
-	       (string-not-equal-loop 1 (- index1 offset1)))
-	      (t
-	       (string-not-equal-loop 2 (- index1 offset1))))))))
- 
-
-
-(eval-when (compile eval)
-
-;;; STRING-LESS-GREATER-EQUAL-TESTS returns a test on the lengths of string1
-;;; and string2 and a test on the current characters from string1 and string2
-;;; for the following macro.
-(defun string-less-greater-equal-tests (lessp equalp)
-  (if lessp
-      (if equalp
-	  ;; STRING-NOT-GREATERP
-	  (values '<= `(not (char-greaterp char1 char2)))
-	  ;; STRING-LESSP
-	  (values '< `(char-lessp char1 char2)))
-      (if equalp
-	  ;; STRING-NOT-LESSP
-	  (values '>= `(not (char-lessp char1 char2)))
-	  ;; STRING-GREATERP
-	  (values '> `(char-greaterp char1 char2)))))
-
-(defmacro string-less-greater-equal (lessp equalp)
-  (multiple-value-bind (length-test character-test)
-		       (string-less-greater-equal-tests lessp equalp)
-    `(let ((offset1 0))
-       (declare (fixnum offset1))
-       (with-two-strings string1 string2 start1 end1 offset1 start2 end2
-	 (let ((slen1 (- (the fixnum end1) start1))
-	       (slen2 (- (the fixnum end2) start2)))
-	   (declare (fixnum slen1 slen2))
-	   (if (or (minusp slen1) (minusp slen2))
-	       ;;prevent endless looping later.
-	       (error "Improper bounds for string comparison."))
-	   (do ((index1 start1 (1+ index1))
-		(index2 start2 (1+ index2))
-		(char1)
-		(char2))
-	       ((or (= index1 (the fixnum end1)) (= index2 (the fixnum end2)))
-		(if (,length-test slen1 slen2) (- index1 offset1)))
-	     (declare (fixnum index1 index2))
-	     (setq char1 (schar string1 index1))
-	     (setq char2 (schar string2 index2))
-	     (if (not (char-equal char1 char2))
-		 (if ,character-test
-		     (return (- index1 offset1))
-		     (return ())))))))))
-
-) ; eval-when
-
-(defun string-lessp* (string1 string2 start1 end1 start2 end2)
-  (declare (fixnum start1 start2))
-  (string-less-greater-equal t nil))
-
-(defun string-greaterp* (string1 string2 start1 end1 start2 end2)
-  (declare (fixnum start1 start2))
-  (string-less-greater-equal nil nil))
-
-(defun string-not-lessp* (string1 string2 start1 end1 start2 end2)
-  (declare (fixnum start1 start2))
-  (string-less-greater-equal nil t))
-
-(defun string-not-greaterp* (string1 string2 start1 end1 start2 end2)
-  (declare (fixnum start1 start2))
-  (string-less-greater-equal t t))
-
-(defun string-lessp (string1 string2 &key (start1 0) end1 (start2 0) end2)
-  "Given two strings, if the first string is lexicographically less than
-  the second string, returns the longest common prefix (using char-equal)
-  of the two strings. Otherwise, returns ()."
-  (string-lessp* string1 string2 start1 end1 start2 end2))
-
-(defun string-greaterp (string1 string2 &key (start1 0) end1 (start2 0) end2)
-  "Given two strings, if the first string is lexicographically greater than
-  the second string, returns the longest common prefix (using char-equal)
-  of the two strings. Otherwise, returns ()."
-  (string-greaterp* string1 string2 start1 end1 start2 end2))
-
-(defun string-not-lessp (string1 string2 &key (start1 0) end1 (start2 0) end2)
-  "Given two strings, if the first string is lexicographically greater
-  than or equal to the second string, returns the longest common prefix
-  (using char-equal) of the two strings. Otherwise, returns ()."
-  (string-not-lessp* string1 string2 start1 end1 start2 end2))
-
-(defun string-not-greaterp (string1 string2 &key (start1 0) end1 (start2 0)
-				    end2)
-  "Given two strings, if the first string is lexicographically less than
-  or equal to the second string, returns the longest common prefix
-  (using char-equal) of the two strings. Otherwise, returns ()."
-  (string-not-greaterp* string1 string2 start1 end1 start2 end2))
-
-
-(defun make-string (count &key ((:initial-element fill-char)))
-  "Given a character count and an optional fill character, makes and returns
-   a new string Count long filled with the fill character."
-  (declare (fixnum count))
-  (if fill-char
-      (do ((i 0 (1+ i))
-	   (string (make-string count)))
-	  ((= i count) string)
-	(declare (fixnum i))
-	(setf (schar string i) fill-char))
-      (make-string count)))
-
-(defun string-upcase (string &key (start 0) end)
-  "Given a string, returns a new string that is a copy of it with
-  all lower case alphabetic characters converted to uppercase."
-  (declare (fixnum start))
-  (if (symbolp string) (setq string (symbol-name string)))
-  (let ((slen (length string))
-	(offset 0))
-    (declare (fixnum slen offset))
-    (with-one-string string start end offset
-      (let ((offset-slen (+ slen offset))
-	    (newstring (make-string slen)))
-	(declare (fixnum offset-slen))
-	(do ((index offset (1+ index))
-	     (new-index 0 (1+ new-index)))
-	    ((= index start))
-	  (declare (fixnum index new-index))
-	  (setf (schar newstring new-index) (schar string index)))
-	(do ((index start (1+ index))
-	     (new-index (- start offset) (1+ new-index)))
-	    ((= index (the fixnum end)))
-	  (declare (fixnum index new-index))
-	  (setf (schar newstring new-index)
-		(char-upcase (schar string index))))
-	(do ((index end (1+ index))
-	     (new-index (- (the fixnum end) offset) (1+ new-index)))
-	    ((= index offset-slen))
-	  (declare (fixnum index new-index))
-	  (setf (schar newstring new-index) (schar string index)))
-	newstring))))
-
-(defun string-downcase (string &key (start 0) end)
-  "Given a string, returns a new string that is a copy of it with
-  all upper case alphabetic characters converted to lowercase."
-  (declare (fixnum start))
-  (if (symbolp string) (setq string (symbol-name string)))
-  (let ((slen (length string))
-	(offset 0))
-    (declare (fixnum slen offset))
-    (with-one-string string start end offset
-      (let ((offset-slen (+ slen offset))
-	    (newstring (make-string slen)))
-	(declare (fixnum offset-slen))
-	(do ((index offset (1+ index))
-	     (new-index 0 (1+ new-index)))
-	    ((= index start))
-	  (declare (fixnum index new-index))
-	  (setf (schar newstring new-index) (schar string index)))
-	(do ((index start (1+ index))
-	     (new-index (- start offset) (1+ new-index)))
-	    ((= index (the fixnum end)))
-	  (declare (fixnum index new-index))
-	  (setf (schar newstring new-index)
-		(char-downcase (schar string index))))
-	(do ((index end (1+ index))
-	     (new-index (- (the fixnum end) offset) (1+ new-index)))
-	    ((= index offset-slen))
-	  (declare (fixnum index new-index))
-	  (setf (schar newstring new-index) (schar string index)))
-	newstring))))
-
-(defun string-capitalize (string &key (start 0) end)
-  "Given a string, returns a copy of the string with the first
-  character of each ``word'' converted to upper-case, and remaining
-  chars in the word converted to lower case. A ``word'' is defined
-  to be a string of case-modifiable characters delimited by
-  non-case-modifiable chars."
-  (declare (fixnum start))
-  (if (symbolp string) (setq string (symbol-name string)))
-  (let ((slen (length string))
-	(offset 0))
-    (declare (fixnum slen offset))
-    (with-one-string string start end offset
-      (let ((offset-slen (+ slen offset))
-	    (newstring (make-string slen)))
-	(declare (fixnum offset-slen))
-	(do ((index offset (1+ index))
-	     (new-index 0 (1+ new-index)))
-	    ((= index start))
-	  (declare (fixnum index new-index))
-	  (setf (schar newstring new-index) (schar string index)))
-	(do ((index start (1+ index))
-	     (new-index (- start offset) (1+ new-index))
-	     (newword t)
-	     (char ()))
-	    ((= index (the fixnum end)))
-	  (declare (fixnum index new-index))
-	  (setq char (schar string index))
-	  (cond ((not (alphanumericp char))
-		 (setq newword t))
-		(newword
-		 ;;char is first case-modifiable after non-case-modifiable
-		 (setq char (char-upcase char))
-		 (setq newword ()))
-		;;char is case-modifiable, but not first
-		(t (setq char (char-downcase char))))
-	  (setf (schar newstring new-index) char))
-	(do ((index end (1+ index))
-	     (new-index (- (the fixnum end) offset) (1+ new-index)))
-	    ((= index offset-slen))
-	  (declare (fixnum index new-index))
-	  (setf (schar newstring new-index) (schar string index)))
-	newstring))))
-
-(defun nstring-upcase (string &key (start 0) end)
-  "Given a string, returns that string with all lower case alphabetic
-  characters converted to uppercase."
-  (declare (fixnum start))
-  (let ((save-header string)
-	offset)
-    (with-one-string string start end offset
-      (do ((index start (1+ index)))
-	  ((= index (the fixnum end)))
-	(declare (fixnum index))
-	(setf (schar string index) (char-upcase (schar string index)))))
-    save-header))
-
-(defun nstring-downcase (string &key (start 0) end)
-  "Given a string, returns that string with all upper case alphabetic
-  characters converted to lowercase."
-  (declare (fixnum start))
-  (let ((save-header string)
-	offset)
-    (with-one-string string start end offset
-      (do ((index start (1+ index)))
-	  ((= index (the fixnum end)))
-	(declare (fixnum index))
-	(setf (schar string index) (char-downcase (schar string index)))))
-    save-header)))
-
-(defun nstring-capitalize (string &key (start 0) end)
-  "Given a string, returns that string with the first
-  character of each ``word'' converted to upper-case, and remaining
-  chars in the word converted to lower case. A ``word'' is defined
-  to be a string of case-modifiable characters delimited by
-  non-case-modifiable chars."
-  (declare (fixnum start))
-  (let ((save-header string)
-	offset)
-    (with-one-string string start end offset
-      (do ((index start (1+ index))
-	   (newword t)
-	   (char ()))
-	  ((= index (the fixnum end)))
-	(declare (fixnum index))
-	(setq char (schar string index))
-	(cond ((not (alphanumericp char))
-	       (setq newword t))
-	      (newword
-	       ;;char is first case-modifiable after non-case-modifiable
-	       (setf (schar string index) (char-upcase char))
-	       (setq newword ()))
-	      (t
-	       (setf (schar string index) (char-downcase char))))))
-    save-header))
-
-(defun string-left-trim (char-bag string)
-  "Given a set of characters (a list or string) and a string, returns
-  a copy of the string with the characters in the set removed from the
-  left end."
-  (with-string string
-    (do ((index start (1+ index)))
-	((or (= index (the fixnum end))
-	     (not (find (schar string index) char-bag)))
-	 (subseq (the simple-string string) index end))
-      (declare (fixnum index)))))
-
-(defun string-right-trim (char-bag string)
-  "Given a set of characters (a list or string) and a string, returns
-  a copy of the string with the characters in the set removed from the
-  right end."
-  (with-string string
-    (do ((index (1- (the fixnum end)) (1- index)))
-	((or (< index start) (not (find (schar string index) char-bag)))
-	 (subseq (the simple-string string) start (1+ index)))
-      (declare (fixnum index)))))
-
-(defun string-trim (char-bag string)
-  "Given a set of characters (a list or string) and a string, returns a
-  copy of the string with the characters in the set removed from both
-  ends."
-  (with-string string
-    (let* ((left-end (do ((index start (1+ index)))
-			 ((or (= index (the fixnum end))
-			      (not (find (schar string index) char-bag)))
-			  index)
-		       (declare (fixnum index))))
-	   (right-end (do ((index (1- (the fixnum end)) (1- index)))
-			  ((or (< index left-end)
-			       (not (find (schar string index) char-bag)))
-			   (1+ index))
-			(declare (fixnum index)))))
-      (subseq (the simple-string string) left-end right-end))))
diff --git a/code/struct.lisp b/code/struct.lisp
deleted file mode 100644
index 30a144080d97c1d608c0d25f08d8ca8c4e590e5c..0000000000000000000000000000000000000000
--- a/code/struct.lisp
+++ /dev/null
@@ -1,159 +0,0 @@
-;;; -*- Log: code.log; Package: Lisp -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    This file contains structure definitions that need to be compiled early
-;;; for bootstrapping reasons.
-;;;
-(in-package 'lisp)
-
-;;;; Defstruct structures:
-
-(in-package 'c)
-
-;;; Initialization hacks:
-
-#+new-compiler
-(progn
-;;; Make these types be sort-of-defined to allow bootstrapping.
-(setf (info type defined-structure-info 'defstruct-description)
-      (make-defstruct-description))
-
-(setf (info type defined-structure-info 'defstruct-slot-description)
-      (make-defstruct-description))
-
-
-;;; Define this now so that EQUAL works:
-;;;
-(defun pathnamep (x)
-  (and (structurep x)
-       (eq (%primitive header-ref x %g-vector-structure-name-slot)
-	   'pathname)))
-
-;;; Define so that we can test for VOLATILE-INFO-ENVs from the beginning of
-;;; initialization.
-;;;
-(defun c::volatile-info-env-p (x)
-  (and (structurep x)
-       (eq (%primitive header-ref x %g-vector-structure-name-slot)
-	   'c::volatile-info-env)))
-
-;;; Not really a structure, but at least a type-related initialization hack:
-;;;
-(deftype c::inlinep ()
-  '(member :inline :maybe-inline :notinline nil))
-;;;
-(deftype c::boolean ()
-  '(member t nil))
-
-); #+new-compiler
-
-
-(defstruct (defstruct-description
-             (:conc-name dd-)
-             (:print-function print-defstruct-description))
-  name				; name of the structure
-  doc				; documentation on the structure
-  slots				; list of slots
-  conc-name			; prefix for slot names
-  constructor			; name of standard constructor function
-  boa-constructors		; BOA constructors (cdr of option).
-  copier			; name of copying function
-  predicate			; name of type predictate
-  include			; name of included structure
-  (includes ())			; names of all structures included by this one
-  (included-by ())		; names of all strctures that include this one 
-  print-function		; function used to print it
-  type				; type specified, Structure if no type specified.
-  lisp-type			; actual type used for implementation.
-  named				; T if named, Nil otherwise
-  offset			; first slot's offset into implementation sequence
-  (length nil :type (or fixnum null))) ; total length of the thing
-
-
-(defstruct (defstruct-slot-description
-             (:conc-name dsd-)
-             (:print-function print-defstruct-slot-description))
-  %name				; string name of slot
-  (index nil :type fixnum)	; its position in the implementation sequence
-  accessor			; name of it accessor function
-  default			; default value
-  type				; declared type
-  read-only)			; T if there's to be no setter for it
-
-
-(in-package 'lisp)
-
-;;;; The stream structure:
-
-(defconstant in-buffer-length 100 "The size of a stream in-buffer.")
-
-(defstruct (stream (:predicate streamp) (:print-function %print-stream))
-  (in-buffer nil)				; Buffered input
-  (in-index in-buffer-length :type fixnum)	; Index into in-buffer
-  (in #'ill-in)					; Read-Char function
-  (bin #'ill-bin)				; Byte input function
-  (n-bin #'ill-bin)				; N-Byte input function
-  (out #'ill-out)				; Write-Char function
-  (bout #'ill-bout)				; Byte output function
-  (sout #'ill-out)				; String output function
-  (misc #'do-nothing))				; Less used methods
-
-
-;;;; Alien structures:
- 
-(defstruct (alien-value
-	    (:constructor make-alien-value (sap offset size type))
-	    (:print-function %print-alien-value))
-  "This structure represents an Alien value."
-  sap
-  offset
-  size
-  type)
-
-(defstruct (ct-a-val
-	    (:print-function
-	     (lambda (s stream d)
-	       (declare (ignore s d))
-	       (write-string "#<Alien compiler info>" stream))))
-  type		; Type of expression, NIL if unknown.
-  size		; Expression for the size of the alien.
-  sap		; Expression for SAP.
-  offset	; Expression for bit offset.
-  alien)	; Expression for alien-value or NIL.
-
-
-(defstruct (alien-info
-	    (:print-function %print-alien-info)
-	    (:constructor
-	     make-alien-info (function num-args arg-types result-type)))
-  function	; The function the definition was made into.
-  num-args	; The total number of arguments.
-  arg-types	; Alist of arg numbers to types of Alien args.
-  result-type)	; The type of the resulting Alien.
-
-
-(defstruct (stack-info
-	    (:print-function
-	     (lambda (s stream d)
-	       (declare (ignore s d))
-	       (format stream "#<Alien stack info>"))))
-  type
-  size
-  head
-  current
-  grow)
-
-
-(defstruct enumeration-info
-  signed	; True if minimum value negative.
-  size		; Minimum number of bits needed to hold value.
-  from		; Symbol holding alist from keywords to integers.
-  to		; Symbol holding alist or vector from integers to keywords.
-  kind		; Kind of from mapping, :vector or :alist.
-  offset)	; Offset to add to value for :vector from mapping.
diff --git a/code/symbol.lisp b/code/symbol.lisp
deleted file mode 100644
index 50f0598a22d901c9f359196c4f6062545adc516f..0000000000000000000000000000000000000000
--- a/code/symbol.lisp
+++ /dev/null
@@ -1,189 +0,0 @@
-;;; -*- Log: code.log; Package: Lisp -*-
-;;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; Symbol manipulating functions for Spice Lisp.
-;;;
-;;; Written by Scott Fahlman.
-;;; Hacked on and maintained by Skef Wholey.
-;;;
-;;; Many of these are trivial interpreter entries to functions
-;;; open-coded by the compiler.
-;;;
-(in-package 'lisp)
-(export '(get remprop symbol-plist getf get-properties symbol-name
-	  make-symbol copy-symbol gensym gentemp *gensym-counter*
-	  symbol-package keywordp makunbound symbol-value symbol-function
-	  boundp set))
-
-(defun set (variable new-value)
-  "VARIABLE must evaluate to a symbol.  This symbol's special value cell is
-  set to the specified new value."
-  (set variable new-value))
-
-(defun makunbound (variable)
-  "VARIABLE must evaluate to a symbol.  This symbol is made unbound,
-  removing any value it may currently have."
-  (makunbound variable))
-
-(defun symbol-value (variable)
-  "VARIABLE must evaluate to a symbol.  This symbol's current special
-  value is returned."
-  (symbol-value variable))
-
-(defun symbol-function (variable)
-  "VARIABLE must evaluate to a symbol.  This symbol's current definition
-  is returned."
-  (symbol-function variable))
-
-(defun %sp-set-definition (symbol new-value)
-  (setf (symbol-function symbol) new-value))
-
-(defun boundp (variable)
-  "VARIABLE must evaluate to a symbol.  Return () if this symbol is
-  unbound, T if it has a value."
-  (boundp variable))
-
-(defun symbol-plist (variable)
-  "VARIABLE must evaluate to a symbol.  Return its property list."
-  (symbol-plist variable))
-
-(defun %sp-set-plist (symbol new-value)
-  (setf (symbol-plist symbol) new-value))
-
-(defun symbol-name (variable)
-  "VARIABLE must evaluate to a symbol.  Return its print name."
-  (symbol-name variable))
-
-(defun symbol-package (variable)
-  "VARIABLE must evaluate to a symbol.  Return its package."
-  (symbol-package variable))
-
-(defun make-symbol (string)
-  "Make and return a new symbol with the STRING as its print name."
-  (make-symbol string))
-
-(defun get (symbol indicator &optional (default nil))
-  "Look on the property list of SYMBOL for the specified INDICATOR.  If this
-  is found, return the associated value, else return DEFAULT."
-  (do ((pl (symbol-plist symbol) (cddr pl)))
-      ((atom pl) default)
-    (cond ((atom (cdr pl))
-	   (error "~S has an odd number of items in its property list."
-		   symbol))
-	  ((eq (car pl) indicator)
-	   (return (cadr pl))))))
-
-(defun %put (symbol indicator value)
-  "The VALUE is added as a property of SYMBOL under the specified INDICATOR.
-  Returns VALUE."
-  (%primitive put symbol indicator value)
-#|  (do ((pl (symbol-plist symbol) (cddr pl)))
-      ((atom pl)
-       (setf (symbol-plist symbol)
-	     (list* indicator value (symbol-plist symbol)))
-       value)
-    (cond ((atom (cdr pl))
-	   (error "~S has an odd number of items in its property list."
-		  symbol))
-	  ((eq (car pl) indicator)
-	   (rplaca (cdr pl) value)
-	   (return value))))|#
-  )
-
-(defun remprop (symbol indicator)
-  "Look on property list of SYMBOL for property with specified
-  INDICATOR.  If found, splice this indicator and its value out of
-  the plist, and return the tail of the original list starting with
-  INDICATOR.  If not found, return () with no side effects."
-  (do ((pl (symbol-plist symbol) (cddr pl))
-       (prev nil pl))
-      ((atom pl) nil)
-    (cond ((atom (cdr pl))
-	   (error "~S has an odd number of items in its property list."
-		  symbol))
-	  ((eq (car pl) indicator)
-	   (cond (prev (rplacd (cdr prev) (cddr pl)))
-		 (t
-		  (setf (symbol-plist symbol) (cddr pl))))
-	   (return pl)))))
-
-(defun getf (place indicator &optional (default ()))
-  "Searches the property list stored in Place for an indicator EQ to Indicator.
-  If one is found, the corresponding value is returned, else the Default is
-  returned."
-  (do ((plist place (cddr plist)))
-      ((null plist) default)
-    (cond ((atom (cdr plist))
-	   (error "~S is a malformed property list."
-		  place))
-	  ((eq (car plist) indicator)
-	   (return (cadr plist))))))
-
-
-(defun get-properties (place indicator-list)
-  "Like GETF, except that Indicator-List is a list of indicators which will
-  be looked for in the property list stored in Place.  Three values are
-  returned, see manual for details."
-  (do ((plist place (cddr plist)))
-      ((null plist) (values nil nil nil))
-    (cond ((atom (cdr plist))
-	   (error "~S is a malformed proprty list."
-		  place))
-	  ((memq (car plist) indicator-list)
-	   (return (values (car plist) (cadr plist) plist))))))
-
-(defun copy-symbol (symbol &optional (copy-props nil) &aux new-symbol)
-  "Make and return a new uninterned symbol with the same print name
-  as SYMBOL.  If COPY-PROPS is null, the new symbol has no properties.
-  Else, it has a copy of SYMBOL's property list."
-  (setq new-symbol (make-symbol (symbol-name symbol)))
-  (if copy-props
-      (setf (symbol-plist new-symbol) (copy-list (symbol-plist symbol))))
-  new-symbol)
-
-(proclaim '(special *keyword-package*))
-
-(defun keywordp (object)
-  "Returns true if Object is a symbol in the keyword package."
-  (and (symbolp object)
-       (eq (symbol-package object) *keyword-package*)))
-
-
-;;;; Gensym and friends.
-
-(defvar *gensym-counter* 0
-  "Counter for generating unique GENSYM symbols.")
-
-(defun gensym (&optional string)
-  "Creates a new uninterned symbol whose name is a prefix string (defaults
-  to \"G\"), followed by a decimal number.  String, when supplied, will
-  alter the prefix if it is a string, or the decimal number if it is a
-  number, of this symbol.  The number, defaultly *gensym-counter*, is
-  incremented by each call to GENSYM."
-  (let* ((*print-base* 10)
-	 (*print-radix* nil)
-	 (*print-pretty* nil)
-	 (prefix (if (stringp string) string "G"))
-	 (number (prin1-to-string (if (numberp string)
-				      string
-				      (incf *gensym-counter*)))))
-    (make-symbol (concatenate 'simple-string prefix number))))
-
-(defun gentemp (&optional (prefix t) (package *package*))
-  "Creates a new symbol interned in package Package with the given Prefix."
-  (loop
-    (let ((*print-base* 10)
-	  (*print-radix* nil)
-	  (*print-pretty* nil)
-	  (new-pname (format nil "~A~D"
-			     (string prefix) (incf *gensym-counter*))))
-      (multiple-value-bind (symbol existsp)
-			   (find-symbol new-pname package)
-	(declare (ignore symbol))
-	(unless existsp (return (values (intern new-pname package))))))))
diff --git a/code/sysmacs.lisp b/code/sysmacs.lisp
deleted file mode 100644
index 95693b1a23b3a50ef5ee8cd2ba3387328ec8e60d..0000000000000000000000000000000000000000
--- a/code/sysmacs.lisp
+++ /dev/null
@@ -1,274 +0,0 @@
-;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    Miscellaneous system hacking macros.
-;;;
-(in-package "LISP" :use '("SYSTEM" "DEBUG"))
-
-#-new-compiler
-(eval-when (compile)
-  (setq lisp::*bootstrap-defmacro* t))
-
-;;; WITH-ARRAY-DATA follows an arbitrarily long chain of displaced arrays
-;;; binding data-var to the data vector, offset-var to the cumulative
-;;; displacement offset, start-var to the actual start index in the data
-;;; vector, and end-var to the actual end of the data vector.  Put all the
-;;; bindings in the LET, so declarations can be made on the variables (for
-;;; example, declaring data-var to be a simple-string.
-(defmacro with-array-data (((data-var array &key (offset-var (gensym)))
-			    (start-var &optional (svalue 0))
-			    (end-var &optional (evalue nil)))
-			   &rest forms)
-  "Bind data-var to the data-vector eventually reached by following displacement
-   links from array, offset-var to a cumulative offset, start-var to the first
-   index in the data vector, and end-var to the total length of the array plus
-   the cumulative offset.  Offset-var, start-var, and end-var are declared to be
-   fixnums."
-  `(multiple-value-bind (,data-var ,offset-var)
-			(find-data-vector ,array)
-     (let* ((,data-var ,data-var)
-	    (,offset-var ,offset-var)
-	    (,start-var (+ ,svalue ,offset-var))
-	    (,end-var (+ ,offset-var (or ,evalue (array-total-size ,array)))))
-       (declare (fixnum ,offset-var ,start-var ,end-var))
-       ,@forms)))
-
-
-(defmacro %displacedp (array-header)
-  `(= (the fixnum (%primitive get-vector-subtype ,array-header))
-      (the fixnum %array-displaced-subtype)))
-
-(defmacro %set-array-displacedp (array-header value)
-  `(%primitive set-vector-subtype ,array-header
-	       (if ,value %array-displaced-subtype %array-normal-subtype)))
-
-
-(defmacro without-gcing (&rest body)
-  "Executes the forms in the body without doing a garbage collection."
-  `(multiple-value-prog1
-       (let ((*gc-inhibit* t))
-	 ,@body)
-     (when (and *need-to-collect-garbage* (not *gc-inhibit*))
-       (maybe-gc nil))))
-
-
-(defmacro with-interrupts (&body body)
-  `(let ((iin %sp-interrupts-inhibited))
-     (setq %sp-interrupts-inhibited NIL)
-     (when (consp iin)
-       (dolist (x iin)
-	 (let ((f (svref *software-interrupt-vector* (car x))))
-	   (when f (apply f x)))))
-     (unwind-protect
-	 (progn ,@body)
-       (if iin (setq %sp-interrupts-inhibited T)))))
-
-(defmacro without-interrupts (&rest body)
-  "Evaluates the forms in the Body without allowing interrupts."
-  `(let* ((old-interrupts-inhibited %sp-interrupts-inhibited)
-	  (%sp-interrupts-inhibited (or %sp-interrupts-inhibited T)))
-     (multiple-value-prog1
-       (progn ,@body)
-       (when (and (null old-interrupts-inhibited)
-		  (consp %sp-interrupts-inhibited))
-	 (dolist (x %sp-interrupts-inhibited)
-	   (let ((f (svref *software-interrupt-vector* (car x))))
-	     (when f (apply f x))))))))
-
-
-(defmacro with-enabled-interrupts (interrupt-list &body body)
-  "With-enabled-interrupts ({(interrupt function [character])}*) {form}*
-  Establish function as a handler for the Unix signal interrupt which
-  should be a number between 1 and 31 inclusive.  For the signals that
-  can be generated from the keyboard, the optional character specifies
-  the character to use to generate the signal."
-  (let ((il (gensym))
-	(fn (gensym))
-	(ch (gensym))
-	(it (gensym)))
-    `(let ((,il NIL))
-       (unwind-protect
-	   (progn
-	     ,@(do* ((item interrupt-list (cdr item))
-		     (intr (caar item) (caar item))
-		     (ifcn (cadar item) (cadar item))
-		     (ichr (caddar item) (caddar item))
-		     (forms NIL))
-		    ((null item) (nreverse forms))
-		 (if (symbolp intr)
-		     (setq intr (symbol-value intr)))
-		 (push `(multiple-value-bind (,fn ,ch)
-					     (enable-interrupt ,intr ,ifcn
-							       ,ichr)
-			  (push `(,,intr ,,fn ,,ch) ,il)) forms))
-	     ,@body)
-	 (dolist (,it (nreverse ,il))
-	   (funcall #'enable-interrupt (car ,it) (cadr ,it) (caddr ,it)))))))
-
-
-(defvar hi::*in-the-editor* nil)
-
-(defmacro without-hemlock (&body body)
-  `(progn
-     (when (and hi::*in-the-editor* (null debug::*in-the-debugger*))
-       (let ((device (hi::device-hunk-device
-		      (hi::window-hunk (hi::current-window)))))
-	 (funcall (hi::device-exit device) device)))
-     ,@body
-     (when (and hi::*in-the-editor* (null debug::*in-the-debugger*))
-       (let ((device (hi::device-hunk-device
-		      (hi::window-hunk (hi::current-window)))))
-	 (funcall (hi::device-init device) device)))))
-
-
-;;; With-Reply-Port  --  Public    
-;;;
-;;;    If we find that the number of ports in use (as indicated by
-;;; *reply-port-pointer*) disagrees with our dynamic depth in
-;;; With-Reply-Port forms (as indicated by *reply-port-depth*),
-;;; then we must have been unwound at some point in the past.
-;;; We reallocate the ports that were in use when we were
-;;; unwound, since they may have random messages hanging on them.
-;;;
-(defmacro with-reply-port ((var) &body body)
-  "With-Reply-Port (Var) {Form}*
-  Binds Var to a port during the evaluation of the Forms."
-  (let ((index (gensym))
-	(old-flag (gensym))
-	(res (gensym)))
-    `(let ((,old-flag %sp-interrupts-inhibited)
-	   ,res)
-       (without-interrupts
-	(let* ((,index *reply-port-depth*)
-	       (*reply-port-depth* (1+ ,index))
-	       ,var)
-	  (unless (eql ,index *reply-port-pointer*)
-	    (reallocate-reply-ports ,index))
-	  (setq ,var (svref *reply-port-stack* ,index))
-	  (setq *reply-port-pointer* (1+ ,index))
-	  (unless ,var (setq ,var (allocate-new-reply-ports)))
-	  (setq %sp-interrupts-inhibited ,old-flag)
-	  (setq ,res (multiple-value-list (progn ,@body)))
-	  (when (eql (car ,res) mach:rcv-timed-out)
-	    (gr-call mach:port_deallocate *task-self* ,var)
-	    (setf (svref *reply-port-stack* ,index)
-		  (gr-call* mach:port_allocate *task-self*)))
-	  (setq %sp-interrupts-inhibited (or ,old-flag T))
-	  (if (eql ,index (1- *reply-port-pointer*))
-	      (setq *reply-port-pointer* ,index)
-	      (reallocate-reply-ports (1+ ,index)))
-	  (values-list ,res))))))
-
-
-;;; Eof-Or-Lose is a useful macro that handles EOF.
-
-(defmacro eof-or-lose (stream eof-errorp eof-value)
-  `(if ,eof-errorp
-       (error "~S: Stream hit EOF unexpectedly." ,stream)
-       ,eof-value))
-
-;;; These macros handle the special cases of t and nil for input and
-;;; output streams.
-;;;
-(defmacro in-synonym-of (stream)
-  (let ((svar (gensym)))
-    `(let ((,svar ,stream))
-       (cond ((null ,svar) *standard-input*)
-	     ((eq ,svar t) *terminal-io*)
-	     (t (check-type ,svar stream)
-		,svar)))))
-
-(defmacro out-synonym-of (stream)
-  (let ((svar (gensym)))
-    `(let ((,svar ,stream))
-       (cond ((null ,svar) *standard-output*)
-	     ((eq ,svar t) *terminal-io*)
-	     (T (check-type ,svar stream)
-		,svar)))))
-
-;;; With-Mumble-Stream calls the function in the given Slot of the Stream with
-;;; the Args.
-;;;
-(defmacro with-in-stream (stream slot &rest args)
-  `(let ((stream (in-synonym-of ,stream)))
-     (funcall (,slot stream) stream ,@args)))
-
-(defmacro with-out-stream (stream slot &rest args)
-  `(let ((stream (out-synonym-of ,stream)))
-     (funcall (,slot stream) stream ,@args)))
-
-
-;;;; These are hacks to make the reader win.
-
-;;; Prepare-For-Fast-Read-Char  --  Internal
-;;;
-;;;    This macro sets up some local vars for use by the Fast-Read-Char
-;;; macro within the enclosed lexical scope.
-;;;
-(defmacro prepare-for-fast-read-char (stream &body forms)
-  `(let* ((%frc-stream% (in-synonym-of ,stream))
-	  (%frc-method% (stream-in %frc-stream%))
-	  (%frc-buffer% (stream-in-buffer %frc-stream%))
-	  (%frc-index% (stream-in-index %frc-stream%)))
-     (declare (type (or simple-string null) %frc-buffer%) (fixnum %frc-index%))
-     ,@forms))
-
-;;; Done-With-Fast-Read-Char  --  Internal
-;;;
-;;;    This macro must be called after one is done with fast-read-char
-;;; inside it's scope to decache the stream-in-index.
-;;;
-(defmacro done-with-fast-read-char ()
-  `(setf (stream-in-index %frc-stream%) %frc-index%))
-
-;;; Fast-Read-Char  --  Internal
-;;;
-;;;    This macro can be used instead of Read-Char within the scope of
-;;; a Prepare-For-Fast-Read-Char.
-;;;
-(defmacro fast-read-char (&optional (eof-errorp t) (eof-value ()))
-  `(cond
-    ((= %frc-index% in-buffer-length)
-     (setf (stream-in-index %frc-stream%) %frc-index%)
-     (prog1 (funcall %frc-method% %frc-stream% ,eof-errorp ,eof-value)
-	    (setq %frc-index% (stream-in-index %frc-stream%))))
-    (t
-     (prog1 (aref %frc-buffer% %frc-index%)
-	    (incf %frc-index%)))))
-
-;;;; And these for the fasloader...
-
-;;; Prepare-For-Fast-Read-Byte  --  Internal
-;;;
-;;;    Just like Prepare-For-Fast-Read-Char except that we get the Bin
-;;; method.
-;;;
-(defmacro prepare-for-fast-read-byte (stream &body forms)
-  `(let* ((%frc-stream% (in-synonym-of ,stream))
-	  (%frc-method% (stream-bin %frc-stream%))
-	  (%frc-buffer% (stream-in-buffer %frc-stream%))
-	  (%frc-index% (stream-in-index %frc-stream%)))
-     (declare (type (or simple-array null) %frc-buffer%) (fixnum %frc-index%))
-     ,@forms))
-
-;;; Fast-Read-Byte, Done-With-Fast-Read-Byte  --  Internal
-;;;
-;;;    Identical to the text versions, but we get some gratuitous
-;;; psuedo-generality by having different names.
-;;;
-(defmacro done-with-fast-read-byte ()
-  `(done-with-fast-read-char))
-;;;
-(defmacro fast-read-byte (&rest stuff)
-  `(fast-read-char ,@stuff))
-
-
-#-new-compiler
-(eval-when (compile)
-  (setq lisp::*bootstrap-defmacro* nil))
diff --git a/code/time.lisp b/code/time.lisp
deleted file mode 100644
index 0b99f9bb19c337daf9b2172b72f6116985b6b386..0000000000000000000000000000000000000000
--- a/code/time.lisp
+++ /dev/null
@@ -1,383 +0,0 @@
-;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    This file contains the definitions for the Spice Lisp time functions.
-;;; They are mostly fairly straightforwardly implemented as calls to the 
-;;; time server.
-;;;
-;;;    Written by Rob MacLachlan.
-;;;
-(in-package 'lisp)
-(export '(internal-time-units-per-second get-internal-real-time
-	  get-internal-run-time get-universal-time
-	  get-decoded-time encode-universal-time decode-universal-time))
-
-(defconstant internal-time-units-per-second 100
-  "The number of internal time units that fit into a second.  See
-  Get-Internal-Real-Time and Get-Internal-Run-Time.")
-
-(defmacro not-leap-year (year)
-  (let ((sym (gensym)))
-    `(let ((,sym ,year))
-       (cond ((eq (mod ,sym 4) 0)
-	      (and (eq (mod ,sym 100) 0)
-		   (not (eq (mod ,sym 400) 0))))
-	     (T T)))))
-
-;;; Get-Internal-Real-Time  --  Public
-;;;
-;;;
-(defun get-internal-real-time ()
-  "Return the real time in the internal time format.  This is useful for
-  finding elapsed time.  See Internal-Time-Units-Per-Second."
-  (let ((val (system:%primitive get-real-time)))
-    (when (eq val -1)
-      (error "Failed to get real time."))
-    val))
-
-#|
-(defun get-internal-real-time ()
-  "Return the real time in the internal time format.  This is useful for
-  finding elapsed time.  See Internal-Time-Units-Per-Second."
-  (multiple-value-bind (result seconds useconds) (mach:unix-gettimeofday)
-    (if result (+ (* seconds internal-time-units-per-second) useconds)
-	(error "Unix system call gettimeofday failed: ~A"
-	       (mach:get-unix-error-msg seconds)))))
-|#
-
-;;; Get-Internal-Run-Time  --  Public
-;;;
-;;; PmGetTimes returns run time in microseconds.  Convert to jiffies.
-;;;
-(defun get-internal-run-time ()
-  "Return the run time in the internal time format.  This is useful for
-  finding CPU usage."
-  (let ((val (system:%primitive get-run-time)))
-    (when (eq val -1)
-      (error "Failed to obtain run time."))
-    val))
-
-#|
-(defun get-internal-run-time ()
-  "Return the run time in the internal time format.  This is useful for
-  finding CPU usage."
-  (multiple-value-bind (result utime stime)
-		       (mach:unix-getrusage mach:rusage_self)
-    (if result (+ utime stime)
-	(error "Unix system call getrusage failed: ~A"
-	       (mach:get-unix-error-msg utime)))))
-|#
-
-;;; Subtract from the returned Internal_Time to get the universal time.
-;;; The offset between our time base and the Perq one is 2145 weeks and
-;;; five days.
-;;;
-(defconstant seconds-in-week (* 60 60 24 7))
-(defconstant weeks-offset 2145)
-(defconstant seconds-offset 432000)
-(defconstant minutes-per-day (* 24 60))
-(defconstant quarter-days-per-year (1+ (* 365 4)))
-(defconstant quarter-days-per-century 146097)
-(defconstant november-17-1858 678882)
-(defconstant weekday-november-17-1858 2)
-(defconstant unix-to-universal-time 2208988800)
-
-;;; Make-Universal-Time  --  Internal
-;;;
-;;;    Convert a Unix Internal_Time into a universal time.
-;;;
-(defun make-universal-time (weeks msec)
-  (+ (* (- weeks weeks-offset) seconds-in-week)
-     (- (truncate msec 1000) seconds-offset)))
-
-
-;;; Get-Universal-Time  --  Public
-;;;
-;;;
-(defun get-universal-time ()
-  "Returns a single integer for the current time of
-   day in universal time format."
-  (multiple-value-bind (res secs) (mach:unix-gettimeofday)
-    (declare (ignore res))
-    (+ secs unix-to-universal-time)))
-
-(defun get-decoded-time ()
-  "Returns nine values specifying the current time as follows:
-   second, minute, hour, date, month, year, day of week (0 = Monday), T
-   (daylight savings times) or NIL (standard time), and timezone."
-  (decode-universal-time (get-universal-time)))
-
-(defun decode-universal-time (universal-time &optional time-zone)
-  "Converts a universal-time to decoded time format returning the following
-  nine values: second, minute, hour, date, month, year, day of week (0 =
-  Monday), T (daylight savings time) or NIL (standard time), and timezone.
-  Completely ignores daylight-savings-time when time-zone is supplied."
-  (declare (type (or fixnum null) time-zone))
-  (multiple-value-bind (weeks secs)
-		       (truncate (+ universal-time seconds-offset)
-				 seconds-in-week)
-    (let ((weeks (+ weeks weeks-offset))
-	  (second NIL)
-	  (minute NIL)
-	  (hour NIL)
-	  (date NIL)
-	  (month NIL)
-	  (year NIL)
-	  (day NIL)
-	  (daylight NIL)
-	  (timezone (if (null time-zone)
-			(multiple-value-bind (res s us tz)
-					     (mach:unix-gettimeofday)
-			  (declare (ignore s us))
-			  (if res tz 0))
-			(* time-zone 60))))
-      (declare (fixnum timezone))
-      (multiple-value-bind (t1 seconds) (truncate secs 60)
-	(setq second seconds)
-	(setq t1 (- t1 timezone))
-	(let* ((tday (if (< t1 0)
-			 (1- (truncate (1+ t1) minutes-per-day))
-			 (truncate t1 minutes-per-day))))
-	  (multiple-value-setq (hour minute)
-	    (truncate (- t1 (* tday minutes-per-day)) 60))
-	  (let* ((t2 (1- (* (+ (* weeks 7) tday november-17-1858) 4)))
-		 (tcent (truncate t2 quarter-days-per-century)))
-	    (setq t2 (mod t2 quarter-days-per-century))
-	    (setq t2 (+ (- t2 (mod t2 4)) 3))
-	    (setq year (+ (* tcent 100) (truncate t2 quarter-days-per-year)))
-	    (let ((days-since-mar0 (1+ (truncate (mod t2 quarter-days-per-year)
-						 4))))
-	      (setq day (mod (+ tday weekday-november-17-1858) 7))
-	      (unless time-zone
-		(if (setq daylight (dst-check days-since-mar0 hour day))
-		    (cond ((eq hour 23)
-			   (setq hour 0)
-			   (setq day (mod (1+ day) 7))
-			   (setq days-since-mar0 (1+ days-since-mar0))
-			   (if (>= days-since-mar0 366)
-			       (if (or (> days-since-mar0 366)
-				       (not-leap-year (1+ year)))
-				   (setq days-since-mar0 368))))
-			  (T (setq hour (1+ hour))))))
-	      (let ((t3 (+ (* days-since-mar0 5) 456)))
-		(cond ((>= t3 1989)
-		       (setq t3 (- t3 1836))
-		       (setq year (1+ year))))
-		(multiple-value-setq (month t3) (truncate t3 153))
-		(setq date (1+ (truncate t3 5))))))))
-      (values second minute hour date month year day
-	      daylight (truncate timezone 60)))))
-
-;;; Encode-Universal-Time  --  Public
-;;;
-;;;    Just do a TimeUser:T_UserToInt.  If the year is between 0 and 99 we 
-;;; have to figure out which the "obvious" year is.
-;;;
-
-(defun encode-universal-time (second minute hour date month year
-				     &optional time-zone)
-  "The time values specified in decoded format are converted to 
-   universal time, which is returned."
-  (let* ((year (if (< year 100)
-		   (multiple-value-bind (sec min hour day month now-year)
-					(get-decoded-time)
-		     (declare (ignore sec min hour day month))
-		     (do ((y (+ year (* 100 (1- (truncate now-year 100))))
-			     (+ y 100)))
-			 ((<= (abs (- y now-year)) 50) y)))
-		   year))
-	 (zone (if time-zone (* time-zone 60)
-		   (multiple-value-bind (res s us tz) (mach:unix-gettimeofday)
-		     (declare (ignore s us))
-		     (if res tz))))
-	 (tmonth (- month 3)))
-    (cond ((< tmonth 0)
-	   (setq tmonth (+ tmonth 12))
-	   (setq year (1- year))))
-    (let ((days-since-mar0 (+ (truncate (+ (* tmonth 153) 2) 5) date)))
-      (multiple-value-bind (tcent tyear) (truncate year 100)
-	(let* ((tday (- (+ (truncate (* tcent quarter-days-per-century) 4)
-			   (truncate (* tyear quarter-days-per-year) 4)
-			   days-since-mar0)
-			november-17-1858))
-	       (daylight (dst-check days-since-mar0 (1- hour)
-				    (mod (+ tday weekday-november-17-1858) 7)))
-	       (tminutes (+ (* hour 60) minute zone)))
-	  (if daylight (setq tminutes (- tminutes 60)))
-	  (do ((i tminutes (+ i minutes-per-day)))
-	      ((>= i 0) (setq tminutes i))
-	    (declare (fixnum i))
-	    (decf tday 1))
-	  (do ((i tminutes (- i minutes-per-day)))
-	      ((< i minutes-per-day) (setq tminutes i))
-	    (declare (fixnum i))
-	    (incf tday 1))
-	  (multiple-value-bind (weeks dpart) (truncate tday 7)
-	    (make-universal-time weeks (* (+ (* (+ (* dpart minutes-per-day)
-						   tminutes) 60)
-					     second) 1000))))))))
-
-;;; Dst-check -- Internal
-(defconstant april-1 (+ (truncate (+ (* (- 4 3) 153) 2) 5) 1))
-(defconstant october-31 (+ (truncate (+ (* (- 10 3) 153) 2) 5) 31))
-
-(eval-when (compile eval)
-  
-  (defmacro dst-check-start-of-month-ge (day hour weekday daybound)
-    (let ((d (gensym))
-	  (h (gensym))
-	  (w (gensym))
-	  (db (gensym)))
-      `(let ((,d ,day)
-	     (,h ,hour)
-	     (,w ,weekday)
-	     (,db ,daybound))
-	 (declare (fixnum ,d ,h ,w ,db))
-	 (cond ((< ,d ,db) NIL)
-	       ((> (the fixnum (- ,d ,w)) ,db) T)
-	       ((and (eq ,w 6) (> ,h 0)) T)
-	       (T NIL)))))
-  
-  (defmacro dst-check-end-of-month-ge (day hour weekday daybound)
-    (let ((d (gensym))
-	  (h (gensym))
-	  (w (gensym))
-	  (db (gensym)))
-      `(let ((,d ,day)
-	     (,h ,hour)
-	     (,w ,weekday)
-	     (,db ,daybound))
-	 (declare (fixnum ,d ,h ,w ,db))
-	 (cond ((< (the fixnum (+ ,d 6)) ,db) NIL)
-	       ((> (the fixnum  (- (the fixnum (+ ,d 6)) ,w)) ,db) T)
-	       ((and (eq ,w 6) (> ,h 0)) T)
-	       (T NIL)))))
-  )
-
-(defun dst-check (day hour weekday)
-  (and (dst-check-start-of-month-ge day hour weekday april-1)
-       (not (dst-check-end-of-month-ge day hour weekday october-31))))
-
-(defmacro time (form)
-  "Evaluates the Form and prints timing information on *Trace-Output*."
-  `(%time #'(lambda () ,form)))
-
-(defun %time (fun)
-  (let (old-run-utime
-	new-run-utime
-	old-run-stime
-	new-run-stime
-	old-real-time
-	new-real-time
-	old-page-faults
-	new-page-faults
-	real-time-overhead
-	run-utime-overhead
-	run-stime-overhead
-	page-faults-overhead
-	old-bytes-consed
-	new-bytes-consed
-	cons-overhead)
-    ;; Calculate the overhead...
-    (multiple-value-bind (err? utime stime)
-			 (mach:unix-getrusage mach:rusage_self)
-      (cond ((null err?)
-	     (error "Unix system call getrusage failed: ~A."
-		    (mach:get-unix-error-msg utime)))
-	    (T (setq old-run-utime utime)
-	       (setq old-run-stime stime))))
-    (multiple-value-bind (gr ps fc ac ic wc zf ra in ot pf)
-			 (mach:vm_statistics *task-self*)
-      (declare (ignore ps fc ac ic wc zf ra in ot))
-      (gr-error 'mach:vm_allocate gr)
-      (setq old-page-faults pf))
-    (setq old-bytes-consed (get-bytes-consed))
-    ;; Do it a second time to make sure everything is faulted in.
-    (multiple-value-bind (err? utime stime)
-			 (mach:unix-getrusage mach:rusage_self)
-      (cond ((null err?)
-	     (error "Unix system call getrusage failed: ~A."
-		    (mach:get-unix-error-msg utime)))
-	    (T (setq old-run-utime utime)
-	       (setq old-run-stime stime))))
-    (multiple-value-bind (gr ps fc ac ic wc zf ra in ot pf)
-			 (mach:vm_statistics *task-self*)
-      (declare (ignore ps fc ac ic wc zf ra in ot))
-      (gr-error 'mach:vm_statistics gr)
-      (setq old-page-faults pf))
-    (setq old-bytes-consed (get-bytes-consed))
-    
-    (multiple-value-bind (err? utime stime)
-			 (mach:unix-getrusage mach:rusage_self)
-      (cond ((null err?)
-	     (error "Unix system call getrusage failed: ~A."
-		    (mach:get-unix-error-msg utime)))
-	    (T (setq new-run-utime utime)
-	       (setq new-run-stime stime))))
-    (multiple-value-bind (gr ps fc ac ic wc zf ra in ot pf)
-			 (mach:vm_statistics *task-self*)
-      (declare (ignore ps fc ac ic wc zf ra in ot))
-      (gr-error 'mach:vm_statistics gr)
-      (setq new-page-faults pf))
-    (setq new-bytes-consed (get-bytes-consed))
-    
-    (setq run-utime-overhead (- new-run-utime old-run-utime))
-    (setq run-stime-overhead (- new-run-stime old-run-stime))
-    (setq page-faults-overhead (- new-page-faults old-page-faults))
-    (setq old-real-time (get-internal-real-time))
-    (setq old-real-time (get-internal-real-time))
-    (setq new-real-time (get-internal-real-time))
-    (setq real-time-overhead (- new-real-time old-real-time))
-    (setq cons-overhead (- new-bytes-consed old-bytes-consed))
-    ;; Now get the initial times.
-    (multiple-value-bind (err? utime stime)
-			 (mach:unix-getrusage mach:rusage_self)
-      (cond ((null err?)
-	     (error "Unix system call getrusage failed: ~A."
-		    (mach:get-unix-error-msg utime)))
-	    (T (setq old-run-utime utime)
-	       (setq old-run-stime stime))))
-    (multiple-value-bind (gr ps fc ac ic wc zf ra in ot pf)
-			 (mach:vm_statistics *task-self*)
-      (declare (ignore ps fc ac ic wc zf ra in ot))
-      (gr-error 'mach:vm_statistics gr)
-      (setq old-page-faults pf))
-    (setq old-real-time (get-internal-real-time))
-    (setq old-bytes-consed (get-bytes-consed))
-    (multiple-value-prog1
-	;; Execute the form and return its values.
-	(funcall fun)
-      (multiple-value-bind (err? utime stime)
-			   (mach:unix-getrusage mach:rusage_self)
-	(cond ((null err?)
-	       (error "Unix system call getrusage failed: ~A."
-		      (mach:get-unix-error-msg utime)))
-	      (T (setq new-run-utime (- utime run-utime-overhead))
-		 (setq new-run-stime (- stime run-stime-overhead)))))
-      (multiple-value-bind (gr ps fc ac ic wc zf ra in ot pf)
-			   (mach:vm_statistics *task-self*)
-	(declare (ignore ps fc ac ic wc zf ra in ot))
-	(gr-error 'mach:vm_statistics gr)
-	(setq new-page-faults (- pf page-faults-overhead)))
-      (setq new-real-time (- (get-internal-real-time) real-time-overhead))
-      (setq new-bytes-consed (- (get-bytes-consed) cons-overhead))
-      (format *trace-output*
-	      "~&Evaluation took:~%  ~
-	      ~S second~:P of real time~%  ~
-	      ~S second~:P of user run time~%  ~
-	      ~S second~:P of system run time~%  ~
-	      ~S page fault~:P and~%  ~
-	      ~S bytes consed.~%"
-	      (max (/ (- new-real-time old-real-time)
-		      (float internal-time-units-per-second))
-		   0.0)
-	      (max (/ (- new-run-utime old-run-utime) 1000000.0) 0.0)
-	      (max (/ (- new-run-stime old-run-stime) 1000000.0) 0.0)
-	      (max (- new-page-faults old-page-faults) 0)
-	      (max (- new-bytes-consed old-bytes-consed) 0)))))
diff --git a/code/tty-inspect.lisp b/code/tty-inspect.lisp
deleted file mode 100644
index e3c3e4acfa18a7fd858e713b209f9f602a5572cd..0000000000000000000000000000000000000000
--- a/code/tty-inspect.lisp
+++ /dev/null
@@ -1,217 +0,0 @@
-;;; -*- Log: code.log; Package: inspect -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; Tty interface for INSPECT.
-;;;
-;;; Written by Blaine Burks
-
-;;;
-(in-package "INSPECT")
-
-;;; The Tty inspector views LISP objects as being composed of parts.  A list,
-;;; for example, would be divided into it's members, and a structure into its
-;;; slots.  These parts are stored in a list.  The first two elements of this
-;;; list are for bookkeeping.  The first element is a preamble string that will
-;;; be displayed before the object.  The second element is a boolean value that
-;;; indicates whether a label will be printed in front of a value, or just the
-;;; value.  Symbols and structures need to display both a slot name and a
-;;; value, while lists, vectors, and atoms need only display a value.  If the
-;;; second member of a parts list is t, then the third and successive members
-;;; must be an association list of slot names and values.  When the second slot
-;;; is nil, the third and successive slots must be the parts of an object.
-;;;
-
-;;; *tty-object-stack* is an assoc list of objects to their parts.  
-;;;
-(defvar *tty-object-stack* ())
-
-(proclaim '(inline numbered-parts-p))
-(defun numbered-parts-p (parts)
-  (second parts))
-
-(defconstant parts-offset 2)
-
-(defun nth-parts (parts n)
-  (if (numbered-parts-p parts)
-      (cdr (nth (+ n parts-offset) parts))
-      (nth (+ n parts-offset) parts)))
-
-(defun tty-inspect (object)
-  (unwind-protect
-      (input-loop object (describe-parts object) *standard-output*)
-    (setf *tty-object-stack* nil)))
-
-;;; When %illegal-object% occurs in a parts list, it indicates that that slot
-;;; is unbound.
-(defvar %illegal-object% (cons nil nil))
-
-(defun input-loop (object parts s)
-  (tty-display-object parts s)
-  (loop
-    (format s "~&> ")
-    (let ((command (read))
-	  ;; Use 2 less than length because first 2 elements are bookkeeping.
-	  (parts-len-2 (- (length parts) 2)))
-      (typecase command
-	(integer
-	 (cond ((< -1 command parts-len-2)
-		(cond ((eq (nth-parts parts command) %illegal-object%)
-		       (format s "~%That slot is unbound.~%"))
-		      (t
-		       (push (cons object parts) *tty-object-stack*)
-		       (setf object (nth-parts parts command))
-		       (setf parts (describe-parts object))
-		       (tty-display-object parts s))))
-	       (t
-		(if (= parts-len-2 0)
-		    (format s "~%This object contains nothing to inspect.~%~%")
-		    (format s "~%Enter a VALID number (~:[0-~D~;0~]).~%~%"
-			    (= parts-len-2 1) (1- parts-len-2))))))
-	(symbol
-	 (case (find-symbol (symbol-name command) (find-package "KEYWORD"))
-	   ((:q :e)
-	    (return object))
-	   (:u
-	    (cond (*tty-object-stack*
-		   (setf object (caar *tty-object-stack*))
-		   (setf parts (cdar *tty-object-stack*))
-		   (pop *tty-object-stack*)
-		   (tty-display-object parts s))
-		  (t (format s "~%Bottom of Stack.~%"))))
-	   (:r
-	    (setf parts (describe-parts object))
-	    (tty-display-object parts s))
-	   (:d
-	    (tty-display-object parts s))
-	   ((:h :? :help)
-	    (show-help s))
-	   (t
-	    (do-tty-inspect-eval command s))))
-	(t
-	 (do-tty-inspect-eval command s))))))
-
-(defun do-tty-inspect-eval (command stream)
-  (let ((result-list (restart-case (multiple-value-list (eval command))
-		       (nil () :report "Return to the TTY-INSPECTOR"
-			  (format stream "~%Returning to INPSECTOR.~%")
-			  (return-from do-tty-inspect-eval nil)))))
-    (setf /// // // / / result-list)
-    (setf +++ ++ ++ + + - - command)
-    (setf *** ** ** * * (car /))
-    (format stream "~&~{~S~%~}" /)))
-
-(defun show-help (s)
-  (terpri)
-  (write-line "TTY-Inspector Help:" s)
-  (write-line "  R           -  recompute current object." s)
-  (write-line "  D           -  redisplay current object." s)
-  (write-line "  U           -  Move upward through the object stack." s)
-  (write-line "  Q, E        -  Quit TTY-INSPECTOR." s)
-  (write-line "  ?, H, Help  -  Show this help." s))
-
-(defun tty-display-object (parts stream)
-  (format stream "~%~a" (car parts))
-  (let ((numbered-parts-p (numbered-parts-p parts))
-	(parts (cddr parts)))
-    (do ((part parts (cdr part))
-	 (i 0 (1+ i)))
-	((endp part) nil)
-      (if numbered-parts-p
-	  (format stream "~d. ~a: ~a~%" i (caar part)
-		  (if (eq (cdar part) %illegal-object%)
-		      "Unbound"
-		      (cdar part)))
-	  (format stream "~d. ~a~%" i (car part))))))
-
-
-
-;;;; DESCRIBE-PARTS
-
-(defun describe-parts (object)
-  (typecase object
-    (symbol (describe-symbol-parts object))
-    (structure (describe-structure-parts object))
-    (function (describe-function-parts object))
-    (vector (describe-vector-parts object))
-    (array (describe-array-parts object))
-    (cons (describe-cons-parts object))
-    (t (describe-atomic-parts object))))
-
-(defun describe-symbol-parts (object)
-  (list (format nil "~s is a symbol.~%" object) t
-	(cons "Value" (if (boundp object)
-			  (symbol-value object)
-			  %illegal-object%))
-	(cons "Function" (if (fboundp object)
-			     (symbol-function object)
-			     %illegal-object%))
-	(cons "Plist" (symbol-plist object))
-	(cons "Package" (symbol-package object))))
-
-(defun describe-structure-parts (object)
-  (let ((dd-slots
-	 (c::dd-slots
-	  (ext:info type defined-structure-info
-		    (system:%primitive header-ref object
-				       system:%g-vector-structure-name-slot))))
-	(parts-list ()))
-    (push (format nil "~s is a structure.~%" object) parts-list)
-    (push t parts-list)
-    (dolist (dd-slot dd-slots (nreverse parts-list))
-      (push (cons (c::dsd-%name dd-slot)
-		  (system:%primitive header-ref object (c::dsd-index dd-slot)))
-	    parts-list))))
-
-(defun describe-function-parts (object)
-  (let ((object (if (= (system:%primitive get-vector-subtype object)
-		       system:%function-closure-subtype)
-		    (system:%primitive header-ref object
-				       system:%function-name-slot)
-		    object)))
-    (list (format nil "Function ~s.~%Argument List: ~a." object
-		  (system:%primitive header-ref object
-				     lisp::%function-entry-arglist-slot)
-		  #|###
-		  (system:%primitive header-ref object
-				     lisp::%function-defined-from-slot)
-		  ~%Defined from: ~a
-		  |#
-		  )
-	  t)))
-
-(defun describe-vector-parts (object)
-  (list* (format nil "Object is a ~:[~;displaced ~]vector of length ~d.~%"
-		 (lisp::%displacedp object) (length object))
-	 nil
-	 (coerce object 'list)))
-
-(defun describe-cons-parts (object)
-  (list* (format nil "Object is a LIST of length ~d.~%" (length object))
-	 nil
-	 object))
-
-(defun describe-array-parts (object)
-  (let* ((length (min (array-total-size object) inspect-length))
-	 (reference-array (make-array length :displaced-to object))
-	 (dimensions (array-dimensions object))
-	 (parts ()))
-    (push (format nil "Object is ~:[a displaced~;an~] array of ~a.~%~
-                       Its dimensions are ~s.~%"
-		  (array-element-type object) (lisp::%displacedp object)
-		  dimensions)
-	  parts)
-    (push t parts)
-    (dotimes (i length (nreverse parts))
-      (push (cons (format nil "~a " (index-string i (reverse dimensions)))
-		  (aref reference-array i))
-	    parts))))
-
-(defun describe-atomic-parts (object)
-  (list (format nil "Object is an atom.~%") nil object))
-
diff --git a/code/wire.lisp b/code/wire.lisp
deleted file mode 100644
index 46bf5792a4cdd9ae2d91745cb45f94ab0b8b05f6..0000000000000000000000000000000000000000
--- a/code/wire.lisp
+++ /dev/null
@@ -1,622 +0,0 @@
-;;; -*- Log: code.log; Package: wire -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; This file contains an interface to internet domain sockets.
-;;;
-;;; Written by William Lott.
-;;;
-
-(in-package "WIRE")
-
-(export '(remote-object-p remote-object-local-p remote-object-eq
-	  remote-object-value make-remote-object forget-remote-translation
-	  make-wire wire-p wire-fd wire-listen wire-get-byte wire-get-number
-	  wire-get-string wire-get-object wire-force-output wire-output-byte
-	  wire-output-number wire-output-string wire-output-object
-	  wire-output-funcall wire-error wire-eof wire-io-error
-	  *current-wire*))
-
-
-(eval-when (compile load eval) ;For macros in remote.lisp.
-
-(defconstant buffer-size 2048)
-
-(defconstant initial-cache-size 16)
-
-(defconstant funcall0-op 0)
-(defconstant funcall1-op 1)
-(defconstant funcall2-op 2)
-(defconstant funcall3-op 3)
-(defconstant funcall4-op 4)
-(defconstant funcall5-op 5)
-(defconstant funcall-op 6)
-(defconstant number-op 7)
-(defconstant string-op 8)
-(defconstant symbol-op 9)
-(defconstant save-op 10)
-(defconstant lookup-op 11)
-(defconstant remote-op 12)
-(defconstant cons-op 13)
-
-) ;eval-when
-
-
-(defvar *current-wire* nil
-  "The wire the form we are currently evaluating came across.")
-
-(defvar *this-host* nil
-  "Unique identifier for this host.")
-(defvar *this-pid* nil
-  "Unique identifier for this process.")
-
-(defvar *object-to-id* (make-hash-table :test 'eq)
-  "Hash table mapping local objects to the corresponding remote id.")
-(defvar *id-to-object* (make-hash-table :test 'eql)
-  "Hash table mapping remote id's to the curresponding local object.")
-(defvar *next-id* 0
-  "Next available id for remote objects.")
-
-
-(defstruct (wire
-            (:constructor make-wire (fd))
-            (:print-function
-             (lambda (wire stream depth)
-               (declare (ignore depth))
-               (format stream
-                       "#<wire fd=~a>"
-		       (wire-fd wire)))))
-  fd
-
-  (ibuf (make-string buffer-size))
-  (ibuf-offset 0)
-  (ibuf-end 0)
-  (object-cache (make-array initial-cache-size))
-
-  (obuf (make-string buffer-size))
-  (obuf-end 0)
-  (cache-index 0)
-  (object-hash (make-hash-table :test 'eq)))
-
-(defstruct (remote-object
-	    (:constructor %make-remote-object (host pid id))
-	    (:print-function
-	     (lambda (obj stream depth)
-	       (declare (ignore depth))
-	       (format stream "#<Remote Object: [~x:~a] ~s>"
-		       (remote-object-host obj)
-		       (remote-object-pid obj)
-		       (remote-object-id obj)))))
-  host
-  pid
-  id)
-
-(define-condition wire-error (error)
-  (wire)
-  (:report (lambda (condition stream)
-	     (format stream "There is a problem with ~A."
-		     (wire-error-wire condition)))))
-
-(define-condition wire-eof (wire-error)
-  ()
-  (:report (lambda (condition stream)
-	     (format stream "Recieved EOF on ~A."
-		     (wire-eof-wire condition)))))
-
-(define-condition wire-io-error (wire-error)
-  ((when "using")
-   (msg "Failed."))
-  (:report (lambda (condition stream)
-	     (format stream "Error ~A ~A: ~A."
-		     (wire-io-error-when condition)
-		     (wire-io-error-wire condition)
-		     (wire-io-error-msg condition)))))
-
-
-;;; Remote Object Randomness
-
-;;; REMOTE-OBJECT-LOCAL-P -- public
-;;;
-;;;   First, make sure the *this-host* and *this-pid* are set. Then test to
-;;; see if the remote object's host and pid fields are *this-host* and
-;;; *this-pid*
-
-(defun remote-object-local-p (remote)
-  "Returns T iff the given remote object is defined locally."
-  (declare (type remote-object remote))
-  (unless *this-host*
-    (setf *this-host* (mach:unix-gethostid))
-    (setf *this-pid* (mach:unix-getpid)))
-  (and (eql (remote-object-host remote) *this-host*)
-       (eql (remote-object-pid remote) *this-pid*)))
-
-;;; REMOTE-OBJECT-EQ -- public
-;;;
-;;;   Remote objects are considered EQ if they refer to the same object, ie
-;;; Their host, pid, and id fields are the same (eql, cause they are all
-;;; numbers).
-
-(defun remote-object-eq (remote1 remote2)
-  "Returns T iff the two objects refer to the same (eq) object in the same
-  process."
-  (declare (type remote-object remote1 remote2))
-  (and (eql (remote-object-host remote1)
-	    (remote-object-host remote2))
-       (eql (remote-object-pid remote1)
-	    (remote-object-pid remote2))
-       (eql (remote-object-id remote1)
-	    (remote-object-id remote2))))
-
-;;; REMOTE-OBJECT-VALUE --- public
-;;;
-;;;   First assure that the remote object is defined locally. If so, look up
-;;; the id in *id-to-objects*. 
-;;; table. This will only happen if FORGET-REMOTE-TRANSLATION has been called
-;;; on the local object.
-
-(defun remote-object-value (remote)
-  "Return the associated value for the given remote object. It is an error if
-  the remote object was not created in this process or if
-  FORGET-REMOTE-TRANSLATION has been called on this remote object."
-  (declare (type remote-object remote))
-  (unless (remote-object-local-p remote)
-    (error "~S is defined is a different process." remote))
-  (multiple-value-bind
-      (value found)
-      (gethash (remote-object-id remote)
-	       *id-to-object*)
-    (unless found
-      (cerror
-       "Use the value of NIL"
-       "No value for ~S -- FORGET-REMOTE-TRANSLATION was called to early."
-       remote))
-    value))
-
-;;; MAKE-REMOTE-OBJECT --- public
-;;;
-;;;   Convert the given local object to a remote object. If the local object is
-;;; alread entered in the *object-to-id* hash table, just use the old id.
-;;; Otherwise, grab the next id and put add both mappings to the two hash
-;;; tables.
-
-(defun make-remote-object (local)
-  "Convert the given local object to a remote object."
-  (unless *this-host*
-    (setf *this-host* (mach:unix-gethostid))
-    (setf *this-pid* (mach:unix-getpid)))
-  (let ((id (gethash local *object-to-id*)))
-    (unless id
-      (setf id *next-id*)
-      (setf (gethash local *object-to-id*) id)
-      (setf (gethash id *id-to-object*) local)
-      (incf *next-id*))
-    (%make-remote-object *this-host* *this-pid* id)))
-
-;;; FORGET-REMOTE-TRANSLATION -- public
-;;;
-;;;   Remove any translation information about the given object. If there is
-;;; currenlt no translation for the object, don't bother doing anything.
-;;; Otherwise remove it from the *object-to-id* hashtable, and remove the id
-;;; from the *id-to-object* hashtable.
-
-(defun forget-remote-translation (local)
-  "Forget the translation from the given local to the corresponding remote
-object. Passing that remote object to remote-object-value will new return NIL."
-  (let ((id (gethash local *object-to-id*)))
-    (when id
-      (remhash local *object-to-id*)
-      (remhash id *id-to-object*)))
-  (values))
-
-
-;;; Wire input routeins.
-
-;;; WIRE-LISTEN -- public
-;;;
-;;;   If nothing is in the current input buffer, select on the file descriptor.
-
-(defun wire-listen (wire)
-  "Return T iff anything is in the input buffer or available on the socket."
-  (or (< (wire-ibuf-offset wire)
-	 (wire-ibuf-end wire))
-      (multiple-value-bind
-	  (number error)
-	  (mach:unix-select (1+ (wire-fd wire))
-			    (ash 1 (wire-fd wire))
-			    0
-			    0
-			    0)
-	(unless number
-	  (error 'wire-io-error
-		 :wire wire
-		 :when "listening to"
-		 :msg (mach:get-unix-error-msg error)))
-	(not (zerop number)))))
-
-
-;;; FILL-INPUT-BUFFER -- Internal
-;;;
-;;;   Fill the input buffer from the socket. If we get an error reading, signal
-;;; a wire-io-error. If we get an EOF, signal a wire-eof error. If we get any
-;;; data, set the ibuf-end index.
-
-(defun fill-input-buffer (wire)
-  "Read data off the socket, filling the input buffer. The buffer is cleared
-first. If fill-input-buffer returns, it is guarenteed that there will be at
-least one byte in the input buffer. If EOF was reached, as wire-eof error
-is signaled."
-  (setf (wire-ibuf-offset wire) 0
-	(wire-ibuf-end wire) 0)
-  (let ((fd (wire-fd wire))
-	(ibuf (wire-ibuf wire)))
-    (unless ibuf
-      (error 'wire-eof :wire wire))
-
-    (multiple-value-bind (bytes error)
-			 (mach:unix-read fd ibuf buffer-size)
-      (cond ((null bytes)
-	     (error 'wire-io-error
-		    :wire wire
-		    :when "reading"
-		    :msg (mach:get-unix-error-msg error)))
-	    ((zerop bytes)
-	     (setf (wire-ibuf wire) nil)
-	     (error 'wire-eof :wire wire))
-	    (t
-	     (setf (wire-ibuf-end wire) bytes)))))
-  (values))
-
-;;; WIRE-GET-BYTE -- public
-;;;
-;;;   Check to see if there is anything in the input buffer. If not, use
-;;; FILL-INPUT-BUFFER to get something. Return the next byte, adjusting
-;;; the input offset index.
-
-(defun wire-get-byte (wire)
-  "Return the next byte from the wire."
-  (when (<= (wire-ibuf-end wire)
-	    (wire-ibuf-offset wire))
-    (fill-input-buffer wire))
-  (prog1
-      (char-int (schar (wire-ibuf wire)
-		       (wire-ibuf-offset wire)))
-    (incf (wire-ibuf-offset wire))))
-
-;;; WIRE-GET-NUMBER -- public
-;;;
-;;;   Just read four bytes and pack them together with normal math ops.
-
-(defun wire-get-number (wire &optional (signed t))
-  "Read a number off the wire. Numbers are 4 bytes in network order.
-The optional argument controls weather or not the number should be considered
-signed (defaults to T)."
-  (let* ((b1 (wire-get-byte wire))
-	 (b2 (wire-get-byte wire))
-	 (b3 (wire-get-byte wire))
-	 (b4 (wire-get-byte wire))
-	 (unsigned
-	  (+ b4 (* 256 (+ b3 (* 256 (+ b2 (* 256 b1))))))))
-    (if (and signed (> b1 127))
-	(- #x100000000 unsigned)
-	unsigned)))
-
-;;; WIRE-GET-STRING -- public
-;;;
-;;;   Use WIRE-GET-NUMBER to read the length, then keep pulling stuff out of
-;;; the input buffer and re-filling it with FILL-INPUT-BUFFER until we've read
-;;; the entire string.
-
-(defun wire-get-string (wire)
-  "Reads a string from the wire. The first four bytes spec the size."
-  (let* ((length (wire-get-number wire))
-	 (result (make-string length))
-	 (offset 0)
-	 (ibuf (wire-ibuf wire)))
-    (declare (simple-string result ibuf)
-	     (integer length offset))
-    (loop
-      (let ((avail (- (wire-ibuf-end wire)
-		      (wire-ibuf-offset wire))))
-	(declare (integer avail))
-	(cond ((<= length avail)
-	       (replace result
-			ibuf
-			:start1 offset
-			:start2 (wire-ibuf-offset wire))
-	       (incf (wire-ibuf-offset wire) length)
-	       (return nil))
-	      ((zerop avail)
-	       (fill-input-buffer wire))
-	      (t
-	       (replace result
-			ibuf
-			:start1 offset
-			:start2 (wire-ibuf-offset wire)
-			:end2 (wire-ibuf-end wire))
-	       (incf offset avail)
-	       (decf length avail)
-	       (incf (wire-ibuf-offset wire) avail)))))
-    result))
-    
-;;; WIRE-GET-OBJECT -- public
-;;;
-;;;   First, read a byte to determine the type of the object to read. Then,
-;;; depending on the type, call WIRE-GET-NUMBER, WIRE-GET-STRING, or whatever
-;;; to read the necessary data. Note, funcall objects are funcalled.
-
-(defun wire-get-object (wire)
-  "Reads the next object from the wire and returns it."
-  (let ((identifier (wire-get-byte wire))
-	(*current-wire* wire))
-    (declare (fixnum identifier))
-    (cond ((eql identifier lookup-op)
-	   (let ((index (wire-get-number wire))
-		 (cache (wire-object-cache wire)))
-	     (declare (integer index))
-	     (declare (simple-vector cache))
-	     (when (< index (length cache))
-	       (svref cache index))))
-	  ((eql identifier number-op)
-	   (wire-get-number wire))
-	  ((eql identifier string-op)
-	   (wire-get-string wire))
-	  ((eql identifier symbol-op)
-	   (let* ((symbol-name (wire-get-string wire))
-		  (package-name (wire-get-string wire))
-		  (package (find-package package-name)))
-	     (unless package
-	       (error "Attempt to read symbol, ~A, of wire into non-existent ~
-		       package, ~A."
-		      symbol-name package-name))
-	     (intern symbol-name package)))
-	  ((eql identifier cons-op)
-	   (cons (wire-get-object wire)
-		 (wire-get-object wire)))
-	  ((eql identifier remote-op)
-	   (let ((host (wire-get-number wire nil))
-		 (pid (wire-get-number wire))
-		 (id (wire-get-number wire)))
-	     (%make-remote-object host pid id)))
-	  ((eql identifier save-op)
-	   (let ((index (wire-get-number wire))
-		 (cache (wire-object-cache wire)))
-	     (declare (integer index))
-	     (declare (simple-vector cache))
-	     (when (>= index (length cache))
-	       (do ((newsize (* (length cache) 2)
-			     (* newsize 2)))
-		   ((< index newsize)
-		    (let ((newcache (make-array newsize)))
-		      (declare (simple-vector newcache))
-		      (replace newcache cache)
-		      (setf cache newcache)
-		      (setf (wire-object-cache wire) cache)))))
-	     (setf (svref cache index)
-		   (wire-get-object wire))))
-	  ((eql identifier funcall0-op)
-	   (funcall (wire-get-object wire)))
-	  ((eql identifier funcall1-op)
-	   (funcall (wire-get-object wire)
-		    (wire-get-object wire)))
-	  ((eql identifier funcall2-op)
-	   (funcall (wire-get-object wire)
-		    (wire-get-object wire)
-		    (wire-get-object wire)))
-	  ((eql identifier funcall3-op)
-	   (funcall (wire-get-object wire)
-		    (wire-get-object wire)
-		    (wire-get-object wire)
-		    (wire-get-object wire)))
-	  ((eql identifier funcall4-op)
-	   (funcall (wire-get-object wire)
-		    (wire-get-object wire)
-		    (wire-get-object wire)
-		    (wire-get-object wire)
-		    (wire-get-object wire)))
-	  ((eql identifier funcall5-op)
-	   (funcall (wire-get-object wire)
-		    (wire-get-object wire)
-		    (wire-get-object wire)
-		    (wire-get-object wire)
-		    (wire-get-object wire)
-		    (wire-get-object wire)))
-	  ((eql identifier funcall-op)
-	   (let ((arg-count (wire-get-byte wire))
-		 (function (wire-get-object wire))
-		 (args '())
-		 (last-cons nil)
-		 (this-cons nil))
-	     (loop
-	       (when (zerop arg-count)
-		 (return nil))
-	       (setf this-cons (cons (wire-get-object wire)
-				     nil))
-	       (if (null last-cons)
-		 (setf args this-cons)
-		 (setf (cdr last-cons) this-cons))
-	       (setf last-cons this-cons)
-	       (decf arg-count))
-	     (apply function args))))))
-
-
-;;; Wire output routines.
-
-;;; WRITE-STUFF -- internal
-;;;
-;;;   Slightly better interface to mach:unix-write. Choaks on errors.
-
-(defmacro write-stuff (fd string-form &optional end)
-  (let ((string (gensym))
-	(length (gensym))
-	(result (gensym))
-	(error (gensym)))
-    `(let* ((,string ,string-form)
-	    ,@(unless end
-		`((,length (length ,string)))))
-       (multiple-value-bind
-	   (,result ,error)
-	   (mach:unix-write ,fd ,string 0 ,(or end length))
-	 (cond ((null ,result)
-		(error 'wire-io-error
-		       :wire wire
-		       :when "writing"
-		       :msg (mach:get-unix-error-msg ,error)))
-	       ((eql ,result ,(or end length))
-		)
-	       (t
-		(error 'wire-io-error
-		       :wire wire
-		       :when "writing"
-		       :msg "Not everything wrote.")))))))
-
-;;; WIRE-FORCE-OUTPUT -- internal
-;;;
-;;;   Output any stuff remaining in the output buffer.
-
-(defun wire-force-output (wire)
-  "Send any info still in the output buffer down the wire and clear it. Nothing
-harmfull will happen if called when the output buffer is empty."
-  (unless (zerop (wire-obuf-end wire))
-    (write-stuff (wire-fd wire)
-		 (wire-obuf wire)
-		 (wire-obuf-end wire))
-    (setf (wire-obuf-end wire) 0))
-  (values))
-
-;;; WIRE-OUTPUT-BYTE -- public
-;;;
-;;;   Stick the byte in the output buffer. If there is no space, flush the
-;;; buffer using WIRE-FORCE-OUTPUT.
-
-(defun wire-output-byte (wire byte)
-  "Output the given (8-bit) byte on the wire."
-  (declare (integer byte))
-  (let ((fill-pointer (wire-obuf-end wire))
-	(obuf (wire-obuf wire)))
-    (when (>= fill-pointer (length obuf))
-      (wire-force-output wire)
-      (setf fill-pointer 0))
-    (setf (schar obuf fill-pointer)
-	  (int-char byte))
-    (setf (wire-obuf-end wire) (1+ fill-pointer)))
-  (values))
-
-;;; WIRE-OUTPUT-NUMBER -- public
-;;;
-;;;   Output the number. Note, we don't care if the number is signed or not,
-;;; because we just crank out the low 32 bits.
-
-(defun wire-output-number (wire number)
-  "Output the given (32-bit) number on the wire."
-  (declare (integer number))
-  (wire-output-byte wire (+ 0 (ldb (byte 8 24) number)))
-  (wire-output-byte wire (ldb (byte 8 16) number))
-  (wire-output-byte wire (ldb (byte 8 8) number))
-  (wire-output-byte wire (ldb (byte 8 0) number))
-  (values))
-
-;;; WIRE-OUTPUT-STRING -- public
-;;;
-;;;   Output the string. Strings are represented by the length as a number,
-;;; followed by the bytes of the string.
-
-(defun wire-output-string (wire string)
-  "Output the given string. First output the length using WIRE-OUTPUT-NUMBER,
-then output the bytes."
-  (declare (simple-string string))
-  (let ((length (length string)))
-    (declare (integer length))
-    (wire-output-number wire length)
-    (let* ((obuf (wire-obuf wire))
-	   (obuf-end (wire-obuf-end wire))
-	   (available (- (length obuf)
-			 obuf-end)))
-      (declare (simple-string obuf)
-	       (integer available))
-      (cond ((>= available length)
-	     (replace obuf string
-		      :start1 obuf-end)
-	     (incf (wire-obuf-end wire) length))
-	    ((> length (length obuf))
-	     (wire-force-output wire)
-	     (write-stuff (wire-fd wire)
-			  string))
-	    (t
-	     (wire-force-output wire)
-	     (replace obuf string)
-	     (setf (wire-obuf-end wire) length)))))
-  (values))
-
-;;; WIRE-OUTPUT-OBJECT -- public
-;;;
-;;;   Output the given object. If the optional argument is non-nil, cache
-;;; the object to enhance the performance of sending it multiple times.
-;;; Caching defaults to yes for symbols, and nil for everything else.
-
-(defun wire-output-object (wire object &optional (cache-it (symbolp object)))
-  "Output the given object on the given wire. If cache-it is T, enter this
-object in the cache for future reference."
-  (let ((cache-index (gethash object
-			      (wire-object-hash wire))))
-    (cond
-     (cache-index
-      (wire-output-byte wire lookup-op)
-      (wire-output-number wire cache-index))
-     (t
-      (when cache-it
-	(wire-output-byte wire save-op)
-	(let ((index (wire-cache-index wire)))
-	  (wire-output-number wire index)
-	  (setf (gethash object (wire-object-hash wire))
-		index)
-	  (setf (wire-cache-index wire) (1+ index))))
-      (typecase object
-	(integer
-	 (wire-output-byte wire number-op)
-	 (wire-output-number wire object))
-	(simple-string
-	 (wire-output-byte wire string-op)
-	 (wire-output-string wire object))
-	(symbol
-	 (wire-output-byte wire symbol-op)
-	 (wire-output-string wire (symbol-name object))
-	 (wire-output-string wire (package-name (symbol-package object))))
-	(cons
-	 (wire-output-byte wire cons-op)
-	 (wire-output-object wire (car object))
-	 (wire-output-object wire (cdr object)))
-	(remote-object
-	 (wire-output-byte wire remote-op)
-	 (wire-output-number wire (remote-object-host object))
-	 (wire-output-number wire (remote-object-pid object))
-	 (wire-output-number wire (remote-object-id object)))
-	(t
-	 (error "Error: Cannot output objects of type ~s across a wire."
-		(type-of object)))))))
-  (values))
-
-;;; WIRE-OUTPUT-FUNCALL -- public
-;;;
-;;;   Send the funcall down the wire. Arguments are evaluated locally in the
-;;; lexical environment of the WIRE-OUTPUT-FUNCALL.
-
-(defmacro wire-output-funcall (wire-form function &rest args)
-  "Send the function and args down the wire as a funcall."
-  (let ((num-args (length args))
-	(wire (gensym)))
-    `(let ((,wire ,wire-form))
-       ,@(if (> num-args 5)
-	    `((wire-output-byte ,wire funcall-op)
-	      (wire-output-byte ,wire ,num-args))
-	    `((wire-output-byte ,wire ,(+ funcall0-op num-args))))
-       (wire-output-object ,wire ,function)
-       ,@(mapcar #'(lambda (arg)
-		     `(wire-output-object ,wire ,arg))
-		 args)
-       (values))))
-
diff --git a/compiler/aliencomp.lisp b/compiler/aliencomp.lisp
deleted file mode 100644
index c059d0b614f8db08f4a528639b7218291125f1a9..0000000000000000000000000000000000000000
--- a/compiler/aliencomp.lisp
+++ /dev/null
@@ -1,830 +0,0 @@
-;;; -*- Log: C.Log; Package: C -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; Spice Lisp is currently incomplete and under active development.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    This file contains transforms and other stuff used to compile Alien
-;;; definitions.  There are two main parts: A fairly general numeric
-;;; constant-folding facility, and the transforms that implement the
-;;; the Alien primitives.
-;;;
-;;;
-(in-package 'c)
-
-(in-package 'lisp)
-(import '(
-	  ct-a-val-sap ct-a-val-type ct-a-val-offset ct-a-val-size
-	  ct-a-val-p ct-a-val make-ct-a-val ct-a-val-alien
-	  check<= check= %alien-indirect %aligned-sap
-	  naturalize-integer deport-integer naturalize-boolean deport-boolean
-	  sap-ref-8 sap-ref-16 sap-ref-32
-	  signed-sap-ref-8 signed-sap-ref-16 signed-sap-ref-32
-	  %set-alien-access
-	  
-	  *alien-eval-when* make-alien alien-type alien-size alien-address
-	  copy-alien dispose-alien defalien alien-value
-	  alien-bind defoperator alien-index alien-indirect
-	  bits bytes words long-words port perq-string
-	  boolean defenumeration enumeration
-	  system-area-pointer pointer alien alien-access
-	  alien-assign alien-sap define-alien-stack
-	  with-stack-alien null-terminated-string c-procedure
-	  record-size
-	  )
-	(find-package "C"))
-
-(in-package 'c)
-
-
-;;;; Pre-pass:
-;;;
-;;;    We do a pre-pass over Alien expressions at source-transformation time.
-;;; This pass does compile-time Alien type checking, and also composes the
-;;; Alien operators, producing separate expressions that compute the address,
-;;; type and total offset and size of the expression.
-
- 
-;;; Analyze-Alien-Expression  --  Internal
-;;;
-;;;    This function grovels an alien expression and return a bunch of values
-;;; that tell how to evaluate the thing.  Result-Type is the alien-type that
-;;; the expression must evaluate to.  The values returned are:
-;;;  0] A list of let*-bindings that need to be made.
-;;;  1] Some stuff that should be evaluated within the bindings.  This
-;;;      stuff is error-checks and stuff like that.  This is in reverse
-;;;      order.
-;;;  2] A ct-a-val structure describing the size, sap and offset.
-;;;
-;;; If the expression is not of the correct type or is somehow malformed, then
-;;; we call Compiler-Error, which aborts out.  If the expression cannot be
-;;; shown to be of the correct type then a runtime check is generated.  When
-;;; Result-Type is Nil we don't pay any attention to the type.
-;;;
-(defun analyze-alien-expression (result-type exp)
-  (if (atom exp)
-      (if (and (symbolp exp)
-	       (or (ct-a-val-p (cdr (assoc exp *venv*)))
-		   (info variable alien-value exp)))
-	  (grovel-alien-var result-type exp)
-	  (grovel-random-alien result-type exp))
-      (let* ((fun (car exp))
-	     (info (info function alien-operator fun)))
-	(cond
-	 ((eq fun 'alien-value)
-	  (grovel-alien-var result-type (cadr exp)))
-	 ((eq fun 'alien-index)
-	  (when result-type
-	    (compiler-error "Alien-Index used where a type is required:~% ~S"
-			    exp))
-	  (grovel-alien-index exp))
-	 ((eq fun 'alien-indirect)
-	  (when result-type
-	    (compiler-error "Alien-Indirect used where a type is required:~% ~S"
-			    exp))
-	  (grovel-alien-indirect exp))
-	 (info
-	  (grovel-alien-operator result-type exp info))
-	 (t
-	  (grovel-random-alien result-type exp))))))
-
-
-;;; Ignore-Unreferenced-Vars  --  Internal
-;;;
-;;;    Return an Ignorable declaration for all of the vars in the let-binding
-;;; list Binds.
-;;;
-(defun ignore-unreferenced-vars (binds)
-  (declare (list binds))
-  `(declare (ignorable ,@(mapcar #'car binds))))
-
-
-;;; Grovel-Alien-Index  --  Internal
-;;;
-;;;    Analyze a call to Alien-Index, a la Analyze-Alien-Expression.  We
-;;; throw a call to Check-Alien-Bounds into the Stuff to do the bounds
-;;; checking.
-;;;
-(defun grovel-alien-index (exp)
-  (unless (= (length exp) 4)
-    (compiler-error "Wrong number of arguments to Alien-Index:~% ~S" exp))
-  
-  (multiple-value-bind (binds stuff res)
-		       (analyze-alien-expression nil (second exp))
-    (let* ((offset (ct-a-val-offset res))
-	   (noffset `(+ ,offset ,(third exp)))
-	   (size (ct-a-val-size res))
-	   (nsize (fourth exp)))
-      (values
-       binds
-       `((check<= (+ ,noffset ,nsize) (+ ,offset ,size))
-	 ,@stuff)
-       (make-ct-a-val
-	:sap (ct-a-val-sap res)
-	:offset noffset
-	:size nsize)))))
-
-
-;;; Grovel-Alien-Indirect  --  Internal
-;;;
-;;;    Handle an Alien-Indirect.  We transform to a %Alien-Indirect that looks
-;;; at the offset and size.  If the offset is long-word aligned and the size is
-;;; 32, then we transform to a SAP-System-Ref, otherwise we give up and allow
-;;; the error check to be done at run-time.
-;;;
-(defun grovel-alien-indirect (exp)
-  (unless (= (length exp) 3)
-    (compiler-error "Wrong number of arguments to Alien-Indirect:~% ~S" exp))
-
-  (multiple-value-bind (binds stuff res)
-		       (analyze-alien-expression nil (second exp))
-    (values
-     binds
-     stuff
-     (make-ct-a-val
-      :sap `(%alien-indirect ,(ct-a-val-size res)
-			     ,(ct-a-val-sap res)
-			     ,(ct-a-val-offset res)
-			     ',exp)
-      :offset 0
-      :size (third exp)))))
-
-(defknown %alien-indirect (index t index t) t (flushable))
-
-(deftransform %alien-indirect ((size sap offset exp))
-  (unless (>= (find-alignment offset) 5)
-    (give-up "Offset may not be long-word aligned:~% ~S"
-	     (continuation-value exp)))
-
-  (unless (and (constant-continuation-p size)
-	       (eql (continuation-value size) 32))
-    (give-up "Size may not be 32:~% ~S" (continuation-value exp)))
-
-  '(%primitive sap-system-ref sap (ash offset -4)))
-
-
-;;; Grovel-Alien-Var  --  Internal
-;;;
-;;;    Look the var up in *venv*, and then check if it is a global
-;;; alien-variable.  If it ain't there or is the the wrong type then flame out.
-;;;
-(defun grovel-alien-var (type var)
-  (let* ((local-def (cdr (assoc var *venv*)))
-	 (res (cond ((ct-a-val-p local-def) local-def)
-		    ((or (not local-def)
-			 (and (global-var-p local-def)
-			      (eq (global-var-kind local-def) :special)))
-		     (info variable alien-value var))
-		    (t
-		     (compiler-error "Not an Alien variable: ~S." var)))))
-    (unless res
-      (compiler-error "Undefined Alien variable: ~S" var))
-    (when (and type (not (equal (ct-a-val-type res) type)))
-      (compiler-error "Alien type of ~S is ~S, not ~S."
-		      var (ct-a-val-type res) type))
-
-    (values () () res)))
-
-
-;;; Grovel-Alien-Operator  --  Internal
-;;;
-;;;    Handle a call to an alien operator.  Analyze each Alien valued argument,
-;;; throwing the result on *aenv* during the processing of the body.  We always
-;;; bind lisp arguments, letting the optimizer do any cleverness.  All we do to
-;;; the body is strip off any stuff if there is a progn, and then call
-;;; Analyze-Alien-Expression on the body with Nil as the result-type.
-;;;
-(defun grovel-alien-operator (type exp info)
-  (unless (or (not type)
-	      (equal (lisp::alien-info-result-type info) type))
-    (compiler-error "Does not result in a ~S alien value:~% ~S" type exp))
-  
-  (unless (= (lisp::alien-info-num-args info) (length (cdr exp)))
-    (compiler-error "Alien operator not called with ~D args:~% ~S"
-		    (lisp::alien-info-num-args info) exp))
-  
-  (do* ((args (cdr exp) (cdr args))
-	(dums ())
-	(*venv* *venv*)
-	(num 0 (1+ num))
-	(types (lisp::alien-info-arg-types info))
-	(atype (cdr (assoc num types)) (cdr (assoc num types)))
-	(stuff ())
-	(binds ()))
-       ((null args)
-	(let ((body (apply (lisp::alien-info-function info)
-			   (nreverse dums))))
-	  (when (and (consp body)
-		     (eq (car body) 'progn))
-	    (push (butlast body) stuff)
-	    (setq body (car (last body))))
-	  (multiple-value-bind (b s r)
-			       (analyze-alien-expression nil body)
-	    (when r
-	      (setq r (make-ct-a-val
-		       :type (lisp::alien-info-result-type info)
-		       :sap (ct-a-val-sap r)
-		       :offset (ct-a-val-offset r)
-		       :size (ct-a-val-size r))))
-	    (values
-	     (nconc b binds)
-	     (nconc s stuff)
-	     r))))
-    (declare (list dums))
-    (cond (atype
-	   (multiple-value-bind (b s val)
-				(analyze-alien-expression atype (car args))
-	     (setq binds (nconc binds b)  stuff (nconc stuff s))
-	     (unless val (return nil))
-	     (let ((var (gensym)))
-	       (push (cons var val) *venv*)
-	       (push var dums))))
-	  (t
-	   (let ((var (gensym)))
-	     (push var dums)
-	     (setq binds (nconc binds `((,var ,(car args))))))))))
-
-
-;;; Grovel-Random-Alien  --  Internal
-;;;
-;;;    Flame out if the form is some random atom, otherwise bind a var
-;;; to Check-Alien-Type of it, and return forms to access the fields
-;;; of the Alien-Value.
-;;;
-(defun grovel-random-alien (type exp)
-  (when (and (atom exp) (not (symbolp exp)))
-    (compiler-error "~S is a bad thing to be an Alien-Value." exp))
-  (cond ((and (symbolp exp) (info variable alien-value exp))
-	 (values () () (info variable alien-value exp)))
-	(t
-	 (when (policy nil (> speed brevity))
-	   (compiler-note "Not a known Alien expression:~% ~S." exp))
-
-	 (let ((var (gensym))
-	       (sap (gensym))
-	       (size (gensym))
-	       (offset (gensym)))
-	   (values
-	    `((,sap (lisp::alien-value-sap ,var))
-	      (,offset (lisp::alien-value-offset ,var))
-	      (,size (lisp::alien-value-size ,var))
-	      (,var ,(if type
-			 `(lisp::check-alien-type ,exp ',type)
-			 exp)))
-	    ()
-	    (make-ct-a-val
-	     :type type
-	     :sap sap
-	     :offset offset
-	     :size size
-	     :alien var))))))
-
-
-;;;; Miscellaneous internal frobs:
-
-(defknown sap+ (t t) t (movable flushable))
-(deftransform sap+ ((sap offset))
-  (unless (and (constant-continuation-p offset)
-	       (eql (continuation-value offset) 0))
-    (give-up))
-  'sap)
-
-(defknown sap-int (t) unsigned-byte (movable flushable))
-(defknown int-sap (unsigned-byte) t (movable flushable))
-
-(defknown %aligned-sap (t t t) t (movable flushable))
-(deftransform %aligned-sap ((sap offset form))
-  (unless (> (find-alignment offset) 3)
-    (give-up))
-  '(sap+ sap offset))
-
-(defknown (check<= check=) (index index) void (movable))
-
-;;; Compile-Time-Check  --  Internal
-;;;
-;;;    If the operands are constant, then test them using OP.  If it succeeds,
-;;; transform to NIL, otherwise warn and give-up.
-;;;
-(defun compile-time-check (x y op)
-  (unless (and (constant-continuation-p x)
-	       (constant-continuation-p y))
-    (give-up))
-  (let ((x (continuation-value x))
-	(y (continuation-value y)))
-    (unless (funcall (symbol-function op) x y)
-      (compiler-warning "~S not ~S to ~S at compile time." x op y)
-      (give-up)))
-  'nil)
-
-(deftransform check<= ((x y)) (compile-time-check x y '<=))
-(deftransform check= ((x y)) (compile-time-check x y '=))
-
-(defknown record-size (symbol) index (movable foldable flushable))
-
-(defknown sap-ref-8 (t index) (unsigned-byte 8) (flushable))
-(defknown sap-ref-16 (t index) (unsigned-byte 16) (flushable))
-(defknown sap-ref-32 (t index) (unsigned-byte 32) (flushable))
-(defknown (setf sap-ref-8) (t index (unsigned-byte 8)) (unsigned-byte 8) ())
-(defknown (setf sap-ref-16) (t index (unsigned-byte 16)) (unsigned-byte 16) ())
-(defknown (setf sap-ref-32) (t index (unsigned-byte 32)) (unsigned-byte 32) ())
-
-
-;;;; Alien variable special forms:
-
-;;; Alien-Bind IR1 convert  --  Internal
-;;;
-(def-ir1-translator alien-bind ((binds &body body &whole source) start cont)
-  (let ((*venv* *venv*))
-    (collect ((lets nil nconc)
-	      (stuff nil nconc))
-      (dolist (bind binds)
-	(unless (<= 2 (length bind) 4)
-	  (compiler-error "Malformed Alien-Bind specifier:~% ~S" bind))
-	(let ((var (first bind))
-	      (val (second bind))
-	      (typ (third bind))
-	      (aligned (fourth bind)))
-
-	  (multiple-value-bind (l s res)
-			       (analyze-alien-expression typ val)
-	    (unless (ct-a-val-type res)
-	      (compiler-error "Must specify type, since it is not apparent ~
-	                       from the value:~% ~S" bind))
-	    (lets l)
-	    (stuff s)
-	    (let* ((offset (ct-a-val-offset res))
-		   (sap (ct-a-val-sap  res))
-		   (size (ct-a-val-size res))
-		   (n-size (gensym))
-		   (n-sap (gensym))
-		   (n-offset (gensym)))
-	      (lets `((,n-sap ,(if aligned
-				   `(%aligned-sap ,sap ,offset ',source)
-				   sap))
-		      (,n-size ,size)
-		      (,n-offset ,(if aligned 0 offset))))
-
-	      (push (cons var
-			  (make-ct-a-val :type (ct-a-val-type res)
-					 :offset (if aligned 0 n-offset)
-					 :size n-size
-					 :sap n-sap
-					 :alien (ct-a-val-alien res)))
-		    *venv*)))))
-
-    (ir1-convert start cont
-		 `(let* ,(reverse (lets))
-		    ,(ignore-unreferenced-vars (lets))
-		    ,@(nreverse (stuff))
-		    ,@body)))))
-
-
-;;; With-Stack-Alien-Transform  --  Internal
-;;;
-;;;
-(def-ir1-translator with-stack-alien (((var stack) &body forms) start cont)
-  (let ((info (info alien-stack info stack)))
-    (unless info
-      (compiler-error "~S is not the name of a declared alien stack." stack))
-
-    (let* ((n-current (lisp::stack-info-current info))
-	   (n-sap (gensym))
-	   (n-alien (gensym))
-	   (*venv* (acons var
-			  (make-ct-a-val :type (lisp::stack-info-type info)
-					 :size (lisp::stack-info-size info)
-					 :sap n-sap
-					 :offset 0
-					 :alien n-alien)
-			  *venv*)))
-      (ir1-convert start cont
-		   `(let* ((,n-alien (or (car ,n-current)
-					 (,(lisp::stack-info-grow info))))
-			   (,n-sap (lisp::alien-value-sap ,n-alien))
-			   (,n-current (cdr ,n-current)))
-		      ,@forms)))))
-
-
-;;;; Transforms for basic Alien accessors.
-;;;
-;;;    Open-coding these guys is probably worthwhile, since they are used
-;;; for real things.
-
-;;; Alien-Address source transform  --  Internal
-;;;
-;;;    Divide out the out the offset, producing a ratio if the alien
-;;; isn't byte aligned.
-;;;
-(def-source-transform alien-address (alien)
-  (multiple-value-bind (binds stuff res)
-		       (analyze-alien-expression nil alien)
-    `(let* ,(reverse binds)
-       ,(ignore-unreferenced-vars binds)
-       ,@(nreverse stuff)
-       (+ (sap-int ,(ct-a-val-sap res)) (/ ,(ct-a-val-offset res) 16)))))
-
-
-;;; Alien-SAP soruce transform  --  Internal
-;;;
-;;;
-(def-source-transform alien-address (alien &whole source)
-  (multiple-value-bind (binds stuff res)
-		       (analyze-alien-expression nil alien)
-    `(let* ,(reverse binds)
-       ,(ignore-unreferenced-vars binds)
-       ,@(nreverse stuff)
-       (%aligned-sap ,(ct-a-val-sap res) ,(ct-a-val-offset res)
-		     ',source))))
-
-
-;;; Alien=>Lisp transform is defined in proclaim.lisp, since it is referenced
-;;; by top-level code in cold load.
-;;;
-(dolist (x '(alien-index alien-indirect))
-  (setf (info function source-transform x) #'alien=>lisp-transform))
-
-
-;;; Alien-Value IR1 convert  --  Internal
-;;;
-;;;    Although all we do is call Alien=>Lisp-Transform, this must be a special
-;;; form, since the transformation must be done even when functions wouldn't be
-;;; transformed.
-;;;
-(def-ir1-translator alien-value ((x &whole form) start cont)
-  x ; Ignore
-  (ir1-convert start cont (alien=>lisp-transform form)))
-
-
-;;;; Alien-Access:
-
-;;; Alien-Access source transform  --  Internal
-;;;
-;;;    We analyze the alien expression, converting to a call to %Alien-Access
-;;; with the alien parts as separate arguments.
-;;;
-(def-source-transform alien-access (alien &optional lisp-type &whole form)
-  (multiple-value-bind (binds stuff res)
-		       (analyze-alien-expression nil alien)
-    `(let* ,(reverse binds)
-       ,(ignore-unreferenced-vars binds)
-       ,@(nreverse stuff)
-       (%alien-access ,(ct-a-val-sap res) ,(ct-a-val-offset res)
-		      ,(ct-a-val-size res) ',(ct-a-val-type res)
-		      ,lisp-type ',form))))
-
-(defknown %alien-access (t unsigned-byte unsigned-byte t t t) t
-  (movable flushable))
-
-;;; %Alien-Access transform  --  Internal
-;;;
-;;;    If we can figure out the alien and lisp types at compile time, then
-;;; expand into the appropriate access form.
-;;;
-(deftransform %alien-access ((sap offset size type lisp-type form))
-  (unless (constant-continuation-p lisp-type)
-    (give-up "Lisp-Type not constant, so cannot open-code."))
-
-  (let ((type (continuation-value type))
-	(lisp-type (continuation-value lisp-type))
-	(form (continuation-value form)))
-    (unless type
-      (give-up "Alien type unknown, so cannot open-code."))
-  
-    (let ((access (lisp::get-alien-access-method type lisp-type)))
-      (funcall access 'sap 'offset 'size type :read nil form))))
-
-
-;;; %Set-Alien-Access source transform  --  Internal
-;;;
-;;;    Like the source transform for Alien-Access, only different.
-;;;
-(def-source-transform %set-alien-access (alien lisp-type
-					  &optional (new-value nil nv-p)
-					  &whole form)
-  (multiple-value-bind (binds stuff res)
-		       (analyze-alien-expression nil alien)
-    `(let* ,(reverse binds)
-       ,(ignore-unreferenced-vars binds)
-       ,@(nreverse stuff)
-       (%%set-alien-access ,(ct-a-val-sap res) ,(ct-a-val-offset res)
-			   ,(ct-a-val-size res) ',(ct-a-val-type res)
-			   ,(if nv-p lisp-type nil)
-			   ,(if nv-p new-value lisp-type)
-			   ',form))))
-
-(defknown %%set-alien-access (t unsigned-byte unsigned-byte t t t t) t)
-
-;;; %%Set-Alien-Access transform  --  Internal
-;;;
-;;;    Like %Alien-Access transform.  The alien-access experts don't return the
-;;; right value, cause it's a pain in the ass.  Since this is a Setf method, we
-;;; gotta return the right value.
-;;;
-(deftransform %%set-alien-access ((sap offset size type lisp-type new-value
-				       form))
-  (unless (constant-continuation-p lisp-type)
-    (give-up "Lisp-Type not constant, so cannot open-code."))
-
-  (let ((type (continuation-value type))
-	(lisp-type (continuation-value lisp-type))
-	(form (continuation-value form)))
-    (unless type
-      (give-up "Alien type unknown, so cannot open-code."))
-  
-    (let ((access (lisp::get-alien-access-method type lisp-type)))
-      `(progn
-	 ,(funcall access 'sap 'offset 'size type :write 'new-value
-		   form)
-	 new-value))))
-
-
-;;;; Alignment determination:
-
-;;; Integer-Alignment  --  Internal
-;;;
-;;;    Returns the largest power of two which evenly divides its argument.
-;;; If N is not an integer 0 is returned. 
-;;;
-(defun integer-alignment (n)
-  (if (integerp n)
-      (if (zerop n)
-	  most-positive-fixnum
-	  (do ((i 0 (1+ i))
-	       (n (abs n) (ash n -1)))
-	      ((not (zerop (logand n 1))) i)))
-      0))
-
-
-;;; Find-Alignment  --  Internal
-;;;
-;;;    This function is used to find out if offsets are some multiple of a
-;;; power of two.  The largest exponent of two which evenly the value of Cont
-;;; is returned.  0 is returned if we can't figure out anything, or the result
-;;; isn't an integer.  If the value is known to be 0, then we return
-;;; most-positive-fixnum.
-;;;
-(defun find-alignment (cont)
-  (declare (type continuation cont))
-  (let ((use (continuation-use cont)))
-    (cond ((and (combination-p use)
-		(= (length (combination-args use)) 2))
-	   (let* ((name (continuation-function-name (combination-fun use)))
-		  (args (combination-args use))
-		  (x (first args))
-		  (y (second args)))
-	     (case name
-	       ((+ -)
-		(min (find-alignment x) (find-alignment y)))
-	       (*
-		(let ((itype (specifier-type 'integer)))
-		  (if (and (csubtypep (continuation-type x) itype)
-			   (csubtypep (continuation-type y) itype))
-		      (+ (find-alignment x) (find-alignment y))
-		      0)))
-	       (ash
-		(if (constant-continuation-p y)
-		    (let ((val (continuation-value y)))
-		      (if (integerp val)
-			  (+ (find-alignment x) val)
-			  0))
-		    0))
-	       (t
-		0))))
-	  ((constant-continuation-p cont)
-	   (integer-alignment (continuation-value cont)))
-	  (t
-	   0))))
-
-;;; Find-Bit-Offset  --  Internal
-;;;
-;;;    Returns the value of (rem Exp From) if this can be determined at
-;;; compile-time, or Nil otherwise.  From must be a power of two.
-;;;
-(defun find-bit-offset (exp &optional (from 16))
-  (declare (type continuation exp) (type unsigned-byte from))
-  (let ((use (continuation-use exp)))
-    (cond ((constant-continuation-p exp)
-	   (rem (continuation-value exp) from))
-	  ((>= (find-alignment exp) (1- (integer-length from)))
-	   0)
-	  ((and (combination-p use)
-		(= (length (combination-args use)) 2))
-	   (let* ((name (continuation-function-name (combination-fun use)))
-		  (args (combination-args use))
-		  (x (find-bit-offset (first args) from))
-		  (y (find-bit-offset (second args) from)))
-	     (when (and x y)
-	       (case name
-		 (+ (rem (+ x y) from))
-		 (t nil)))))
-	  (t
-	   nil))))
-
-
-;;;; Reading and writing integers.
-;;;
-;;;    This code is used by many of the Alien-Access experts, since many
-;;; operations reduce to reading and writing integers.
-
-;;; Sign-Extend  --  Internal
-;;;
-;;;    Wrap code around Form to sign-extend a Size-bit integer if Signed,
-;;; otherwise just return arg.
-;;;
-(defun sign-extend (form size &optional (signed t))
-  (if signed
-      `(let ((res ,form))
-	 (declare (fixnum res))
-	 (if (zerop (logand res ,(ash 1 (1- size))))
-	     res
-	     (logior res ,(ash -1 size))))
-      form))
-
-
-(defknown naturalize-integer (t t unsigned-byte unsigned-byte t) integer
-  (flushable))
-
-;;; Naturalize-Integer Transform  --  Internal
-;;;
-;;;    Compile a call to Naturalize-Integer in some tense fashion.
-;;; The number may be signed or unsigned.  The integer may be any size and
-;;; alignment, as long as it fits within a word, otherwise it must be
-;;; exactly 16 or 32 bits and be word-aligned.  The size must be a
-;;; compile-time constant and is assumed to have been checked for
-;;; correctness.
-;;;
-;;; ### Note that the alignment check will fail if the SAP isn't 32 bit
-;;; aligned.  Now that we don't generally squeeze offsets into the sap, this is
-;;; probably usually true.  Eventually, we should guarantee that the SAP is
-;;; 32 bit aligned.
-;;; 
-(deftransform naturalize-integer ((signed sap offset size form))
-  (unless (constant-continuation-p size)
-    (give-up "Size not constant, so cannot open-code integer access:~%~S"
-	     (continuation-value form)))
-  
-  (let ((align (find-alignment offset))
-	(size (continuation-value size))
-	(signed (continuation-value signed)))
-    (cond
-     ((or (and (> size 15) (< align 4))
-	  (and (> size 16) (< align 5)))
-      (give-up "Could not show ~D bit access to be word-aligned:~%~S"
-	       size (continuation-value form)))
-     ((= size 32)
-      (if signed
-	  '(%primitive signed-32bit-system-ref sap (ash offset -4))
-	  '(%primitive unsigned-32bit-system-ref sap (ash offset -4))))
-     ((= size 16)
-      (if signed
-	  '(%primitive signed-16bit-system-ref sap (ash offset -4))
-	  '(%primitive 16bit-system-ref sap (ash offset -4))))
-     ((> size 15)
-      (compiler-warning "Access of ~D bit bytes is not supported:~%~S"
-			size (continuation-value form))
-      (give-up))
-     ((and (> align 2) (= size 8))
-      (sign-extend '(%primitive 8bit-system-ref sap (ash offset -3))
-		   8 signed))
-     (t
-      (let ((bits (find-bit-offset offset)))
-	(unless bits
-	  (give-up "Can't determine offset within word, so cannot ~
-	  open-code:~%~S"
-		   (continuation-value form)))
-	
-	(if (>= (+ bits size) 16)
-	    (let* ((hi-bits (- 16 bits))
-		   (lo-bits (- size hi-bits)))
-	      ;;
-	      ;; If the integer spans a 16bit boundry, then the high bits in
-	      ;; the integer are the low bits in the first word, and the low
-	      ;; bits in the integer are the high bits in the next word.
-	      (sign-extend
-	       `(let ((offset (ash offset -4)))
-		  (logior (ash (ldb (byte ,hi-bits 0)
-				    (sap-ref-16 sap offset))
-			       ,lo-bits)
-			  (ash (sap-ref-16 sap (1+ offset))
-			       ,(- (- 16 lo-bits)))))
-	       size signed))
-	    (sign-extend `(ldb (byte ,size ,bits)
-			       (sap-ref-16 sap (ash offset -4)))
-			 size signed)))))))
-
-
-
-(defknown deport-integer (t t unsigned-byte unsigned-byte integer t) void
-  ())
-
-;;; Deport-Integer transform  --  Internal
-;;;
-;;;    Similar to Naturalize-Integer transform.
-;;;
-(deftransform deport-integer ((signed sap offset size value form))
-  (unless (constant-continuation-p size)
-    (give-up "Size not constant, so cannot open-code integer access:~%~S"
-	     (continuation-value form)))
-
-  (let ((align (find-alignment offset))
-	(size (continuation-value size)))
-    (cond
-     ((or (and (> size 15) (< align 4))
-	  (and (> size 16) (< align 5)))
-      (give-up "Could not show ~D bit access to be word-aligned:~%~S"
-	       size (continuation-value form)))
-     ((= size 32)
-      '(%primitive signed-32bit-system-set sap (ash offset -4) value))
-     ((= size 16)
-      '(%primitive 16bit-system-set sap (ash offset -4) value))
-     ((> size 15)
-      (compiler-warning "Access of ~D bit bytes is not supported:~%~S"
-			size (continuation-value form))
-      (give-up))
-     ((and (> align 2) (= size 8))
-      '(%primitive 8bit-system-set sap (ash offset -3) value))
-     (t
-      (let ((bits (find-bit-offset offset)))
-	(unless bits
-	  (give-up "Can't determine offset within word, so cannot ~
-	            open-code:~%~S"
-		   (continuation-value form)))
-	
-	(if (>= (+ bits size) 16)
-	    (let* ((hi-bits (- 16 bits))
-		   (lo-bits (- size hi-bits)))
-	      ;;
-	      ;; If the integer spans a 16bit boundry, then the high bits in
-	      ;; the integer are the low bits in the first word, and the low
-	      ;; bits in the integer are the high bits in the next word.
-	      `(let ((offset (ash offset -4)))
-		 (%primitive 16bit-system-set sap offset
-			     (dpb (ash value ,(- lo-bits))
-				  (byte ,hi-bits 0)
-				  (sap-ref-16 sap offset)))
-		 (%primitive 16bit-system-set sap (1+ offset)
-			     (dpb value
-				  (byte ,lo-bits ,(- 16 lo-bits))
-				  (sap-ref-16 (1+ offset))))))
-	    `(let ((offset (ash offset -4)))
-	       (setf (sap-ref-16 sap offset)
-		     (dpb value
-			  (byte ,size ,bits)
-			  (sap-ref-16 sap offset))))))))))
-
-
-;;;; Boolean stuff:
-
-(defknown naturalize-boolean (t index index t) boolean (flushable))
-(defknown deport-boolean (t index index t t) void ())
-
-;;; Naturalize and Deport Boolean transforms  --  Internal
-;;; 
-;;;     If the bit falls at a known position within a byte, then we can
-;;; test and set it using a single logical operation instead of extracting the
-;;; whole field.  If the value occupies a full byte/short/word, then then we
-;;; just do the access, rather than messing around with masks.
-;;;
-;;; When setting, we must always set the entire field, so we can only be clever
-;;; when the field is a single bit.
-;;;
-(deftransform naturalize-boolean ((sap offset size form))
-  (unless (constant-continuation-p size)
-    (give-up "Size not constant, so cannot open-code integer access:~% ~S"
-	     (continuation-value form)))
-
-  (let ((off (find-bit-offset offset 8))
-	(size (continuation-value size)))
-    (unless off
-      (give-up "Can't determine offset within word, so cannot open-code:~% ~S"
-	       (continuation-value form)))
-    (if (and (>= (find-alignment offset) 3)
-	     (member size '(8 16 32)))
-	`(not (zerop (naturalize-integer nil sap offset ,size
-					 ',(continuation-value form))))
-	`(not (zerop (logand (sap-ref-8 sap (ash (+ offset ,(1- size)) -3))
-			     ,(ash 1 (- 7 off))))))))
-;;;
-(deftransform deport-boolean ((sap offset size value form))
-  (unless (constant-continuation-p size)
-    (give-up "Size not constant, so cannot open-code integer access:~% ~S"
-	     (continuation-value form)))
-
-  (let ((off (find-bit-offset offset 8))
-	(size (continuation-value size)))
-    (unless off
-      (give-up "Can't determine offset within word, so cannot open-code:~% ~S"
-	       (continuation-value form)))
-    (if (= size 1)
-	`(let ((offset (ash offset -3)))
-	   (setf (sap-ref-8 sap offset)
-		 (let ((old (sap-ref-8 sap offset)))
-		   (if value
-		       (logior old ,(ash 1 (- 7 off)))
-		       (logand old ,(lognot (ash 1 (- 7 off))))))))
-	`(deport-integer nil sap offset ,size (if value 1 0)
-			 ',(continuation-value form)))))
diff --git a/compiler/bit-util.lisp b/compiler/bit-util.lisp
deleted file mode 100644
index 6aec56fd3d9f92e5fb85dce40532ab787aa8b686..0000000000000000000000000000000000000000
--- a/compiler/bit-util.lisp
+++ /dev/null
@@ -1,50 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    Bit-vector hacking utilities, potentially implementation-dependent for
-;;; speed.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-;;; Clear-Bit-Vector  --  Interface
-;;;
-;;;    Clear a bit-vector to zeros.
-;;;
-(defun clear-bit-vector (vec)
-  (declare (type simple-bit-vector vec))
-  (bit-xor vec vec t))
-
-
-;;; Set-Bit-Vector  --  Interface
-;;;
-;;;    Fill a bit vector with ones.
-;;;
-(defun set-bit-vector (vec)
-  (declare (type simple-bit-vector vec))
-  (bit-orc2 vec vec t))
-
-
-;;; Bit-Vector-Replace  --  Interface
-;;;
-;;;    Replace the bits in To with the bits in From.
-;;;
-(defun bit-vector-replace (to from)
-  (declare (type simple-bit-vector to from))
-  (bit-ior from from to))
-
-
-;;; Bit-Vector-Copy  --  Interface
-;;;
-;;;    Copy a bit-vector.
-;;;
-(defun bit-vector-copy (vec)
-  (declare (type simple-bit-vector vec))
-  (bit-ior vec vec))
diff --git a/compiler/checkgen.lisp b/compiler/checkgen.lisp
deleted file mode 100644
index f2acd1088652d7567d84cc04ad5c1c5893d4cd2a..0000000000000000000000000000000000000000
--- a/compiler/checkgen.lisp
+++ /dev/null
@@ -1,374 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    This file implements type check generation.  This is a phase that runs
-;;; at the very end of IR1.  If a type check is too complex for the back end to
-;;; directly emit in-line, then we transform the check into an explicit
-;;; conditional using TYPEP.
-;;; 
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-
-;;;; Cost estimation:
-
-
-;;; Function-Cost  --  Internal
-;;;
-;;;    Return some sort of guess about the cost of a call to a function.  If
-;;; the function has some templates, we return the cost of the cheapest one,
-;;; otherwise we return the cost of CALL-NAMED.  Calling this with functions
-;;; that have transforms can result in relatively meaningless results
-;;; (exaggerated costs.)
-;;;
-;;; We randomly special-case NULL, since it does have a source tranform and is
-;;; interesting to us.
-;;;
-(defun function-cost (name)
-  (declare (symbol name))
-  (let ((info (info function info name))
-	(call-cost (template-cost (template-or-lose 'call-named))))
-    (if info
-	(let ((templates (function-info-templates info)))
-	  (if templates
-	      (template-cost (first templates))
-	      (case name
-		(null (template-cost (template-or-lose 'if-eq)))
-		(t call-cost))))
-	call-cost)))
-
-  
-;;; Type-Test-Cost  --  Internal
-;;;
-;;;    Return some sort of guess for the cost of doing a test against TYPE.
-;;; The result need not be precise as long as it isn't way out in space.  The
-;;; units are based on the costs specified for various templates in the VM
-;;; definition.
-;;;
-(defun type-test-cost (type)
-  (declare (type ctype type))
-  (or (let ((check (type-check-template type)))
-	(if check
-	    (template-cost check)
-	    (let ((found (cdr (assoc type *type-predicates* :test #'type=))))
-	      (if found
-		  (function-cost found)
-		  nil))))
-      (typecase type
-	(union-type
-	 (collect ((res 0 +)) 
-	   (dolist (mem (union-type-types type))
-	     (res (type-test-cost mem)))
-	   (res)))
-	(member-type
-	 (* (length (member-type-members type))
-	    (function-cost 'eq)))
-	(numeric-type
-	 (* (if (numeric-type-complexp type) 2 1)
-	    (function-cost
-	     (if (csubtypep type (specifier-type 'fixnum)) 'fixnump 'numberp))
-	    (+ 1
-	       (if (numeric-type-low type) 1 0)
-	       (if (numeric-type-high type) 1 0))))
-	(t
-	 (function-cost 'typep)))))
-
-
-;;;; Checking strategy determination:
-
-
-;;; MAYBE-NEGATE-CHECK  --  Internal
-;;;
-;;;    Cont is a continuation we are doing a type check on and Types is a list
-;;; of types that we are checking its values against.  If we have proven
-;;; that Cont generates a fixed number of values, then for each value, we check
-;;; whether it is cheaper to then difference between the the proven type and
-;;; the corresponding type in Types.  If so, we opt for a :HAIRY check with
-;;; that test negated.  Otherwise, we try to do a simple test, and if that is
-;;; impossible, we do a hairy test with non-negated types.
-;;;
-(defun maybe-negate-check (cont types)
-  (declare (type continuation cont) (list types))
-  (multiple-value-bind (ptypes count)
-		       (values-types (continuation-proven-type cont))
-    (if (eq count :unknown)
-	(if (every #'type-check-template types)
-	    (values :simple types)
-	    (values :hairy (mapcar #'(lambda (x) (list nil x x)) types)))
-	(let ((res (mapcar #'(lambda (p c)
-			       (let ((diff (type-difference p c)))
-				 (if (and diff
-					  (< (type-test-cost diff)
-					     (type-test-cost c)))
-				     (list t diff c)
-				     (list nil c c))))
-			   ptypes types)))
-	  (if (and (not (find-if #'first res))
-		   (every #'type-check-template types))
-	      (values :simple types)
-	      (values :hairy res))))))
-	    
-
-;;; CONTINUATION-CHECK-TYPES  --  Interface
-;;;
-;;; Determines whether Cont's assertion is:
-;;;  -- Checkable by the back end (:SIMPLE), or
-;;;  -- Not checkable by the back end, but checkable via an explicit test in
-;;;     type check conversion (:HAIRY), or
-;;;  -- not reasonably checkable at all (:TOO-HAIRY).
-;;;
-;;; A type is checkable if it either represents a fixed number of values (as
-;;; determined by VALUES-TYPES), or it is the assertion for an MV-Bind.  A type
-;;; is simply checkable if all the type assertions have a TYPE-CHECK-TEMPLATE.
-;;; In this :SIMPLE case, the second value is a list of the type restrictions
-;;; specified for the leading positional values.
-;;;
-;;; In the :HAIRY case, the second value is a list of triples of the form:
-;;;    (Not-P Type Original-Type)
-;;;
-;;; If true, the Not-P flag indicates a test that the corresponding value is
-;;; *not* of the specified Type.  Original-Type is the type asserted on this
-;;; value in the continuation, for use in error messages.  When Not-P is true,
-;;; this will be different from Type.
-;;;
-;;; This allows us to take what has been proven about Cont's type into
-;;; consideration.  If it is cheaper to test for the difference between the
-;;; derived type and the asserted type, then we check for the negation of this
-;;; type instead.
-;;;
-(defun continuation-check-types (cont)
-  (declare (type continuation cont))
-  (let ((type (continuation-asserted-type cont))
-	(dest (continuation-dest cont)))
-    (assert (not (eq type *wild-type*)))
-    (multiple-value-bind (types count)
-			 (values-types type)
-      (cond ((not (eq count :unknown))
-	     (maybe-negate-check cont types))
-	    ((and (mv-combination-p dest)
-		  (eq (basic-combination-kind dest) :local))
-	     (assert (values-type-p type))
-	     (maybe-negate-check cont (args-type-optional type)))
-	    (t
-	     (values :too-hairy nil))))))
-
-
-;;; Probable-Type-Check-P  --  Internal
-;;;
-;;;    Return true if Cont is a continuation whose type the back end is likely
-;;; to want to check.  Since we don't know what template the back end is going
-;;; to choose to implement the continuation's DEST, we use a heuristic.  We
-;;; always return T unless:
-;;;  -- Nobody uses the value, or
-;;;  -- Speed or space is more important that safety, or
-;;;  -- the continuation is an argument to an unknown function, or
-;;;  -- the continuation is an argument to a known function that has no
-;;;     IR2-Convert method or :fast-safe templates that are compatible with the
-;;;     call's type.
-;;;
-;;; We must only return nil when it is *certain* that a check will not be done,
-;;; since if we pass up this chance to do the check, it will be too late.  The
-;;; penalty for being too conservative is duplicated type checks.
-;;;
-;;; We always return true if there is a compile-time type error on the
-;;; continuation, so that this error will be signalled at runtime as well.
-;;;
-(defun probable-type-check-p (cont)
-  (declare (type continuation cont))
-  (let ((dest (continuation-dest cont)))
-    (cond ((eq (continuation-type-check cont) :error))
-	  ((or (not dest)
-	       (policy dest (or (> speed safety) (> space safety))))
-	   nil)
-	  ((basic-combination-p dest)
-	   (let ((kind (basic-combination-kind dest)))
-	     (cond ((eq cont (basic-combination-fun dest)) t)
-		   ((eq kind :local) t)
-		   ((eq kind :full) nil)
-		   ((function-info-ir2-convert kind) t)
-		   (t
-		    (dolist (template (function-info-templates kind) nil)
-		      (when (and (eq (template-policy template) :fast-safe)
-				 (valid-function-use dest
-						     (template-type template)))
-			(return t)))))))
-	  (t t))))
-
-
-;;; Make-Type-Check-Form  --  Internal
-;;;
-;;;    Return a form that we can convert to do a hairy type check of the
-;;; specified Types.  Types is a list of the format returned by
-;;; Continuation-Check-Types in the :HAIRY case.  In place of the actual
-;;; value(s) we are to check, we use 'Dummy.  This constant reference is later
-;;; replaced with the actual values continuation.
-;;;
-;;; Note that we don't attempt to check for required values being unsupplied.
-;;; Such checking is impossible to efficiently do at the source level because
-;;; our fixed-values conventions are optimized for the common MV-Bind case.
-;;;
-;;; We can always use Multiple-Value-Bind, since the macro is clever about
-;;; binding a single variable.
-;;;
-(defun make-type-check-form (types)
-  (collect ((temps))
-    (dotimes (i (length types))
-      (declare (ignore i))
-      (temps (gensym)))
-
-    `(multiple-value-bind ,(temps)
-			  'dummy
-       ,@(mapcar #'(lambda (temp type)
-		     (let* ((spec (type-specifier (second type)))
-			    (test (if (first type) `(not ,spec) spec)))
-		       `(unless (typep ,temp ',test)
-			  (%type-check-error
-			   ,temp
-			   ',(type-specifier (third type))))))
-		 (temps) types)
-       (values ,@(temps)))))
-  
-
-;;; Convert-Type-Check  --  Internal
-;;;
-;;;    Splice in explicit type check code immediately before the node that its
-;;; Cont's Dest.  This code receives the value(s) that were being passed to
-;;; Cont, checks the type(s) of the value(s), then passes them on to Cont.
-;;; We:
-;;;  -- Ensure that Cont starts a block, so that we can freely manipulate its
-;;;     uses.
-;;;  -- Make a new continuation and move Cont's uses to it.  Set type set
-;;;     Type-Check in Cont to :DELETED to indicate that the check has been
-;;;     done.
-;;;  -- Make the Dest node start its block so that we can splice in the type
-;;;     check code.
-;;;  -- Splice in a new block before the Dest block, giving it all the Dest's
-;;;     predecessors. 
-;;;  -- Convert the check form, using the new block start as Start and a dummy
-;;;     continuation as Cont.
-;;;  -- Set the new block's start and end cleanups to the *start* cleanup of
-;;;     Prev's block.  This overrides the incorrect default from
-;;;     With-IR1-Environment.
-;;;  -- Finish off the dummy continuation's block, and change the use to a use
-;;;     of Cont.  (we need to use the dummy continuation to get the control
-;;;     transfer right, since we want to go to Prev's block, not Cont's.)
-;;;     Link the new block to Prev's block.
-;;;  -- Substitute the new continuation for the dummy placeholder argument.
-;;;     Since no let conversion has been done yet, we can find the placeholder.
-;;;     The [mv-]combination node from the mv-bind in the check form will be
-;;;     the Use of the new check continuation.  We substitute for the first
-;;;     argument of this node.
-;;;  -- Invoke local call analysis to convert the call to a let.
-;;;
-(defun convert-type-check (cont types)
-  (declare (type continuation cont) (list types))
-  (with-ir1-environment (continuation-dest cont)
-    (ensure-block-start cont)    
-    (let* ((new-start (make-continuation))
-	   (dest (continuation-dest cont))
-	   (prev (node-prev dest)))
-      (continuation-starts-block new-start)
-      (substitute-continuation-uses new-start cont)
-      (setf (continuation-%type-check cont) :deleted)
-      
-      (when (continuation-use prev)
-	(node-ends-block (continuation-use prev)))
-      
-      (let* ((prev-block (continuation-block prev))
-	     (prev-cleanup (block-start-cleanup prev-block))
-	     (new-block (continuation-block new-start))
-	     (dummy (make-continuation)))
-	(dolist (block (block-pred prev-block))
-	  (change-block-successor block prev-block new-block))
-	(ir1-convert new-start dummy (make-type-check-form types))
-	(assert (eq (continuation-block dummy) new-block))
-
-	(setf (block-start-cleanup new-block) prev-cleanup)
-	(setf (block-end-cleanup new-block) prev-cleanup)
-
-	(let ((node (continuation-use dummy)))
-	  (setf (block-last new-block) node)
-	  (delete-continuation-use node)
-	  (add-continuation-use node cont))
-	(link-blocks new-block prev-block))
-      
-      (let* ((node (continuation-use cont))
-	     (args (basic-combination-args node))
-	     (victim (first args)))
-	(assert (and (= (length args) 1)
-		     (eq (constant-value
-			  (ref-leaf
-			   (continuation-use victim)))
-			 'dummy)))
-	(substitute-continuation new-start victim)))
-
-    (local-call-analyze *current-component*))
-  
-  (undefined-value))
-
-
-;;; Generate-Type-Checks  --  Interface
-;;;
-;;;    Loop over all blocks in Component that have TYPE-CHECK set, looking for
-;;; continuations with TYPE-CHECK T.  We do two mostly unrelated things: detect
-;;; compile-time type errors and determine if and how to do run-time type
-;;; checks.
-;;;
-;;;    If a continuation is too complex to be checked by the back end, or is
-;;; better checked with explicit code, then convert to an explicit test.
-;;; Assertions that can checked by the back end are passed through.  Assertions
-;;; that can't be tested are flamed about and marked as not needing to be
-;;; checked.
-;;;
-;;;    If we determine that a type check won't be done, then we set TYPE-CHECK
-;;; to :NO-CHECK.  In the non-hairy cases, this is just to prevent us from
-;;; wasting time coming to the same conclusion again on a later iteration.  In
-;;; the hairy case, we must indicate to LTN that it must choose a safe
-;;; implementation, since IR2 conversion will choke on the check.
-;;;
-(defun generate-type-checks (component)
-  (do-blocks (block component)
-    (when (block-type-check block)
-      (do-nodes (node cont block)
-	(when (eq (continuation-type-check cont) t)
-	  
-	  (let ((dtype (node-derived-type node))
-		(atype (continuation-asserted-type cont)))
-	    (unless (values-types-intersect dtype atype)
-	      (setf (continuation-%type-check cont) :error)
-	      (when (policy node (>= safety brevity))
-		(let ((*compiler-error-context* node))
-		  (compiler-warning "Result is a ~S, not a ~S."
-				    (type-specifier dtype)
-				    (type-specifier atype))))))
-	  
-	  (let ((check-p (probable-type-check-p cont)))
-	    (multiple-value-bind (check types)
-				 (continuation-check-types cont)
-	      (ecase check
-		(:simple
-		 (unless check-p
-		   (setf (continuation-%type-check cont) :no-check)))
-		(:hairy
-		 (if check-p
-		     (convert-type-check cont types)
-		     (setf (continuation-%type-check cont) :no-check)))
-		(:too-hairy
-		 (let* ((context (continuation-dest cont))
-			(*compiler-error-context* context))
-		   (when (policy context (>= safety brevity))
-		     (compiler-note
-		      "Type assertion too complex to check:~% ~S."
-		      (type-specifier (continuation-asserted-type cont)))))
-		 (setf (continuation-%type-check cont) :deleted)))))))
-
-      (setf (block-type-check block) nil)))
-
-  (undefined-value))
diff --git a/compiler/codegen.lisp b/compiler/codegen.lisp
deleted file mode 100644
index 1b1fd64bb61af1c211a69a81ccc7bf406b310dc6..0000000000000000000000000000000000000000
--- a/compiler/codegen.lisp
+++ /dev/null
@@ -1,50 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    The implementation-independent parts of the code generator.  We use
-;;; functions and information provided by the VM definition to convert IR2 into
-;;; assembly code.  After emitting code, we finish the assembly and then do the
-;;; post-assembly phase.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-;;;; Utilities used during code generation.
-
-;;; Current-Frame-Size  --  Interface
-;;;
-;;;    The size of the currently compiled component's stack frame in bytes.
-;;;
-(defun current-frame-size ()
-  (* 4 (finite-sb-current-size
-	(sc-sb (svref *sc-numbers* (sc-number-or-lose 'stack))))))
-
-
-;;; Generate-Code  --  Interface
-;;;
-(defun generate-code (component)
-  (do-ir2-blocks (block component)
-    (let ((1block (ir2-block-block block)))
-      (when (eq (block-info 1block) block)
-	(emit-label (block-label 1block))))
-
-    (do ((vop (ir2-block-start-vop block) (vop-next vop)))
-	((null vop))
-      (let ((gen (vop-info-generator-function (vop-info vop))))
-	(if gen 
-	    (funcall gen vop)
-	    (format t "Missing generator for ~S.~%"
-		    (template-name (vop-info vop)))))))
-
-  (finish-assembly))
-
-
-;;;; Post-assembly:
-;;;
diff --git a/compiler/constraint.lisp b/compiler/constraint.lisp
deleted file mode 100644
index 16b76358fad2804d217da8762f7f51afdfe6d60d..0000000000000000000000000000000000000000
--- a/compiler/constraint.lisp
+++ /dev/null
@@ -1,242 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    This file implements the constraint propagation phase of the compiler,
-;;; which uses global flow analysis to obtain dynamic type information.
-;;; 
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-(defstruct (constraint
-	    (:include sset-element)
-	    (:constructor make-constraint (number kind x y not-p)))
-  ;;
-  ;; The kind of constraint we have:
-  ;;     
-  ;; TYPEP
-  ;;     X is a LAMBDA-VAR and Y is a CTYPE.  The value of X is constrained to
-  ;;     be of type Y.
-  ;;
-  ;; >, <, =, EQL, EQ
-  ;;     X is a LAMBDA-VAR Y is a LAMBDA-VAR or a CONSTANT.  The relation is
-  ;;     asserted to hold.
-  ;;
-  (kind nil :type (member typep < > = eql eq))
-  ;;
-  ;; The operands to the relation.
-  (x nil :type lambda-var)
-  (y nil :type (or ctype lambda-var constant))
-  ;;
-  ;; If true, negates the sense of the constaint.  The relation is does *not*
-  ;; hold.
-  (not-p nil :type boolean))
-
-
-(defvar *constraint-number*)
-
-;;; FIND-CONSTRAINT  --  Interface
-;;;
-;;;    Return a constraint for the specified arguments.  We only create a new
-;;; constraint if there isn't already an equivalent old one, guaranteeing that
-;;; all equivalent constraints are EQ.  This shouldn't be called on lambda-vars
-;;; with no CONSTRAINTS set.
-;;;
-(defun find-constraint (kind x y not-p)
-  (declare (type lambda-var x) (type (or constant lambda-var ctype) y)
-	   (type boolean not-p))
-  (or (etypecase y
-	(ctype
-	 (do-elements (con (lambda-var-constraints x) nil)
-	   (when (and (eq (constraint-kind con) kind)
-		      (eq (constraint-not-p con) not-p)
-		      (type= (constraint-y con) y))
-	     (return con))))
-	(constant
-	 (do-elements (con (lambda-var-constraints x) nil)
-	   (when (and (eq (constraint-kind con) kind)
-		      (eq (constraint-not-p con) not-p)
-		      (eq (constraint-y con) y))
-	     (return con))))
-	(lambda-var 
-	 (do-elements (con (lambda-var-constraints x) nil)
-	   (when (and (eq (constraint-kind con) kind)
-		      (eq (constraint-not-p con) not-p)
-		      (let ((cx (constraint-x con)))
-			(eq (if (eq cx x)
-				(constraint-y con)
-				cx)
-			    y)))
-	     (return con)))))
-      (let ((new (make-constraint (incf *constraint-number*) kind x y not-p)))
-	(sset-adjoin new (lambda-var-constraints x))
-	(when (lambda-var-p y)
-	  (sset-adjoin new (lambda-var-constraints y)))
-	new)))
-
-
-;;; FIND-BLOCK-TYPE-CONSTRAINTS  --  Internal
-;;;
-;;;    Compute the initial flow analysis sets for Block:
-;;; -- For any lambda-var ref with a type check, add that constraint.
-;;; -- For any lambda-var set, delete all constraints on that var, and add
-;;;    those constraints to the set nuked by this block.
-;;;    
-(defun find-block-type-constraints (block)
-  (let ((gen (make-sset))
-	(kill (make-sset)))
-	
-    (do-nodes (node cont block)
-      (typecase node
-	(ref
-	 (when (continuation-type-check cont)
-	   (let ((leaf (ref-leaf node)))
-	     (when (and (lambda-var-p leaf)
-			(lambda-var-constraints leaf))
-	       (let* ((atype (continuation-derived-type cont))
-		      (con (find-constraint 'typep leaf atype nil)))
-		 (sset-adjoin con gen))))))
-	(cset
-	 (let ((var (set-var node)))
-	   (when (lambda-var-p var)
-	     (let ((cons (lambda-var-constraints var)))
-	       (when cons
-		 (sset-difference gen cons)
-		 (sset-union kill cons))))))))
-
-    (setf (block-gen block) gen)
-    (setf (block-kill block) kill)
-    (setf (block-out block) (copy-sset gen))
-    (setf (block-type-asserted block) nil)
-    (undefined-value)))
-
-
-;;; GET-CONSTRAINTS-TYPE  --  Internal
-;;;
-;;;    Given the set of Constraints for a variable and the current set of
-;;; restrictions from flow analysis In, return the best approximation of what
-;;; the type of a reference would be.
-;;;
-(defun get-constraints-type (constraints in)
-  (let ((var-cons (copy-sset constraints)))
-    (sset-intersection var-cons in)
-    (let ((res *universal-type*))
-      (do-elements (con var-cons)
-	(when (eq (constraint-kind con) 'typep)
-	  (if (constraint-not-p con)
-	      (let ((diff (type-difference res (constraint-y con))))
-		(when diff
-		  (setf res diff)))
-	      (setq res (type-intersection res (constraint-y con))))))
-      res)))
-
-		 
-;;; USE-RESULT-CONSTRAINTS  --  Internal
-;;;
-;;;    Deliver the results of constraint propagation to REFs in Block.  During
-;;; this pass, we also do local constraint propagation by adding in constraints
-;;; as we seem them during the pass through the block.
-;;;
-(defun use-result-constraints (block)
-  (declare (type cblock block))
-  (let ((in (block-in block)))
-    (do-nodes (node cont block)
-      (typecase node
-	(ref
-	 (let ((var (ref-leaf node)))
-	   (when (lambda-var-p var)
-	     (let ((con (lambda-var-constraints var)))
-	       (when con
-		 (derive-node-type node (get-constraints-type con in))
-		 (when (continuation-type-check cont)
-		   (sset-adjoin
-		    (find-constraint 'typep var
-				     (continuation-asserted-type cont)
-				     nil)
-		    in)))))))
-	(cset
-	 (let ((var (set-var node)))
-	   (when (lambda-var-p var)
-	     (let ((cons (lambda-var-constraints var)))
-	       (when cons
-		 (sset-difference in cons))))))))))
-
-
-;;; CLOSURE-VAR-P  --  Internal
-;;;
-;;;    Return true if Var would have to be closed over if environment analysis
-;;; ran now (i.e. if there are any uses that have a different home lambda than
-;;; the var's home.)
-;;;
-(defun closure-var-p (var)
-  (declare (type lambda-var var))
-  (let ((home (lambda-home (lambda-var-home var))))
-    (flet ((frob (l)
-	     (dolist (node l nil)
-	       (unless (eq (lambda-home (block-lambda (node-block node))) home)
-		 (return t)))))
-      (or (frob (leaf-refs var))
-	  (frob (basic-var-sets var))))))
-
-
-;;; INIT-VAR-CONSTRAINTS  --  Internal
-;;;
-;;;    Give an empty constraints set to any var that doesn't have one and isn't
-;;; a set closure var.  Since a var that we previously rejected looks identical
-;;; to one that is new, so we optimistically keep hoping that vars stop being
-;;; closed over or lose their sets.
-;;;
-(defun init-var-constraints (component)
-  (declare (type component component))
-  (dolist (fun (component-lambdas component))
-    (flet ((frob (x)
-	     (dolist (var (lambda-vars x))
-	       (unless (lambda-var-constraints var)
-		 (when (or (null (lambda-var-sets var))
-			   (not (closure-var-p var)))
-		   (setf (lambda-var-constraints var) (make-sset)))))))
-      (frob fun)
-      (dolist (let (lambda-lets fun))
-	(frob let)))))
-
-
-;;; FLOW-PROPAGATE-CONSTRAINTS  --  Internal
-;;;
-(defun flow-propagate-constraints (block)
-  (let* ((pred (block-pred block))
-	 (in (copy-sset (block-out (first pred)))))
-    (dolist (b (rest pred))
-      (sset-intersection in (block-out b)))
-    (setf (block-in block) in)
-    (sset-union-of-difference (block-out block) in (block-kill block))))
-
-
-;;; CONSTRAINT-PROPAGATE  --  Interface
-;;;
-(defun constraint-propagate (component)
-  (declare (type component component))
-  (init-var-constraints component)
-  (do-blocks (block component)
-    (when (block-type-asserted block)
-      (find-block-type-constraints block)))
-  (setf (block-out (component-head component)) (make-sset))
-
-  (let ((did-something nil))
-    (loop
-      (do-blocks (block component)
-	(when (flow-propagate-constraints block)
-	  (setq did-something t)))
-
-      (unless did-something (return))
-      (setq did-something nil)))
-
-  (do-blocks (block component)
-    (use-result-constraints block))
-
-  (undefined-value))
diff --git a/compiler/control.lisp b/compiler/control.lisp
deleted file mode 100644
index 6474c9414408e39fb54f499ecbb7e6fc2a1c0089..0000000000000000000000000000000000000000
--- a/compiler/control.lisp
+++ /dev/null
@@ -1,139 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    The control analysis pass in the compiler.  This pass determines the
-;;; order in which the IR2 blocks are to be emitted, attempting to minimize the
-;;; associated branching costs.
-;;;
-;;;    At this point, we commit to generating IR2 (and ultimately assembler)
-;;; for reachable blocks.  Before this phase there might be blocks that are
-;;; unreachable but still appear in the DFO, due in inadequate optimization,
-;;; etc.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-
-;;; Add-To-Emit-Order  --  Interface
-;;;
-;;;    Insert Block in the emission order after the block After.  We also add
-;;; the block to the IR2-Environment-Blocks.
-;;;
-(defun add-to-emit-order (block after)
-  (declare (type ir2-block block after))
-  (let ((next (ir2-block-next after)))
-    (setf (ir2-block-next after) block)
-    (setf (ir2-block-prev block) after)
-    (setf (ir2-block-next block) next)
-    (setf (ir2-block-prev next) block))
-
-  (let ((2env (environment-info
-	       (lambda-environment
-		(block-lambda (ir2-block-block block))))))
-    (push-in ir2-block-environment-next block (ir2-environment-blocks 2env)))
-
-  (undefined-value))
-
-
-;;; Control-Analyze-Block  --  Internal
-;;;
-;;;    Do a graph walk linking blocks into the emit order as we go.  We treat
-;;; blocks ending in TR nodes specially, since it may be that we want to go
-;;; somewhere other than the return block.  If tail-call-p, then we drop
-;;; through to the head of the called function in a TR local calls (instead of
-;;; to the return node.)
-;;;
-;;;    If the IR2 blocks haven't already been assigned, then we make them at
-;;; this point.
-;;;
-(defun control-analyze-block (block tail)
-  (declare (type cblock block) (type ir2-block tail))
-  (unless (block-flag block)
-    (setf (block-flag block) t)
-    (assert (and (block-component block) (not (block-delete-p block))))
-    (add-to-emit-order (or (block-info block)
-			   (setf (block-info block) (make-ir2-block block)))
-		       (ir2-block-prev tail))
-
-    #|But not really...
-    (let ((last (block-last block)))
-      (when (and (combination-p last) (node-tail-p last)
-		 (eq (basic-combination-kind last) :local)
-		 tail-call-p)
-	(control-analyze-block (node-block
-				(lambda-bind
-				 (ref-leaf
-				  (continuation-use
-				   (basic-combination-fun last)))))
-			       tail t)))
-    |#
-    
-    (dolist (succ (block-succ block))
-      (control-analyze-block succ tail)))
-
-  (undefined-value))
-
-
-;;; CONTROL-ANALYZE-1-FUN  --  Internal
-;;;
-;;;    Analyze all of the NLX EPs first to ensure that code reachable only from
-;;; a NLX is emitted contiguously with the code reachable from the Bind.  Code
-;;; reachable from the Bind is inserted *before* the NLX code so that the Bind
-;;; marks the beginning of the code for the function.  The walk from a NLX EP
-;;; will never reach the bind block, so we will always get to insert it at the
-;;; beginning.
-;;;
-(defun control-analyze-1-fun (fun component)
-  (declare (type clambda fun) (type component component))
-  (let* ((tail-block (block-info (component-tail component)))
-	 (prev-block (ir2-block-prev tail-block))
-	 (bind-block (node-block (lambda-bind fun))))
-    (unless (block-flag bind-block)
-      (dolist (nlx (environment-nlx-info (lambda-environment fun)))
-	(control-analyze-block (nlx-info-target nlx) tail-block))
-      (assert (not (block-flag bind-block)))
-      (control-analyze-block bind-block (ir2-block-next prev-block))))
-  (undefined-value))
-
-  
-;;; Control-Analyze  --  Interface
-;;;
-;;;    Do control analysis on Component, finding the emit order.  Our only
-;;; cleverness here is that we walk XEP's first to increase the probability
-;;; that the tail call will be a drop-through.
-;;;
-;;;    When we are done, we delete all blocks that weren't reached during our
-;;; walk.  This allows IR2 phases to assume that all IR1 blocks in the DFO have
-;;; valid IR2 blocks in their Info.
-;;;
-(defun control-analyze (component)
-  (let* ((head (component-head component))
-	 (head-block (make-ir2-block head))
-	 (tail (component-tail component))
-	 (tail-block (make-ir2-block tail)))
-    (setf (block-info head) head-block)
-    (setf (block-info tail) tail-block)
-    (setf (ir2-block-prev tail-block) head-block)
-    (setf (ir2-block-next head-block) tail-block)
-
-    (clear-flags component)
-
-    (dolist (fun (component-lambdas component))
-      (when (external-entry-point-p fun)
-	(control-analyze-1-fun fun component)))
-
-    (dolist (fun (component-lambdas component))
-      (control-analyze-1-fun fun component))
-
-    (do-blocks (block component)
-      (unless (block-flag block)
-	(delete-block block))))
-
-  (undefined-value))
diff --git a/compiler/ctype.lisp b/compiler/ctype.lisp
deleted file mode 100644
index b28632353848dc6e3a9ffb2531afcd174139a406..0000000000000000000000000000000000000000
--- a/compiler/ctype.lisp
+++ /dev/null
@@ -1,529 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    This file contains code which knows about both the type representation
-;;; and the compiler IR1 representation.  This stuff is used for doing type
-;;; checking.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-;;; These are the functions that are to be called when a problem is detected.
-;;; They are passed format arguments.  If null, we don't do anything.  The
-;;; error function is called when something is definitely incorrect.  The
-;;; warning function is called when it is somehow impossible to tell if the
-;;; call is correct.
-;;;
-(defvar *error-function*)
-(defvar *warning-function*)
-
-;;; The function that we use for type checking.  The derived type is the first
-;;; argument and the type we are testing against is the second argument.  The
-;;; function should return values like Csubtypep. 
-;;;
-(defvar *test-function*)
-
-(proclaim '(type (or function null) *error-function* *warning-function
-		 *test-function*))
-
-;;; *lossage-detected* is set if a definite incompatibility is detected.
-;;; *slime-detected* is set if we can't tell whether the call is compatible or
-;;; not.
-;;;
-(defvar *lossage-detected*)
-(defvar *slime-detected*)
-
-
-;;; Note-Lossage, Note-Slime  --  Internal
-;;;
-;;;    Signal a warning if appropriate and set the *lossage-detected* flag.
-;;;
-(proclaim '(ftype (function (string &rest t) void) note-lossage note-slime))
-(defun note-lossage (format-string &rest format-args)
-  (setq *lossage-detected* t)
-  (when *error-function*
-    (apply *error-function* format-string format-args)))
-;;;
-(defun note-slime (format-string &rest format-args)
-  (setq *slime-detected* t)
-  (when *warning-function*
-    (apply *warning-function* format-string format-args)))
-
-
-(proclaim '(special *compiler-error-context*))
-
-
-;;;; Stuff for checking a call against a function type.
-
-;;; Valid-Function-Use  --  Interface
-;;;
-;;;    Determine whether a use of a function is consistent with its type.  The
-;;; first value is true if the call is thought to be valid, and the second
-;;; value is true when the first value is definitely correct.
-;;;
-;;; The Argument-Test function is used to determine whether an argument type
-;;; matches the type we are checking against.  Similarly, the Result-Test is
-;;; used to determine whether the result type matches the specified result.
-;;;
-;;; Unlike the argument test, the result test may be called on values or
-;;; function types.  If Strict-Result is true, then the Node-Derived-Type is
-;;; always used.  If Strict-Result is false and Cont's Type-Check is true, then
-;;; the Node-Derived-Type is intersected with the Cont's Asserted-Type.
-;;;
-;;; The error and warning functions are functions that are called to explain
-;;; the result.  We bind *compiler-error-context* to the combination node so
-;;; that Compiler-Warning and related functions will do the right thing if
-;;; they are supplied.
-;;;
-(defun valid-function-use (call type &key
-				((:argument-test *test-function*) #'csubtypep)
-				(result-test #'values-subtypep)
-				(strict-result nil)
-				((:error-function *error-function*))
-				((:warning-function *warning-function*)))
-  (declare (function result-test) (type combination call)
-	   (type function-type type))
-  (let* ((*lossage-detected* nil)
-	 (*slime-detected* nil)
-	 (*compiler-error-context* call)
-	 (args (combination-args call))
-	 (nargs (length args))
-	 (required (function-type-required type))
-	 (min-args (length required))
-	 (optional (function-type-optional type))
-	 (max-args (+ min-args (length optional)))
-	 (rest (function-type-rest type))
-	 (keyp (function-type-keyp type)))
-    
-    (cond ((< nargs min-args)
-	   (note-lossage "Function called with ~R argument~:P, but wants at least ~R."
-			 nargs min-args))
-	  ((<= nargs max-args)
-	   (check-fixed-and-rest args (append required optional) rest))
-	  ((not (or keyp rest))
-	   (note-lossage "Function called with ~R argument~:P, but wants at most ~R."
-			 nargs max-args))
-	  ((and keyp (oddp (- nargs max-args)))
-	   (note-lossage "Function has an odd number of arguments in the keyword portion."))
-	  (t
-	   (check-fixed-and-rest args (append required optional) rest)
-	   (when keyp
-	     (check-keywords args max-args type))))
-    
-    (let* ((dtype (node-derived-type call))
-	   (return-type (function-type-returns type))
-	   (cont (node-cont call))
-	   (out-type
-	    (if (or strict-result (not (continuation-type-check cont)))
-		dtype
-		(values-type-intersection (continuation-asserted-type cont)
-					  dtype))))
-      (multiple-value-bind (int win)
-			   (funcall result-test out-type return-type)
-	(cond ((not win)
-	       (note-slime "Can't tell whether the result is a ~S."
-			   (type-specifier return-type)))
-	      ((not int)
-	       (note-lossage "The result is a ~S, not a ~S."
-			     (type-specifier out-type)
-			     (type-specifier return-type)))))) 
-    
-    (cond (*lossage-detected* (values nil t))
-	  (*slime-detected* (values nil nil))
-	  (t (values t nil)))))
-
-
-;;; Check-Arg-Type  --  Internal
-;;;
-;;;    Check that the derived type of the continuation Cont is compatible with
-;;; Type.  N is the arg number, for error message purposes.  We return true if
-;;; arg is definitely o.k.
-;;;
-(proclaim '(function check-arg-type (continuation type fixnum) void))
-(defun check-arg-type (cont type n)
-  (let ((ctype (continuation-type cont)))
-    (multiple-value-bind (int win)
-			 (funcall *test-function* ctype type)
-      (cond ((not win)
-	     (note-slime "Can't tell whether the ~:R argument is a ~S." n
-			 (type-specifier type))
-	     nil)
-	    ((not int)
-	     (note-lossage "The ~:R argument is a ~S, not a ~S." n
-			   (type-specifier ctype)
-			   (type-specifier type))
-	     nil)
-	    (t t)))))
-
-  
-;;; Check-Fixed-And-Rest  --  Internal
-;;;
-;;;    Check that each of the type of each supplied argument intersects with
-;;; the type specified for that argument.  If we can't tell, then we complain
-;;; about the slime.
-;;;
-(proclaim '(function check-fixed-and-rest (list list (or type null)) void))
-(defun check-fixed-and-rest (args types rest)
-  (do ((arg args (cdr arg))
-       (type types (cdr type))
-       (n 1 (1+ n)))
-      ((or (null type) (null arg))
-       (when rest
-	 (dolist (arg arg)
-	   (check-arg-type arg rest n)
-	   (incf n))))
-    (declare (fixnum n))
-    (check-arg-type (car arg) (car type) n)))
-
-
-;;; Check-Keywords  --  Internal
-;;;
-;;;    Check that the keyword args are of the correct type.  Each keyword
-;;; should be known and the corresponding argument should be of the correct
-;;; type.  If the keyword isn't a constant, then we can't tell, so we note
-;;; slime.
-;;;
-(proclaim '(function check-keywords (list fixnum function-type) void))
-(defun check-keywords (args pre-key type)
-  (do ((key (nthcdr pre-key args) (cddr key))
-       (n pre-key (+ n 2)))
-      ((null key))
-    (declare (fixnum n))
-    (let ((k (car key)))
-      (check-arg-type k (specifier-type 'symbol) n)
-      (cond ((not (check-arg-type k (specifier-type 'keyword) n)))
-	    ((not (constant-continuation-p k))
-	     (note-slime "The keyword for the ~:R argument is not a constant." n))
-	    (t
-	     (let* ((name (continuation-value k))
-		    (info (find name (function-type-keywords type) :key #'key-info-name)))
-	       (cond ((not info)
-		      (unless (function-type-allowp type)
-			(note-lossage "~S is not a known argument keyword." name)))
-		     (t
-		      (check-arg-type (second key) (key-info-type info) n)))))))))
-
-
-;;; Lambda-Result-Type  --  Internal
-;;;
-;;;    Guess the return type of a Lambda.  We just return the derived type of
-;;; the result continuation, assuming that IR1 optimize and Type check have
-;;; made this be a good description of the return type.
-;;;
-(proclaim '(function lambda-result-type (lambda) type))
-(defun lambda-result-type (lambda)
-  (let ((ret (lambda-return lambda)))
-    (if ret
-	(continuation-derived-type (return-result ret))
-	*empty-type*)))
-
-
-;;; Definition-Type  --  Interface
-;;;
-;;;    Construct a function type from a definition.
-;;;
-;;; Due to the lack of a (list x) type specifier, we can't reconstruct the
-;;; &rest type.
-;;;
-(proclaim '(function definition-type (functional) function-type))
-(defun definition-type (functional)
-  (if (lambda-p functional)
-      (make-function-type
-       :required (mapcar #'leaf-type (lambda-vars functional))
-       :returns (lambda-result-type functional))
-      (let ((rest nil))
-	(collect ((req)
-		  (opt)
-		  (keys))
-	  (dolist (arg (optional-dispatch-arglist functional))
-	    (let ((info (lambda-var-arg-info arg))
-		  (type (leaf-type arg)))
-	      (if info
-		  (ecase (arg-info-kind info)
-		    (:required (req type))
-		    (:optional (opt type))
-		    (:keyword
-		     (keys (make-key-info :name (arg-info-keyword info)
-					  :type type)))
-		    (:rest
-		     (setq rest *universal-type*)))
-		  (req type))))
-	  
-	  (make-function-type
-	   :required (req)  :optional (opt)  :rest rest  :keywords (keys)
-	   :keyp (optional-dispatch-keyp functional)
-	   :allowp (optional-dispatch-allowp functional)
-	   :returns (lambda-result-type
-		     (optional-dispatch-main-entry functional)))))))
-
-
-
-;;;; Approximate function types:
-;;;
-;;;    Approximate function types provide a condensed representation of all the
-;;; different ways that a function has been used.  If we have no declared or
-;;; defined type for a function, then we build an approximate function type
-;;; by examining each use of the function.  When we encounter a definition or
-;;; proclamation, we can check the actual type for compatibity with the
-;;; previous uses.
-
-
-(defstruct (approximate-function-type)
-  ;;
-  ;; The smallest and largest numbers of arguments that this function has been
-  ;; called with.
-  (min-args call-arguments-limit :type fixnum)
-  (max-args 0 :type fixnum)
-  ;;
-  ;; A list of lists of the all the types that have been used in each argument
-  ;; position.
-  (types () :type list)
-  ;;
-  ;; A list of the Approximate-Key-Info structures describing all the things
-  ;; that looked like keyword arguments.  There are distinct structures
-  ;; describing each argument position in which the keyword appeared.
-  (keys () :type list))
-
-
-(defstruct (approximate-key-info)
-  ;;
-  ;; The keyword name of this argument.
-  (name nil :type keyword)
-  ;;
-  ;; The position at which this keyword appeared.  0 if it appeared as the
-  ;; first argument, etc.
-  (position nil :type fixnum)
-  ;;
-  ;; A list of all the argument types that have been used with this keyword.
-  (types nil :type list)
-  ;;
-  ;; True if this keyword has appeared only in calls with an obvious
-  ;; :allow-other-keys.
-  (allowp nil :type (member t nil)))
-
-
-;;; Note-Function-Use  --  Interface
-;;;
-;;;    Return an Approximate-Function-Type representing the context of Call.
-;;; If Type is supplied and not null, then we merge the information into the
-;;; information already accumulated in Type.
-;;;
-(proclaim '(function note-function-use
-		     (combination &optional (or approximate-function-type null))
-		     approximate-function-type))
-(defun note-function-use (call &optional type)
-  (let* ((type (or type (make-approximate-function-type)))
-	 (types (approximate-function-type-types type))
-	 (args (combination-args call))
-	 (nargs (length args))
-	 (allowp (find-if #'(lambda (x)
-			      (and (constant-continuation-p x)
-				   (eq (continuation-value x) :allow-other-keys)))
-			  args)))
-
-    (setf (approximate-function-type-min-args type)
-	  (min (approximate-function-type-min-args type) nargs))
-    (setf (approximate-function-type-max-args type)
-	  (max (approximate-function-type-max-args type) nargs))
-
-    (do ((old types (cdr old))
-	 (arg args (cdr arg)))
-	((null old)
-	 (setf (approximate-function-type-types type)
-	       (nconc types
-		      (mapcar #'(lambda (x)
-				  (list (continuation-type x)))
-			      arg))))
-      (when (null arg) (return))
-      (pushnew (continuation-type (car arg))
-	       (car old)
-	       :test #'type=))
-
-    (collect ((keys (approximate-function-type-keys type) cons))
-      (do ((arg args (cdr arg))
-	   (pos 0 (1+ pos)))
-	  ((or (null arg) (null (cdr arg)))
-	   (setf (approximate-function-type-keys type) (keys)))
-	(let ((key (first arg))
-	      (val (second arg)))
-	  (when (constant-continuation-p key)
-	    (let ((name (continuation-value key)))
-	      (when (keywordp name)
-		(let ((old (find-if
-			    #'(lambda (x)
-				(and (eq (approximate-key-info-name x) name)
-				     (= (approximate-key-info-position x) pos)))
-			    (keys)))
-		      (val-type (continuation-type val))) 
-		  (cond (old
-			 (pushnew val-type
-				  (approximate-key-info-types old)
-				  :test #'type=)
-			 (unless allowp
-			   (setf (approximate-key-info-allowp old) nil)))
-			(t
-			 (keys (make-approximate-key-info
-				:name name  :position pos  :allowp allowp
-				:types (list val-type))))))))))))
-    type))
-
-
-;;; Valid-Approximate-Type  --  Interface
-;;;
-;;;    Similar to Valid-Function-Use, but checks an Approximate-Function-Type
-;;; against a real function type.
-;;;
-(proclaim '(function valid-approximate-type
-		     (approximate-function-type function-type &optional
-						function function function)
-		     (values boolean boolean)))
-(defun valid-approximate-type (call-type type &optional (*test-function* #'types-intersect)
-					 (*error-function* #'compiler-warning)
-					 (*warning-function* #'compiler-note))
-  (let* ((*lossage-detected* nil)
-	 (*slime-detected* nil)
-	 (required (function-type-required type))
-	 (min-args (length required))
-	 (optional (function-type-optional type))
-	 (max-args (+ min-args (length optional)))
-	 (rest (function-type-rest type))
-	 (keyp (function-type-keyp type)))
-
-    (let ((call-min (approximate-function-type-min-args call-type)))
-      (when (< call-min min-args)
-	(note-lossage
-	 "Function previously called with ~R argument~:P, but wants at least ~R."
-	 call-min min-args)))
-
-    (let ((call-max (approximate-function-type-max-args call-type)))
-      (cond ((<= call-max max-args))
-	    ((not (or keyp rest))
-	     (note-lossage
-	      "Function previously called with ~R argument~:P, but wants at most ~R."
-	      call-max max-args))
-	    ((and keyp (oddp (- call-max max-args)))
-	     (note-lossage
-	      "Function previously called with an odd number of arguments in ~
-	      the keyword portion.")))
-
-      (when (and keyp (> call-max max-args))
-	(check-approximate-keywords call-type max-args type)))
-
-    (check-approximate-fixed-and-rest call-type (append required optional) rest)
-
-    (cond (*lossage-detected* (values nil t))
-	  (*slime-detected* (values nil nil))
-	  (t (values t t)))))
-
-
-;;; Check-Approximate-Fixed-And-Rest  --  Internal
-;;;
-;;;    Check that each of the types used at each arg position is compatible
-;;; with the actual type.
-;;;
-(proclaim '(function check-approximate-fixed-and-rest
-		     (approximate-function-type list (or type null))
-		     void))
-(defun check-approximate-fixed-and-rest (call-type fixed rest)
-  (do ((types (approximate-function-type-types call-type) (cdr types))
-       (n 1 (1+ n))
-       (arg fixed (cdr arg)))
-      ((null types))
-    (let ((decl-type (or (car arg) rest)))
-      (unless decl-type (return))
-      (check-approximate-arg-type (car types) decl-type "~R" n))))
-
-
-;;; Check-Approximate-Arg-Type  --  Internal
-;;;
-;;;    Check that each of the call-types is compatible with Decl-Type,
-;;; complaining if not or if we can't tell.
-;;;
-(proclaim '(function check-approximate-arg-type (list type string &rest t) void))
-(defun check-approximate-arg-type (call-types decl-type context &rest args)
-  (let ((losers *empty-type*))
-    (dolist (ctype call-types)
-      (multiple-value-bind (int win)
-			   (funcall *test-function* ctype decl-type)			   
-	(cond
-	 ((not win)
-	  (note-slime "Can't tell whether previous ~? argument type ~S is a ~S."
-		      context args (type-specifier ctype) (type-specifier decl-type)))
-	 ((not int)
-	  (setq losers (type-union ctype losers))))))
-
-    (unless (eq losers *empty-type*)
-      (note-lossage "~:(~?~) argument should be a ~S but was a ~S in a previous call."
-		    context args (type-specifier decl-type) (type-specifier losers)))))
-
-
-;;; Check-Approximate-Keywords  --  Internal
-;;;
-;;;    Check the types of each manifest keyword that appears in a keyword
-;;; argument position.  Check the validity of all keys that appeared in valid
-;;; keyword positions.
-;;;
-;;; ### We could check the Approximate-Function-Type-Types to make sure that
-;;; all arguments in keyword positions were manifest keywords.
-;;;
-(defun check-approximate-keywords (call-type max-args type)
-  (let ((call-keys (approximate-function-type-keys call-type))
-	(keys (function-type-keywords type)))
-    (dolist (key keys)
-      (let ((name (key-info-name key)))
-	(collect ((types nil append))
-	  (dolist (call-key call-keys)
-	    (let ((pos (approximate-key-info-position call-key)))
-	      (when (and (eq (approximate-key-info-name call-key) name)
-			 (> pos max-args) (evenp (- pos max-args)))
-		(types (approximate-key-info-types call-key)))))
-	  (check-approximate-arg-type (types) (key-info-type key) "~S" name))))
-    
-    (unless (function-type-allowp type)
-      (collect ((names () adjoin))
-	(dolist (call-key call-keys)
-	  (let ((pos (approximate-key-info-position call-key)))
-	    (when (and (> pos max-args) (evenp (- pos max-args))
-		       (not (approximate-key-info-allowp call-key)))
-	      (names (approximate-key-info-name call-key)))))
-
-	(dolist (name (names))
-	  (unless (find name keys :key #'key-info-name)
-	    (note-lossage "Function previously called with unknown argument keyword ~S."
-		  name)))))))
-
-
-;;;; Redefinition checking:
-;;;
-;;;    When we encounter a 
-
-#|
-
-
-;;; Valid-Redefinition  --  Interface
-;;;
-;;;    Check for reasonablness of redefining a function of type Old as type
-;;; New.
-;;;
-(proclaim '(function valid-redefinition (function-type function-type) ???))
-(defun valid-redefinition (old new)
-  ...)
-
-
-;;; Assert-Definition-Type  --  Interface
-;;;
-;;;    Propagate type constraints from Type to the variables and result of
-;;; Functional.
-;;;
-(proclaim '(function assert-definition-type (functional type) void))
-(defun assert-definition-type (functional type)
-  ...)
-|#
-
diff --git a/compiler/debug-dump.lisp b/compiler/debug-dump.lisp
deleted file mode 100644
index 7cc273aa21f0a367609c14d745d814e2840a39c9..0000000000000000000000000000000000000000
--- a/compiler/debug-dump.lisp
+++ /dev/null
@@ -1,505 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    This file contains stuff that creates debugger information from the
-;;; compiler's internal data structures.
-;;; 
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-(defvar *byte-buffer*
-  (make-array 10 :element-type '(unsigned-byte 8)
-	      :fill-pointer 0  :adjustable t))
-
-
-;;;; Debug blocks:
-
-(deftype location-kind ()
-  '(member :unknown-return :known-return :internal-error :non-local-exit
-	   :block-start))
-
-
-;;; The Location-Info structure holds the information what we need about
-;;; locations which code generation decided were "interesting".
-;;;
-(defstruct (location-info
-	    (:constructor make-location-info (kind label vop)))
-  ;;
-  ;; The kind of location noted.
-  (kind nil :type location-kind)
-  ;;
-  ;; The label pointing to the interesting code location.
-  (label nil :type label)
-  ;;
-  ;; The VOP that emitted this location (for node, save-set, ir2-block, etc.)
-  (vop nil :type vop))
-
-
-;;; NOTE-DEBUG-LOCATION  --  Interface
-;;;
-;;;    Called during code generation in places where there is an "interesting"
-;;; location: some place where we are likely to end up in the debugger, and
-;;; thus want debug info.
-;;;
-(defun note-debug-location (vop label kind)
-  (declare (type vop vop) (type label label) (type location-kind kind))
-  (setf (ir2-block-locations (vop-block vop))
-	(nconc (ir2-block-locations (vop-block vop))
-	       (list (make-location-info kind label vop))))
-  (undefined-value))
-
-
-;;; IR2-BLOCK-ENVIRONMENT  --  Interface
-;;;
-(proclaim '(inline ir2-block-environment))
-(defun ir2-block-environment (2block)
-  (declare (type ir2-block 2block))
-  (lambda-environment (block-lambda (ir2-block-block 2block))))
-
-
-;;; COMPUTE-LIVE-VARS  --  Internal
-;;;
-;;;    Given a local conflicts vector and an IR2 block to represent the set of
-;;; live TNs, and the Var-Locs hashtable representing the variables dumped,
-;;; compute a bit-vector representing the set of live variables.
-;;;
-(defun compute-live-vars (live block var-locs)
-  (declare (type ir2-block block) (type local-tn-bit-vector live)
-	   (type hash-table var-locs))
-  (let ((res (make-array (logandc2 (+ (hash-table-count var-locs) 7) 7)
-			 :element-type 'bit
-			 :initial-element 0)))
-    (do-live-tns (tn live block)
-      (let ((leaf (tn-leaf tn)))
-	(when (lambda-var-p leaf)
-	  (let ((num (gethash leaf var-locs)))
-	    (when num
-	      (setf (sbit res num) 1))))))
-    res))
-
-
-;;; The PC for the location most recently dumped.
-;;;
-(defvar *previous-location*)
-
-;;; DUMP-1-LOCATION  --  Internal
-;;;
-;;;    Dump a compiled debug-location into *BYTE-BUFFER* that describes the
-;;; code/source map and live info.
-;;;
-(defun dump-1-location (node block kind tlf-num label live var-locs)
-  (declare (type node node) (type ir2-block block)
-	   (type local-tn-bit-vector live) (type label label)
-	   (type location-kind kind) (type (or index null) tlf-num)
-	   (type hash-table var-locs))
-  
-  (vector-push-extend
-   (dpb (position kind compiled-code-location-kinds)
-	compiled-code-location-kind-byte
-	0)
-   *byte-buffer*)
-  
-  (let ((loc (label-location label)))
-    (write-var-integer (- loc *previous-location*) *byte-buffer*)
-    (setq *previous-location* loc))
-  
-  (unless tlf-num
-    (write-var-integer (node-tlf-number node) *byte-buffer*))
-  (write-var-integer (first (node-source-path node)) *byte-buffer*)
-  
-  (write-packed-bit-vector (compute-live-vars live block var-locs)
-			   *byte-buffer*)
-  
-  (undefined-value))
-
-
-;;; DUMP-LOCATION-FROM-INFO  --  Internal
-;;;
-;;;    Extract context info from a Location-Info structure and use it to dump a
-;;; compiled code-location.
-;;;
-(defun dump-location-from-info (loc tlf-num var-locs)
-  (declare (type location-info loc) (type (or index null) tlf-num)
-	   (type hash-table var-locs))
-  (let ((vop (location-info-vop loc)))
-    (dump-1-location (vop-node vop)
-		     (vop-block vop)
-		     (location-info-kind loc)
-		     tlf-num
-		     (location-info-label loc)
-		     (vop-save-set vop)
-		     var-locs))
-  (undefined-value))
-
-
-;;; COMPUTE-DEBUG-BLOCKS  --  Internal
-;;;
-;;;    Return a vector and an integer (or null) suitable for use as the BLOCKS
-;;; and TLF-NUMBER in Fun's debug-function.  This requires three passes to
-;;; compute:
-;;; -- Scan all the blocks, caching the block numbering in the BLOCK-FLAG and
-;;;    determining if all locations are in the same TLF.
-;;; -- Scan all blocks, dumping the header and successors followed by all the
-;;;    non-elsewhere locations.
-;;; -- Dump the elsewhere block header and all the elsewhere locations (if
-;;;    any.)
-;;;
-(defun compute-debug-blocks (fun var-locs)
-  (declare (type clambda fun) (type hash-table var-locs))
-  (setf (fill-pointer *byte-buffer*) 0)
-  (let ((*previous-location* 0)
-	(tlf-num (node-tlf-number (lambda-bind fun))))
-    (let ((num 0))
-      (do-environment-ir2-blocks (2block (lambda-environment fun))
-	(let ((block (ir2-block-block 2block)))
-	  (when (eq (block-info block) 2block)
-	    (setf (block-flag block) num)
-	    (incf num)
-	    (unless (eql (node-tlf-number
-			  (continuation-next (block-start block)))
-			 tlf-num)
-	      (setq tlf-num nil)))
-	  
-	  (dolist (loc (ir2-block-locations 2block))
-	    (unless (eql (node-tlf-number (vop-node (location-info-vop loc)))
-			 tlf-num)
-	      (setq tlf-num nil))))))
-
-    (collect ((elsewhere))
-      (let ((tail (component-tail
-		   (block-component (node-block (lambda-bind fun))))))
-	(do-environment-ir2-blocks (2block (lambda-environment fun))
-	  (let ((block (ir2-block-block 2block)))
-	    (when (eq (block-info block) 2block)
-	      (let ((succ (let ((s (block-succ block)))
-			    (if (eq (car s) tail)
-				()
-				s))))
-		(vector-push-extend
-		 (dpb (length succ) compiled-debug-block-nsucc-byte 0)
-		 *byte-buffer*)
-		(dolist (b succ)
-		  (write-var-integer (block-flag b) *byte-buffer*)))
-
-	      (collect ((here))
-		(dolist (loc (ir2-block-locations 2block))
-		  (if (label-elsewhere-p (location-info-label loc))
-		      (elsewhere loc)
-		      (here loc)))
-		(write-var-integer (1+ (length (here))) *byte-buffer*)
-	      
-		(dump-1-location (continuation-next (block-start block))
-				 2block :block-start tlf-num
-				 (ir2-block-%label 2block)
-				 (ir2-block-live-out 2block)
-				 var-locs)
-		
-		(dolist (loc (here))
-		  (dump-location-from-info loc tlf-num var-locs)))))))
-
-      (when (elsewhere)
-	(vector-push-extend compiled-debug-block-elsewhere-p *byte-buffer*)
-	(write-var-integer (length (elsewhere)) *byte-buffer*)
-	(dolist (loc (elsewhere))
-	  (dump-location-from-info loc tlf-num var-locs))))
-
-    (values (copy-seq *byte-buffer*) tlf-num)))
-
-
-;;; DEBUG-SOURCE-FOR-INFO  --  Interface
-;;;
-;;;    Return a list of DEBUG-SOURCE structures containing information derived
-;;; from Info.
-;;;
-(defun debug-source-for-info (info)
-  (declare (type source-info info))
-  (assert (not (source-info-current-file info)))
-  (mapcar #'(lambda (x)
-	      (let ((name (file-info-name x))
-		    (res (make-debug-source
-			  :from :file
-			  :created (file-info-write-date x)
-			  :compiled (source-info-start-time info)
-			  :source-root (file-info-source-root x)
-			  :start-positions
-			  (when (policy nil (>= debug 2))
-			    (coerce-to-smallest-eltype
-			     (file-info-positions x))))))
-		(cond ((pathnamep name)
-		       (setf (debug-source-name res) name))
-		      (t
-		       (setf (debug-source-from res) name)
-		       (when (eq name :lisp)
-			 (setf (debug-source-name res)
-			       (cadr (aref (file-info-forms x) 0))))))
-		res))
-	  (source-info-files info)))
-
-
-;;; COERCE-TO-SMALLEST-ELTYPE  --  Internal
-;;;
-;;;    Given an arbirtary sequence, coerce it to an unsigned vector if
-;;; possible.
-;;;
-(defun coerce-to-smallest-eltype (seq)
-  (let ((max 0))
-    (macrolet ((frob ()
-		 '(if (and (integerp val) (>= val 0) max)
-		      (when (> val max)
-			(setq max val))
-		      (setq max nil))))
-      (if (listp seq)
-	  (dolist (val seq)
-	    (frob))
-	  (dotimes (i (length seq))
-	    (let ((val (aref seq i)))
-	      (frob)))))
-    
-    (if max
-	(coerce seq `(vector (integer 0 ,max)))
-	(coerce seq 'simple-vector))))
-
-
-;;;; Locations:
-
-;;; TN-SC-OFFSET  --  Internal
-;;;
-;;;    Return a SC-OFFSET describing TN's location.
-;;;
-(defun tn-sc-offset (tn)
-  (declare (type tn tn))
-  (make-sc-offset (sc-number (tn-sc tn))
-		  (tn-offset tn)))
-
-
-;;; DUMP-1-VARIABLE  --  Internal
-;;;
-;;;    Dump info to represent Var's location being TN.  ID is an integer that
-;;; makes Var's name unique in the function.  Buffer is the vector we stick the
-;;; result in.
-;;;
-(defun dump-1-variable (var tn id buffer)
-  (declare (type lambda-var var) (type tn tn) (type unsigned-byte id))
-  (let* ((name (leaf-name var))
-	 (package (symbol-package name))
-	 (package-p (and package (not (eq package *package*))))
-	 (save-tn (tn-save-tn tn))
-	 (flags 0))
-    (unless package
-      (setq flags (logior flags compiled-debug-variable-uninterned)))
-    (when package-p
-      (setq flags (logior flags compiled-debug-variable-packaged)))
-    (when (eq (tn-kind tn) :environment)
-      (setq flags (logior flags compiled-debug-variable-environment-live)))
-    (when save-tn
-      (setq flags (logior flags compiled-debug-variable-save-loc-p)))
-    (unless (zerop id)
-      (setq flags (logior flags compiled-debug-variable-id-p)))
-    (vector-push-extend flags buffer)
-    (write-var-string (symbol-name name) buffer)
-    (when package-p
-      (write-var-string (package-name package) buffer))
-    (unless (zerop id)
-      (write-var-integer id buffer))
-    (write-var-integer (tn-sc-offset tn) buffer)
-    (when save-tn
-      (write-var-integer (tn-sc-offset save-tn) buffer)))
-  (undefined-value))
-
-
-;;; COMPUTE-VARIABLES  --  Internal
-;;;
-;;;    Return a vector suitable for use as the DEBUG-FUNCTION-VARIABLES of Fun.
-;;; Level is the current DEBUG-INFO quality.  Var-Locs is a hashtable in which
-;;; we enter the translation from LAMBDA-VARS to the relative position of that
-;;; variable's location in the resulting vector.
-;;;
-(defun compute-variables (fun level var-locs)
-  (declare (type clambda fun) (type hash-table var-locs))
-  (collect ((vars))
-    (labels ((frob-leaf (leaf tn gensym-p)
-	       (let ((name (leaf-name leaf)))
-		 (when (and name (leaf-refs leaf)
-			    (or gensym-p (symbol-package name)))
-		   (vars (cons leaf tn)))))
-	     (frob-lambda (x gensym-p)
-	       (dolist (leaf (lambda-vars x))
-		 (frob-leaf leaf (leaf-info leaf) gensym-p))))
-      (frob-lambda fun t)
-      (when (>= level 2)
-	(dolist (x (ir2-environment-environment
-		    (environment-info (lambda-environment fun))))
-	  (let ((thing (car x)))
-	    (when (lambda-var-p thing)
-	      (frob-leaf thing (cdr x) (= level 3)))))
-	
-	(dolist (let (lambda-lets fun))
-	  (frob-lambda let (= level 3)))))
-    
-    (setf (fill-pointer *byte-buffer*) 0)
-    (let ((sorted (sort (vars) #'string<
-			:key #'(lambda (x)
-				 (symbol-name (leaf-name (car x))))))
-	  (prev-name nil)
-	  (id 0)
-	  (i 0))
-      (declare (type (or simple-string null) prev-name))
-      (dolist (x sorted)
-	(let* ((var (car x))
-	       (name (symbol-name (leaf-name var))))
-	  (cond ((and prev-name (string= prev-name name))
-		 (incf id))
-		(t
-		 (setq id 0  prev-name name)))
-	  (dump-1-variable var (cdr x) id *byte-buffer*)
-	  (setf (gethash var var-locs) i))
-	(incf i)))
-
-    (copy-seq *byte-buffer*)))
-
-
-;;; DEBUG-LOCATION-FOR  --  Internal
-;;;
-;;;    Return Var's relative position in the function's variables (determined
-;;; from the Var-Locs hashtable.)  If Var is deleted, the return DELETED.
-;;;
-(defun debug-location-for (var var-locs)
-  (declare (type lambda-var var) (type hash-table var-locs))
-  (let ((res (gethash var var-locs)))
-    (cond (res)
-	  (t
-	   (assert (null (leaf-refs var)))
-	   'deleted))))
-
-
-;;;; Arguments/returns:
-
-;;; COMPUTE-ARGUMENTS  --  Internal
-;;;
-;;;    Return a vector to be used as the COMPILED-DEBUG-FUNCTION-ARGUMENTS for
-;;; Fun.  If fun is the MAIN-ENTRY for an optional dispatch, then look at the
-;;; ARGLIST to determine the syntax, otherwise pretend all arguments are fixed.
-;;;
-;;; ### This assumption breaks down in EPs other than the main-entry, since
-;;; they may or may not have supplied-p vars, etc.
-;;;
-(defun compute-arguments (fun var-locs)
-  (declare (type clambda fun) (type hash-table var-locs))
-  (collect ((res))
-    (let ((od (lambda-optional-dispatch fun)))
-      (if (and od (eq (optional-dispatch-main-entry od) fun))
-	  (let ((actual-vars (lambda-vars fun)))
-	    (dolist (arg (optional-dispatch-arglist od))
-	      (let ((info (lambda-var-arg-info arg))
-		    (actual (pop actual-vars)))
-		(cond (info
-		       (case (arg-info-kind info)
-			 (:keyword
-			  (res (arg-info-keyword info)))
-			 (:rest
-			  (res 'rest-arg)))
-		       (res (debug-location-for actual var-locs))
-		       (when (arg-info-supplied-p info)
-			 (res 'supplied-p)
-			 (res (debug-location-for (pop actual-vars) var-locs))))
-		      (t
-		       (res (debug-location-for actual var-locs)))))))
-	  (dolist (var (lambda-vars fun))
-	    (res (debug-location-for var var-locs)))))
-
-    (coerce-to-smallest-eltype (res))))
-
-
-;;; COMPUTE-DEBUG-RETURNS  --  Internal
-;;;
-;;;    Return a vector of SC offsets describing Fun's return locations.  (Must
-;;; be known values return...)
-;;;
-(defun compute-debug-returns (fun)
-  (coerce-to-smallest-eltype 
-   (mapcar #'(lambda (loc)
-	       (tn-sc-offset loc))
-	   (return-info-locations (tail-set-info (lambda-tail-set fun))))))
-
-
-;;; DEBUG-INFO-FOR-COMPONENT  --  Interface
-;;;
-;;; Return a debug-info structure describing component.  This has to be called
-;;; at some particular time (after assembly) so that source map information is
-;;; available.
-;;; 
-(defun debug-info-for-component (component assem-nodes count)
-  (declare (type component component) (simple-vector assem-nodes)
-	   (type index count))
-  (let ((level (cookie-debug *default-cookie*))
-	(res (make-compiled-debug-info :name (component-name component)
-				       :package (package-name *package*))))
-    (collect ((dfuns))
-      (let ((var-locs (make-hash-table :test #'eq)))
-	(dolist (fun (component-lambdas component))
-	  (clrhash var-locs)
-	  (let* ((2env (environment-info (lambda-environment fun)))
-		 (dfun (make-compiled-debug-function
-			:name (cond ((leaf-name fun))
-				    ((let ((ef (functional-entry-function fun)))
-				       (and ef (leaf-name ef))))
-				    (t
-				     (component-name component)))
-			:kind (functional-kind fun)
-			:return-pc (tn-sc-offset
-				    (ir2-environment-return-pc 2env))
-			:old-cont (tn-sc-offset
-				   (ir2-environment-old-cont 2env))
-			;; Not right...
-			:start-pc 0)))
-	    
-	    (when (>= level 1)
-	      (setf (compiled-debug-function-variables dfun)
-		    (compute-variables fun level var-locs)))
-
-	    (unless (= level 0)
-	      (setf (compiled-debug-function-arguments dfun)
-		    (compute-arguments fun var-locs)))
-
-	    (when (>= level 2)
-	      (multiple-value-bind (blocks tlf-num)
-				   (compute-debug-blocks fun var-locs)
-		(setf (compiled-debug-function-tlf-number dfun) tlf-num)
-		(setf (compiled-debug-function-blocks dfun) blocks)))
-
-	    (let ((tails (lambda-tail-set fun)))
-	      (when tails
-		(let ((info (tail-set-info tails)))
-		  (cond ((eq (return-info-kind info) :unknown)
-			 (setf (compiled-debug-function-returns dfun)
-			       :standard))
-			((/= level 0)
-			 (setf (compiled-debug-function-returns dfun)
-			       (compute-debug-returns fun)))))))
-
-	    (dfuns (cons (label-location
-			  (block-label
-			   (node-block
-			    (lambda-bind fun))))
-			 dfun)))))
-
-      (let* ((sorted (sort (dfuns) #'< :key #'car))
-	     (len (1- (* (length sorted) 2)))
-	     (funs-vec (make-array len)))
-	(do ((i -1 (+ i 2))
-	     (sorted sorted (cdr sorted)))
-	    ((= i len))
-	  (let ((dfun (car sorted)))
-	    (unless (minusp i)
-	      (setf (svref funs-vec i) (car dfun)))
-	    (setf (svref funs-vec (1+ i)) (cdr dfun))))
-	(setf (compiled-debug-info-function-map res) funs-vec)))
-
-    res))
diff --git a/compiler/debug.lisp b/compiler/debug.lisp
deleted file mode 100644
index bd9a387757ce2f84a588dbd4558cd0d93e5eb19e..0000000000000000000000000000000000000000
--- a/compiler/debug.lisp
+++ /dev/null
@@ -1,1297 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    Utilities for debugging the compiler.  Currently contains only stuff for
-;;; checking the consistency of the IR1.
-;;; 
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-(defvar *args* ()
-  "This variable is bound to the format arguments when an error is signalled
-  by Barf or Burp.")
-
-;;; Barf  --  Interface
-;;;
-;;;    A definite inconsistency has been detected.  Signal an error with
-;;; *args* bound to the list of the format args.
-;;;
-(proclaim '(function barf (string &rest t) nil))
-(defun barf (string &rest *args*)
-  (apply #'cerror "Skip this error." string *args*))
-
-(defvar *burp-action* :warn
-  "Action taken by the Burp function when a possible compiler bug is detected.
-  One of :Warn, :Error or :None.")
-
-(proclaim '(type (member :warn :error :none) *burp-action*))
-
-;;; Burp  --  Interface
-;;;
-;;;    Called when something funny but possibly correct is noticed.  Otherwise
-;;; similar to Barf.
-;;;
-(proclaim '(function burp (string &rest t) nil))
-(defun burp (string &rest *args*)
-  (ecase *burp-action*
-    (:warn (apply #'warn string *args*))
-    (:error (apply #'cerror "press on anyway." string *args*))
-    (:none)))
-
-
-;;; *Seen-Blocks* is a hashtable with true values for all blocks which appear
-;;; in the DFO for one of the specified components.
-;;;
-(defvar *seen-blocks* (make-hash-table :test #'eq))
-
-;;; *Seen-Functions* is similar, but records all the lambdas we reached by
-;;; recursing on top-level functions.
-;;;
-(defvar *seen-functions* (make-hash-table :test #'eq))
-
-
-;;; Check-Node-Reached  --  Internal
-;;;
-;;;    Barf if Node is in a block which wasn't reached during the graph
-;;; walk.
-;;;
-(proclaim '(function check-node-reached (node) void))
-(defun check-node-reached (node)
-  (unless (gethash (continuation-block (node-prev node)) *seen-blocks*)
-    (barf "~S was not reached." node)))
-
-
-;;; Check-IR1-Consistency  --  Interface
-;;;
-;;;    Check everything that we can think of for consistency.  When a definite
-;;; inconsistency is detected, we Barf.  Possible problems just cause us to
-;;; Burp.  Our argument is a list of components, but we also look at the
-;;; *free-variables*, *free-functions* and *constants*.
-;;;
-;;;    First we do a pre-pass which finds all the blocks and lambdas, testing
-;;; that they are linked together properly and entering them in hashtables.
-;;; Next, we iterate over the blocks again, looking at the actual code and
-;;; control flow.  Finally, we scan the global leaf hashtables, looking for
-;;; lossage.
-;;;
-(proclaim '(function check-ir1-consistency (list) void))
-(defun check-ir1-consistency (components)
-  (clrhash *seen-blocks*)
-  (clrhash *seen-functions*)
-  (dolist (c components)
-    (let* ((head (component-head c))
-	   (tail (component-tail c)))
-      (unless (and (null (block-pred head)) (null (block-succ tail)))
-	(barf "~S malformed." c))
-
-      (do ((prev nil block)
-	   (block head (block-next block)))
-	  ((null block)
-	   (unless (eq prev tail)
-	     (barf "Wrong Tail for DFO, ~S in ~S." prev c)))
-	(setf (gethash block *seen-blocks*) t)
-	(unless (eq (block-prev block) prev)
-	  (barf "Bad Prev for ~S, should be ~S." block prev))
-	(unless (or (eq block tail)
-		    (eq (block-component block) c))
-	  (barf "~S is not in ~S." block c)))
-#|
-      (when (or (loop-blocks c) (loop-inferiors c))
-	(do-blocks (block c :both)
-	  (setf (block-flag block) nil))
-	(check-loop-consistency c nil)
-	(do-blocks (block c :both)
-	  (unless (block-flag block)
-	    (barf "~S was not in any loop." block))))
-|#
-    ))
-
-  (check-function-consistency components)
-
-  (dolist (c components)
-    (do ((block (block-next (component-head c)) (block-next block)))
-	((null (block-next block)))
-      (check-block-consistency block)))
-
-      
-  (maphash #'(lambda (k v)
-	       (declare (ignore k))
-	       (unless (or (constant-p v)
-			   (and (global-var-p v)
-				(member (global-var-kind v)
-					'(:global :special :constant))))
-		 (barf "Strange *free-variables* entry: ~S." v))
-	       (dolist (n (leaf-refs v))
-		 (check-node-reached n))
-	       (when (basic-var-p v)
-		 (dolist (n (basic-var-sets v))
-		   (check-node-reached n))))
-	   *free-variables*)
-
-  (maphash #'(lambda (k v)
-	       (declare (ignore k))
-	       (unless (constant-p v)
-		 (barf "Strange *constants* entry: ~S." v))
-	       (dolist (n (leaf-refs v))
-		 (check-node-reached n)))
-	   *constants*)
-
-  (maphash #'(lambda (k v)
-	       (declare (ignore k))
-	       (unless (or (functional-p v)
-			   (and (global-var-p v)
-				(eq (global-var-kind v) :global-function)))
-		 (barf "Strange *free-functions* entry: ~S." v))
-	       (dolist (n (leaf-refs v))
-		 (check-node-reached n)))
-	   *free-functions*)
-  (clrhash *seen-functions*)
-  (clrhash *seen-blocks*)
-  (values))
-
-
-;;;; Function consistency checking:
-
-;;; Observe-Functional  --  Internal
-;;;
-(defun observe-functional (x)
-  (declare (type functional x))
-  (when (gethash x *seen-functions*)
-    (barf "~S seen more than once." x))
-  (unless (eq (functional-kind x) :deleted)
-    (setf (gethash x *seen-functions*) t)))
-
-
-;;; Check-Function-Reached  --  Internal
-;;;
-;;;    Check that the specified function has been seen. 
-;;;
-(defun check-function-reached (fun where)
-  (declare (type functional fun))
-  (unless (gethash fun *seen-functions*)
-    (barf "Unseen function ~S in ~S." fun where)))
-
-
-;;; Check-Function-Stuff  --  Internal
-;;;
-;;;    In a lambda, check that the associated nodes are in seen blocks.  In an
-;;; optional dispatch, check that the entry points were seen.  If the function
-;;; is deleted, ignore it.
-;;;
-(defun check-function-stuff (functional)
-  (ecase (functional-kind functional)
-    (:external
-     (let ((fun (functional-entry-function functional)))
-       (check-function-reached fun functional)
-       (when (functional-kind fun)
-	 (barf "Function for XEP ~S has kind." functional))
-       (unless (eq (functional-entry-function fun) functional)
-	 (barf "Bad back-pointer in function for XEP ~S." functional))))
-    ((:let :mv-let)
-     (check-function-reached (lambda-home functional) functional)
-     (when (functional-entry-function functional)
-       (barf "Let ~S has entry function." functional))
-     (unless (member functional (lambda-lets (lambda-home functional)))
-       (barf "Let ~S not in Lets for Home." functional))
-     (when (rest (leaf-refs functional))
-       (barf "Let ~S has multiple refernces." functional))
-     (when (lambda-lets functional)
-       (barf "Lets in a Let: ~S." functional)))
-    (:optional
-     (when (functional-entry-function functional)
-       (barf ":Optional ~S has an ENTRY-FUNCTION." functional))
-     (let ((ef (lambda-optional-dispatch functional)))
-       (check-function-reached ef functional)
-       (unless (or (member functional (optional-dispatch-entry-points ef))
-		   (eq functional (optional-dispatch-more-entry ef))
-		   (eq functional (optional-dispatch-main-entry ef)))
-	 (barf ":Optional ~S not an e-p for its OPTIONAL-DISPATCH ~S." 
-	       functional ef))))
-    (:top-level
-     (unless (eq (functional-entry-function functional) functional)
-       (barf "Entry-Function is ~S isn't a self-pointer." functional)))
-    ((nil :escape :cleanup)
-     (let ((ef (functional-entry-function functional)))
-       (when ef
-	 (check-function-reached ef functional)
-	 (unless (eq (functional-kind ef) :external)
-	   (barf "Entry-Function in ~S isn't an XEP: ~S." functional ef)))))
-    (:deleted
-     (return-from check-function-stuff)))
-
-  (case (functional-kind functional)
-    ((nil :optional :external :top-level :escape :cleanup)
-     (when (lambda-p functional)
-       (dolist (fun (lambda-lets functional))
-	 (unless (eq (lambda-home fun) functional)
-	   (barf "Home in ~S not ~S." fun functional))
-	 (check-function-reached fun functional))
-       (when (lambda-cleanup functional)
-	 (barf "Non-let has cleanup: ~S." functional))
-       (unless (eq (lambda-home functional) functional)
-	 (barf "Home not self-pointer in ~S." functional)))))
-       
-  (etypecase functional
-    (clambda
-     (when (lambda-bind functional)
-       (check-node-reached (lambda-bind functional)))
-     (when (lambda-return functional)
-       (check-node-reached (lambda-return functional)))
-     
-     (dolist (var (lambda-vars functional))
-       (dolist (ref (leaf-refs var))
-	 (check-node-reached ref))
-       (dolist (set (basic-var-sets var))
-	 (check-node-reached set))
-       (unless (eq (lambda-var-home var) functional)
-	 (barf "HOME in ~S should be ~S." var functional))))
-    (optional-dispatch
-     (dolist (ep (optional-dispatch-entry-points functional))
-       (check-function-reached ep functional))
-     (let ((more (optional-dispatch-more-entry functional)))
-       (when more (check-function-reached more functional)))
-     (check-function-reached (optional-dispatch-main-entry functional)
-			     functional)))))
-
-
-;;; Check-Function-Consistency  --  Internal
-;;;
-(defun check-function-consistency (components)
-  (dolist (c components)
-    (dolist (fun (component-new-functions c))
-      (observe-functional fun))
-    (dolist (fun (component-lambdas c))
-      (when (eq (functional-kind fun) :external)
-	(let ((ef (functional-entry-function fun)))
-	  (when (optional-dispatch-p ef)
-	    (observe-functional ef))))
-      (observe-functional fun)
-      (dolist (let (lambda-lets fun))
-	(observe-functional let))))
-
-  (dolist (c components)
-    (dolist (fun (component-new-functions c))
-      (check-function-stuff fun))
-    (dolist (fun (component-lambdas c))
-      (when (eq (functional-kind fun) :deleted)
-	(barf "Deleted lambda ~S in Lambdas for ~S." fun c))
-      (check-function-stuff fun)
-      (dolist (let (lambda-lets fun))
-	(check-function-stuff let)))))
-
-
-;;;; Loop consistency checking:
-
-#|
-;;; Check-Loop-Consistency  --  Internal
-;;;
-;;;    Descend through the loop nesting and check that the tree is well-formed
-;;; and that all blocks in the loops are known blocks.  We also mark each block
-;;; that we see so that we can do a check later to detect blocks that weren't
-;;; in any loop.
-;;;
-(proclaim '(function check-loop-consistency (loop (or loop null)) void))
-(defun check-loop-consistency (loop superior)
-  (unless (eq (loop-superior loop) superior)
-    (barf "Wrong superior in ~S, should be ~S." loop superior))
-  (when (and superior
-	     (/= (loop-depth loop) (1+ (loop-depth superior))))
-    (barf "Wrong depth in ~S." loop))
-
-  (dolist (tail (loop-tail loop))
-    (check-loop-block tail loop))
-  (dolist (exit (loop-exits loop))
-    (check-loop-block exit loop))
-  (check-loop-block (loop-head loop) loop)
-  (unless (eq (block-loop (loop-head loop)) loop)
-    (barf "Head of ~S is not directly in the loop." loop))
-
-  (do ((block (loop-blocks loop) (block-loop-next block)))
-      ((null block))
-    (setf (block-flag block) t)
-    (unless (gethash block *seen-blocks*)
-      (barf "Unseen block ~S in Blocks for ~S." block loop))
-    (unless (eq (block-loop block) loop)
-      (barf "Wrong Loop in ~S, should be ~S." block loop)))
-
-  (dolist (inferior (loop-inferiors loop))
-    (check-loop-consistency inferior loop)))
-
-
-;;; Check-Loop-Block  --  Internal
-;;;
-;;;    Check that Block is either in Loop or an inferior.
-;;;
-(proclaim '(function check-loop-block (block loop) void))
-(defun check-loop-block (block loop)
-  (unless (gethash block *seen-blocks*)
-    (barf "Unseen block ~S in loop info for ~S." block loop))
-  (labels ((walk (l)
-	     (if (eq (block-loop block) l)
-		 t
-		 (dolist (inferior (loop-inferiors l) nil)
-		   (when (walk inferior) (return t))))))
-    (unless (walk loop)
-      (barf "~S in loop info for ~S but not in the loop." block loop))))
-
-|#
-
-
-;;; Check-Block-Consistency  --  Internal
-;;;
-;;;    Check a block for consistency at the general flow-graph level, and call
-;;; Check-Node-Consistency on each node to locally check for semantic
-;;; consistency.
-;;;
-(proclaim '(function check-block-consistency (cblock) void))
-(defun check-block-consistency (block)
-
-  (dolist (pred (block-pred block))
-    (unless (gethash pred *seen-blocks*)
-      (barf "Unseen predecessor ~S in ~S." pred block))
-    (unless (member block (block-succ pred))
-      (barf "Bad predecessor link ~S in ~S." pred block)))
-
-  (let ((fun (block-lambda block)))
-    (when (eq (functional-kind fun) :deleted)
-      (return-from check-block-consistency nil))
-    (check-function-reached fun block))
-
-  (let ((this-cont (block-start block))
-	(last (block-last block)))
-    (when (not this-cont)
-      (barf "~S has no START." block))
-    (when (not last)
-      (barf "~S has no LAST." block))
-    (unless (eq (continuation-kind this-cont) :block-start)
-      (barf "Start of ~S has wrong kind." block))
-
-    (let ((use (continuation-use this-cont))
-	  (uses (block-start-uses block)))
-      (when (and (null use) (= (length uses) 1))
-	(barf "~S has unique use, but no USE." this-cont))
-      (dolist (node uses)
-	(unless (eq (node-cont node) this-cont)
-	  (barf "Use ~S for START in ~S has wrong CONT." node block))
-	(check-node-reached node)))
-
-    (let* ((last-cont (node-cont last))
-	   (cont-block (continuation-block last-cont))
-	   (dest (continuation-dest last-cont)))
-      (ecase (continuation-kind last-cont)
-	(:deleted)
-	(:deleted-block-start
-	 (let ((dest (continuation-dest last-cont)))
-	   (when dest
-	     (check-node-reached dest)))
-	 (unless (member last (block-start-uses cont-block))
-	   (barf "Last in ~S is missing from uses of it's Cont." block)))
-	(:block-start
-	 (check-node-reached (continuation-next last-cont))
-	 (unless (member last (block-start-uses cont-block))
-	   (barf "Last in ~S is missing from uses of it's Cont." block)))
-	(:inside-block
-	 (unless (eq cont-block block)
-	   (barf "Cont of Last in ~S is in a different block." block))
-	 (unless (eq (continuation-use last-cont) last)
-	   (barf "Use is not Last in Cont of Last in ~S." block))
-	 (when (continuation-next last-cont)
-	   (barf "Cont of Last has a Next in ~S." block))))
-
-      (when dest
-	(check-node-reached dest)))
-
-    (loop	
-      (unless (eq (continuation-block this-cont) block)
-	(barf "BLOCK in ~S should be ~S." this-cont block))
-      
-      (let ((dest (continuation-dest this-cont)))
-	(when dest
-	  (check-node-reached dest)))
-      
-      (let ((node (continuation-next this-cont)))
-	(unless (node-p node)
-	  (barf "~S has strange next." this-cont))
-	(unless (eq (node-prev node) this-cont)
-	  (barf "PREV in ~S should be ~S." node this-cont))
-	
-	(check-node-consistency node)
-	
-	(let ((cont (node-cont node)))
-	  (when (not cont)
-	    (barf "~S has no CONT." node))
-	  (when (eq node last) (return))
-	  (unless (eq (continuation-kind cont) :inside-block)
-	    (barf "Interior continuation ~S in ~S has wrong kind." cont block))
-	  (unless (continuation-next cont)
-	    (barf "~S has no NEXT." cont))
-	  (unless (eq (continuation-use cont) node)
-	    (barf "USE in ~S should be ~S." cont node))
-	  (setq this-cont cont))))
-	
-    (check-block-successors block)))
-
-
-;;; Check-Block-Successors  --  Internal
-;;;
-;;;    Check that Block is properly terminated.  Each successor must be
-;;; accounted for by the type of the last node.
-;;;
-(proclaim '(function check-block-successors (cblock) void))
-(defun check-block-successors (block)
-  (let ((last (block-last block))
-	(succ (block-succ block)))
-
-    (let ((comp (block-component block)))
-      (dolist (b succ)
-	(unless (gethash b *seen-blocks*)
-	  (barf "Unseen successor ~S in ~S." b block))
-	(unless (member block (block-pred b))
-	  (barf "Bad successor link ~S in ~S." b block))
-	(unless (eq (block-component b) comp)
-	  (barf "Successor ~S in ~S is in a different component." b block))))
-    
-    (typecase last
-      (cif
-       (unless (<= 1 (length succ) 2)
-	 (barf "~S ends in an IF, but doesn't have one or two succesors."
-	       block))
-       (unless (member (if-consequent last) succ) 
-	 (barf "CONSEQUENT for ~S isn't in SUCC for ~S." last block))
-       (unless (member (if-alternative last) succ)
-	 (barf "ALTERNATIVE for ~S isn't in SUCC for ~S." last block)))
-      (creturn
-       (unless (and (= (length succ) 1)
-		    (eq (first succ)
-			(component-tail (block-component block))))
-	 (barf "Strange successors for RETURN in ~S." block)))
-      (exit
-       (unless (<= (length succ) 1)
-	 (barf "EXIT node has strange number of successors: ~S." last)))
-      (t
-       (unless (or (= (length succ) 1) (node-tail-p last)
-		   (and (block-delete-p block) (null succ)))
-	 (barf "~S ends in normal node, but doesn't have one successor."
-	       block))))))
-
-
-;;;; Node consistency checking:
-
-;;; Check-Dest  --  Internal
-;;;
-;;;    Check that the Dest for Cont is the specified Node.  We also mark the
-;;; block Cont is in as Seen.
-;;;
-(proclaim '(function check-dest (continuation node) void))
-(defun check-dest (cont node)
-  (let ((kind (continuation-kind cont)))
-    (ecase kind
-      (:deleted
-       (unless (block-delete-p (node-block node))
-	 (barf "DEST ~S of deleted continuation ~S is not DELETE-P."
-	       cont node)))
-      (:deleted-block-start
-       (unless (eq (continuation-dest cont) node)
-	 (barf "DEST for ~S should be ~S." cont node)))
-      ((:inside-block :block-start)
-       (unless (gethash (continuation-block cont) *seen-blocks*)
-	 (barf "~S receives ~S, which is in an unknown block." node cont))
-       (unless (eq (continuation-dest cont) node)
-	 (barf "DEST for ~S should be ~S." cont node))))))
-
-
-;;; Check-Node-Consistency  --  Internal
-;;;
-;;;    This function deals with checking for consistency the type-dependent
-;;; information in a node.
-;;;
-(defun check-node-consistency (node)
-  (declare (type node node))
-  (unless (or (node-source node)
-	      (and (ref-p node)
-		   (not (leaf-name (ref-leaf node)))))
-    (burp "~S has no SOURCE." node))
-
-  (etypecase node
-    (ref
-     (let ((leaf (ref-leaf node)))
-       (when (functional-p leaf)
-	 (check-function-reached leaf node))))
-    (basic-combination
-     (check-dest (basic-combination-fun node) node)
-     (dolist (arg (basic-combination-args node))
-       (cond
-	(arg (check-dest arg node))
-	((not (and (eq (basic-combination-kind node) :local)
-		   (combination-p node)))
-	 (barf "Flushed arg not in local call: ~S." node))
-	(t
-	 (let ((fun (ref-leaf (continuation-use
-			       (basic-combination-fun node)))))
-	   (when (leaf-refs (elt (lambda-vars fun)
-				 (position arg (basic-combination-args node))))
-	     (barf "Flushed arg for referenced var in ~S." node)))))))
-    (cif
-     (check-dest (if-test node) node)
-     (unless (eq (block-last (node-block node)) node)
-       (barf "IF not at block end: ~S" node)))
-    (cset
-     (check-dest (set-value node) node))
-    (bind
-     (check-function-reached (bind-lambda node) node))
-    (creturn
-     (check-function-reached (return-lambda node) node)
-     (check-dest (return-result node) node)
-     (unless (eq (block-last (node-block node)) node)
-       (barf "RETURN not at block end: ~S" node)))
-    (entry
-     (unless (member node
-		     (lambda-entries
-		      (lambda-home
-		       (block-lambda (node-block node)))))
-       (barf "~S not in Entries for its home lambda." node))
-     (dolist (exit (entry-exits node))
-       (unless (eq (continuation-kind exit) :deleted)
-	 (do-uses (node exit)
-	   (check-node-reached node)))))
-    (exit
-     (let ((entry (exit-entry node))
-	   (value (exit-value node)))
-       (cond (entry
-	      (check-node-reached entry)
-	      (unless (member (node-cont node) (entry-exits entry))
-		(barf "CONT for ~S not in its ENTRY's EXITS." node))
-	      (when value
-		(check-dest value node)))
-	     (t
-	      (when value
-		(barf "~S has VALUE but no ENTRY." node)))))))
-       
-  (undefined-value))
-
-
-;;;; IR2 consistency checking:
-
-
-;;; Check-TN-Refs  --  Internal
-;;;
-;;;    Check for some kind of consistency in some Refs linked together by
-;;; TN-Ref-Across.  VOP is the VOP that the references are in.  Write-P is the
-;;; value of Write-P that should be present.  Count is the minimum number of
-;;; operands expected.  If More-P is true, then any larger number will also be
-;;; accepted.  What is a string describing the kind of operand in error
-;;; messages.
-;;;
-(defun check-tn-refs (refs vop write-p count more-p what)
-  (let ((vop-refs (vop-refs vop)))
-    (do ((ref refs (tn-ref-across ref))
-	 (num 0 (1+ num)))
-	((null ref)
-	 (when (< num count)
-	   (barf "Should be at least ~D ~A in ~S, but are only ~D."
-		 count what vop num))
-	 (when (and (not more-p) (> num count))
-	   (barf "Should be ~D ~A in ~S, but are ~D."
-		 count what vop num)))
-      (unless (eq (tn-ref-vop ref) vop)
-	(barf "VOP is ~S isn't ~S." ref vop))
-      (unless (eq (tn-ref-write-p ref) write-p)
-	(barf "Write-P in ~S isn't ~S." vop write-p))
-      (unless (find-in #'tn-ref-next-ref ref vop-refs)
-	(barf "~S not found in Refs for ~S." ref vop))
-      (unless (find-in #'tn-ref-next ref
-		       (if (tn-ref-write-p ref)
-			   (tn-writes (tn-ref-tn ref))
-			   (tn-reads (tn-ref-tn ref))))
-	(barf "~S not found in reads/writes for its TN." ref))
-
-      (let ((target (tn-ref-target ref)))
-	(when target
-	  (unless (eq (tn-ref-write-p target) (not (tn-ref-write-p ref)))
-	    (barf "Target for ~S isn't complementary write-p." ref))
-	  (unless (find-in #'tn-ref-next-ref target vop-refs)
-	    (barf "Target for ~S isn't in Refs for ~S." ref vop)))))))
-
-
-;;; Check-VOP-Refs  --  Internal
-;;;
-;;;    Verify the sanity of the VOP-Refs slot in VOP.  This involves checking
-;;; that each referenced TN appears as an argument, result or temp, and also
-;;; basic checks for the plausibility of the specified ordering of the refs.
-;;; 
-(defun check-vop-refs (vop)
-  (declare (type vop vop))
-  (let ((saw-arg nil))
-    (do ((ref (vop-refs vop) (tn-ref-next-ref ref)))
-	((null ref))
-      (cond
-       ((find-in #'tn-ref-across ref (vop-args vop))
-	(setq saw-arg t))
-       ((find-in #'tn-ref-across ref (vop-results vop))
-	(when saw-arg
-	  (barf "Result ~S after arg in refs for ~S." ref vop)))
-       ((not (eq (tn-ref-vop ref) vop))
-	(barf "VOP in ~S isn't ~S." ref vop))
-       ((find-in #'tn-ref-across ref (vop-temps vop)))
-       ((tn-ref-write-p ref)
-	(barf "Stray ref that isn't a read: ~S." ref))
-       (t
-	(let* ((tn (tn-ref-tn ref))
-	       (temp (find-in #'tn-ref-across tn (vop-temps vop)
-			      :key #'tn-ref-tn)))
-	  (unless temp
-	    (barf "Stray ref with no corresponding temp write: ~S." ref))
-	  (unless (find-in #'tn-ref-next-ref temp (tn-ref-next-ref ref))
-	    (barf "Read is after write for temp ~S in refs of ~S."
-		  tn vop)))))))
-  (undefined-value))
-
-
-;;; Check-IR2-Block-Consistency  --  Internal
-;;;
-;;;    Check the basic sanity of the VOP linkage, then call some other
-;;; functions to check on the TN-Refs.  We grab some info out of the VOP-Info
-;;; to tell us what to expect.
-;;; [### Check that operand type restrictions are met?]
-;;;
-(defun check-ir2-block-consistency (2block)
-  (declare (type ir2-block 2block))
-  (do ((vop (ir2-block-start-vop 2block)
-	    (vop-next vop))
-       (prev nil vop))
-      ((null vop)
-       (unless (eq prev (ir2-block-last-vop 2block))
-	 (barf "Last VOP in ~S shoule be ~S." 2block prev)))
-    (unless (eq (vop-prev vop) prev)
-      (barf "Prev in ~S should be ~S." vop prev))
-
-    (unless (eq (vop-block vop) 2block)
-      (barf "Block in ~S should be ~S." vop 2block))
-
-    (check-vop-refs vop)
-
-    (let* ((info (vop-info vop))
-	   (atypes (template-arg-types info))
-	   (rtypes (template-result-types info)))
-      (check-tn-refs (vop-args vop) vop nil (length atypes)
-		     (template-more-args-type info) "args")
-      (check-tn-refs (vop-results vop) vop t
-		     (if (eq rtypes :conditional) 0 (length rtypes))
-		     (template-more-results-type info) "results")
-      (check-tn-refs (vop-temps vop) vop t 0 t "temps")
-      (unless (= (length (vop-codegen-info vop))
-		 (template-info-arg-count info))
-	(barf "Wrong number of codegen info args in ~S." vop))))
-  (undefined-value))
-
-
-;;; Check-IR2-Consistency  --  Interface
-;;;
-;;;    Check stuff about the IR2 representation of Component.  This assumes the
-;;; sanity of the basic flow graph.
-;;;
-;;; [### Also grovel global TN data structures?  Assume pack not
-;;; done yet?  Have separate check-tn-consistency for pre-pack and
-;;; check-pack-consistency for post-pack?]
-;;;
-(defun check-ir2-consistency (component)
-  (declare (type component component))
-  (do-ir2-blocks (block component)
-    (check-ir2-block-consistency block))
-  (undefined-value))
-
-
-;;;; Lifetime analysis checking:
-
-;;; Pre-Pack-TN-Stats  --  Interface
-;;;
-;;;    Dump some info about how many TNs there, and what the conflicts data
-;;; structures are like.
-;;;
-(defun pre-pack-tn-stats (component &optional (stream *compiler-error-output*))
-  (declare (type component component))
-  (let ((wired 0)
-	(global 0)
-	(local 0)
-	(confs 0)
-	(unused 0)
-	(const 0)
-	(temps 0)
-	(environment 0))
-    (do-packed-tns (tn component)
-      (let ((reads (tn-reads tn))
-	    (writes (tn-writes tn)))
-	(when (and reads writes
-		   (not (tn-ref-next reads)) (not (tn-ref-next writes))
-		   (eq (tn-ref-vop reads) (tn-ref-vop writes)))
-	  (incf temps)))
-      (when (tn-offset tn)
-	(incf wired))
-      (unless (or (tn-reads tn) (tn-writes tn))
-	(incf unused))
-      (cond ((eq (tn-kind tn) :environment)
-	     (incf environment))
-	    ((tn-global-conflicts tn)
-	     (incf global)
-	     (do ((conf (tn-global-conflicts tn)
-			(global-conflicts-tn-next conf)))
-		 ((null conf))
-	       (incf confs)))
-	    (t
-	     (incf local))))
-
-    (do ((tn (ir2-component-constant-tns (component-info component))
-	     (tn-next tn)))
-	((null tn))
-      (incf const))
-
-    (format stream
-     "~%TNs: ~D local, ~D temps, ~D constant, ~D environment, ~D global.~@
-       Wired: ~D, Unused: ~D.  ~D block~:P, ~D global conflict~:P.~%"
-       local temps const environment global wired unused
-       (1+ (ir2-block-number
-	    (block-info (block-next (component-head component)))))
-       confs))
-  (undefined-value))
-
-
-;;; Check-More-TN-Entry  --  Internal
-;;;
-;;;    If the entry in Local-TNs for TN in Block is :More, then do some checks
-;;; for the validity of the usage.
-;;;
-(defun check-more-tn-entry (tn block)
-  (let* ((vop (ir2-block-start-vop block))
-	 (info (vop-info vop)))
-    (macrolet ((frob (more-p ops)
-		 `(and (,more-p info)
-		       (find-in #'tn-ref-across tn (,ops vop)
-				:key #'tn-ref-tn))))
-      (unless (and (eq vop (ir2-block-last-vop block))
-		   (or (frob template-more-args-type vop-args)
-		       (frob template-more-results-type vop-results)))
-	(barf "Strange :More LTN entry for ~S in ~S." tn block))))
-  (undefined-value))
-
-
-;;; Check-TN-Conflicts  --  Internal
-;;;
-(defun check-tn-conflicts (component)
-  (do-packed-tns (tn component)
-    (unless (or (tn-reads tn) (tn-writes tn))
-      (barf "No references to ~S." tn))
-
-    (let ((conf (tn-global-conflicts tn))
-	  (kind (tn-kind tn)))
-      (cond
-       ((eq kind :environment)
-	(let ((env (tn-environment tn)))
-	  (macrolet ((frob (refs)
-		       `(do ((ref ,refs (tn-ref-next ref)))
-			    ((null ref))
-			  (unless (eq (environment-info
-				       (lambda-environment
-					(block-lambda
-					 (ir2-block-block
-					  (vop-block (tn-ref-vop ref))))))
-				      env)
-			    (barf "~S not in TN-Environment for ~S." ref
-				  tn)))))
-	    (frob (tn-reads tn))
-	    (frob (tn-writes tn)))
-	  (unless (member tn (ir2-environment-live-tns env))
-	    (barf "~S not in Live-TNs for ~S." tn env))
-	  (when (or (tn-local tn) (tn-global-conflicts tn))
-	    (barf ":Environment TN ~S has Local or Global-Conflicts." tn))))
-       (conf
-	(do ((conf conf (global-conflicts-tn-next conf))
-	     (prev nil conf))
-	    ((null conf))
-	  (unless (eq (global-conflicts-tn conf) tn)
-	    (barf "TN in ~S should be ~S." conf tn))
-
-	  (unless (eq (global-conflicts-kind conf) :live)
-	    (let* ((block (global-conflicts-block conf))
-		   (ltn (svref (ir2-block-local-tns block)
-			       (global-conflicts-number conf))))
-	      (cond ((eq ltn tn))
-		    ((eq ltn :more) (check-more-tn-entry tn block))
-		    (t
-		     (barf "~S wrong in LTN map for ~S." conf tn)))))
-
-	  (when prev
-	    (unless (> (ir2-block-number (global-conflicts-block conf))
-		       (ir2-block-number (global-conflicts-block prev)))
-	      (barf "~S and ~S out of order." prev conf)))))
-       ((eq (tn-kind tn) :constant))
-       (t
-	(let ((local (tn-local tn)))
-	  (unless local
-	    (barf "~S has no global conflicts, but isn't local either." tn))
-	  (unless (eq (svref (ir2-block-local-tns local)
-			     (tn-local-number tn))
-		      tn)
-	    (barf "~S wrong in LTN map." tn))
-	  (do ((ref (tn-reads tn) (tn-ref-next ref)))
-	      ((null ref))
-	    (unless (eq (vop-block (tn-ref-vop ref)) local)
-	      (barf "~S has references in blocks other than its Local block."
-		    tn)))
-	  (do ((ref (tn-writes tn) (tn-ref-next ref)))
-	      ((null ref))
-	    (unless (eq (vop-block (tn-ref-vop ref)) local)
-	      (barf "~S has references in blocks other than its Local block."
-		    tn))))))))
-  (undefined-value))
-
-
-;;; Check-Block-Conflicts  --  Internal
-;;;
-(defun check-block-conflicts (component)
-  (do-ir2-blocks (block component)
-    (do ((conf (ir2-block-global-tns block)
-	       (global-conflicts-next conf))
-	 (prev nil conf))
-	((null conf))
-      (when prev
-	(unless (> (tn-number (global-conflicts-tn conf))
-		   (tn-number (global-conflicts-tn prev)))
-	  (barf "~S and ~S out of order in ~S." prev conf block)))
-      
-      (unless (find-in #'global-conflicts-tn-next
-		       conf
-		       (tn-global-conflicts
-			(global-conflicts-tn conf)))
-	(barf "~S missing from global conflicts of its TN." conf)))
-    
-    (let ((map (ir2-block-local-tns block)))
-      (dotimes (i (ir2-block-local-tn-count block))
-	(let ((tn (svref map i)))
-	  (unless (or (eq tn :more)
-		      (null tn)
-		      (tn-global-conflicts tn)
-		      (eq (tn-local tn) block))
-	    (barf "Strange TN ~S in LTN map for ~S." tn block)))))))))
-
-
-;;; Check-Environment-Lifetimes  --  Internal
-;;;
-;;;    All TNs live at the beginning of an environment must be passing
-;;; locations associated with that environment.  We make an exception for wired
-;;; TNs in XEP functions, since we randomly reference wired TNs to access the
-;;; full call passing locations.
-;;;
-(defun check-environment-lifetimes (component)
-  (dolist (fun (component-lambdas component))
-    (let* ((env (lambda-environment fun))
-	   (2env (environment-info env))
-	   (locs (ir2-environment-arg-locs 2env))
-	   (pc (ir2-environment-return-pc-pass 2env))
-	   (cont (ir2-environment-old-cont-pass 2env))
-	   (argp (ir2-environment-argument-pointer 2env))
-	   (2block (block-info
-		    (node-block
-		     (lambda-bind
-		      (environment-function env))))))
-      (do ((conf (ir2-block-global-tns 2block)
-		 (global-conflicts-next conf)))
-	  ((null conf))
-	(let ((tn (global-conflicts-tn conf)))
-	  (unless (or (eq (global-conflicts-kind conf) :write)
-		      (eq (tn-kind tn) :cached-constant)
-		      (member tn locs)
-		      (eq tn pc)
-		      (eq tn cont)
-		      (eq tn argp))
-	    (barf "Strange TN live at head of ~S: ~S." env tn))))))
-  (undefined-value))
-
-
-;;; Check-Life-Consistency  --  Interface
-;;;
-;;;    Check for some basic sanity in the TN conflict data structures, and also
-;;; check that no TNs are unexpectedly live at environment entry.
-;;;
-(defun check-life-consistency (component)
-  (check-tn-conflicts component)
-  (check-block-conflicts component)
-  (check-environment-lifetimes component))
-
-
-;;;; Data structure dumping routines:
-
-;;; Continuation-Number, Number-Continuation, ID-TN, TN-ID  --  Interface
-;;;
-;;;    When we print Continuations and TNs, we assign them small numeric IDs so
-;;; that we can get a handle on anonymous objects given a printout.
-;;;
-(macrolet ((frob (counter vto vfrom fto ffrom)
-	     `(progn
-		(defvar ,vto (make-hash-table :test #'eq))
-		(defvar ,vfrom (make-hash-table :test #'eql))
-		(proclaim '(hash-table ,vto ,vfrom))
-		(defvar ,counter 0)
-		(proclaim '(fixnum ,counter))
-		
-		(defun ,fto (x)
-		  (or (gethash x ,vto)
-		      (let ((num (incf ,counter)))
-			(setf (gethash num ,vfrom) x)
-			(setf (gethash x ,vto) num))))
-		
-		(defun ,ffrom (num)
-		  (values (gethash num ,vfrom))))))
-  (frob *continuation-number*
-        *continuation-numbers* *number-continuations*
-        cont-num num-cont)
-  (frob *tn-id*
-        *tn-ids* *id-tns*
-        tn-id id-tn)
-  (frob *label-id*
-        *id-labels* *label-ids*
-        label-id id-label))
-
-;;; Print-Leaf  --  Internal
-;;;
-;;;    Print out a terse one-line description of a leaf.
-;;;
-(defun print-leaf (leaf &optional (stream *standard-output*))
-  (declare (type leaf leaf) (type stream stream))
-  (etypecase leaf
-    (lambda-var (prin1 (leaf-name leaf) stream))
-    (constant (format stream "'~S" (constant-value leaf)))
-    (global-var
-     (format stream "~S {~A}" (leaf-name leaf) (global-var-kind leaf)))
-    (clambda
-      (format stream "lambda ~S ~S" (leaf-name leaf)
-	      (mapcar #'leaf-name (lambda-vars leaf))))
-    (optional-dispatch
-     (format stream "optional-dispatch ~S" (leaf-name leaf)))))
-
-
-;;; Block-Or-Lose  --  Interface
-;;;
-;;;    Attempt to find a block given some thing that has to do with it.
-;;;
-(proclaim '(function block-or-lose (t) block))
-(defun block-or-lose (thing)
-  (ctypecase thing
-    (cblock thing)
-    (ir2-block (node-block (vop-node (ir2-block-start-vop thing))))
-    (continuation (continuation-block thing))
-    (node (node-block thing))
-    (component (component-head thing))
-#|    (cloop (loop-head thing))|#
-    (integer (continuation-block (num-cont thing)))
-    (functional (node-block (lambda-bind (main-entry thing))))
-    (null (error "Bad thing: ~S." thing))
-    (symbol (block-or-lose (gethash thing *free-functions*)))))
-
-
-;;; Print-Continuation  --  Internal
-;;;
-;;;    Print cN.
-;;;
-(defun print-continuation (cont)
-  (declare (type continuation cont))
-  (format t " c~D" (cont-num cont)))
-  (undefined-value))
-
-
-;;; Print-Nodes  --  Interface
-;;;
-;;;    Print out the nodes in Block in a format oriented toward representing
-;;; what the code does. 
-;;;
-(defun print-nodes (block)
-  (setq block (block-or-lose block))
-  (format t "~%block start c~D" (cont-num (block-start block)))
-
-  (let ((last (block-last block)))
-    (terpri)
-    (do ((cont (block-start block) (node-cont (continuation-next cont))))
-	(())
-      (let ((node (continuation-next cont)))
-	(format t "~3D: " (cont-num (node-cont node)))
-	(etypecase node
-	  (ref (print-leaf (ref-leaf node)))
-	  (basic-combination
-	   (let ((kind (basic-combination-kind node)))
-	     (format t "~(~A ~A~) c~D"
-		     (if (function-info-p kind) "known" kind)
-		     (type-of node)
-		     (cont-num (basic-combination-fun node)))
-	     (dolist (arg (basic-combination-args node))
-	       (if arg
-		   (print-continuation arg)
-		   (format t " <none>")))))
-	  (cset
-	   (write-string "set ")
-	   (print-leaf (set-var node))
-	   (print-continuation (set-value node)))
-	  (cif
-	   (format t "if c~D" (cont-num (if-test node)))
-	   (print-continuation (block-start (if-consequent node)))
-	   (print-continuation (block-start (if-alternative node))))
-	  (bind
-	   (write-string "bind ")
-	   (print-leaf (bind-lambda node)))
-	  (creturn
-	   (format t "return c~D " (cont-num (return-result node)))
-	   (print-leaf (return-lambda node)))
-	  (entry
-	   (format t "entry")
-	   (mapc #'print-continuation (entry-exits node)))
-	  (exit
-	   (let ((value (exit-value node)))
-	     (cond (value
-		    (format t "exit c~D" (cont-num value)))
-		   ((exit-entry node)
-		    (format t "exit <no value>"))
-		   (t
-		    (format t "exit <degenerate>"))))))
-	(terpri)
-	(when (eq node last) (return)))))
-
-  (let ((succ (block-succ block)))
-    (format t "successors~{ c~D~}~%"
-	    (mapcar #'(lambda (x) (cont-num (block-start x))) succ)))
-  (values))
-
-
-;;; Print-TN  --  Internal
-;;;
-;;;    Print a useful representation of a TN.  If the TN has a leaf, then do a
-;;; Print-Leaf on that, otherwise print a generated ID.
-;;;
-(defun print-tn (tn &optional (stream *standard-output*))
-  (declare (type tn tn))
-  (let ((leaf (tn-leaf tn)))
-    (cond (leaf
-	   (print-leaf leaf stream)
-	   (format stream "!~D" (tn-id tn)))
-	  (t
-	   (format stream "t~D" (tn-id tn))))
-    (when (and (tn-sc tn) (tn-offset tn))
-      ;; ### hack...
-      (let ((sb (sb-name (sc-sb (tn-sc tn)))))
-	(if (eq sb 'registers)
-	    (format stream "[~A]"
-		    (svref '#(NL0 A0 NL1 A1 A3 A2 SP L0 L1 L2 L3 L4
-				  BS CONT ENV PC)
-			   (tn-offset tn)))
-	    (format stream "[~A~D]" (char (string sb) 0) (tn-offset tn)))))))
-
-
-;;; Print-Operands  --  Internal
-;;;
-;;;    Print the TN-Refs representing some operands to a VOP, linked by
-;;; TN-Ref-Across.
-;;;
-(defun print-operands (refs)
-  (declare (type (or tn-ref null) refs))
-  (do ((ref refs (tn-ref-across ref)))
-      ((null ref))
-    (format t " ")
-    (print-tn (tn-ref-tn ref))))
-
-
-;;; Print-IR2-Block  --  Internal
-;;;
-;;;    Print the VOPs in the specified IR2 block.
-;;;
-(defun print-ir2-block (block first-p)
-  (declare (type ir2-block block))
-  (cond
-   (first-p
-    (format t "~%IR2 block start c~D~%"
-	    (cont-num (block-start (ir2-block-block block))))
-    (let ((label (ir2-block-%label block)))
-      (when label
-	(format t "L~D:~%" (label-id label)))))
-   (t
-    (format t "<overflow>~%")))
-
-  (do ((vop (ir2-block-start-vop block)
-	    (vop-next vop))
-       (number 0 (1+ number)))
-      ((null vop))
-    (format t "~D: ~A" number (vop-info-name (vop-info vop)))
-    (print-operands (vop-args vop))
-    (when (vop-codegen-info vop)
-      (let ((*print-level* 1)
-	    (*print-length* 3))
-	(format t " {~{~S~^ ~}}" (vop-codegen-info vop))))
-    (when (vop-results vop)
-      (format t " =>")
-      (print-operands (vop-results vop)))
-    (terpri)))
-
-
-;;; Print-VOPs  --  Interface
-;;;
-;;;    Like Print-Nodes, but dumps the IR2 representation of the code in Block.
-;;;
-(defun print-vops (block)
-  (setq block (block-or-lose block))
-  (let ((2block (block-info block)))
-    (print-ir2-block 2block t)
-    (do ((b (ir2-block-next 2block) (ir2-block-next b)))
-	((not (eq (ir2-block-block b) block)))
-      (print-ir2-block b nil)))
-  (values))
-
-
-;;; Print-IR2-Blocks  --  Interface
-;;;
-;;;    Scan the IR2 blocks in emission order.
-;;;
-(defun print-ir2-blocks (thing)
-  (let ((last-block nil))
-    (do-ir2-blocks (block (block-component (block-or-lose thing)))
-      (print-ir2-block block (not (eq block last-block)))
-      (setq last-block block)))
-  (values))
-
-
-;;; Print-Blocks  --  Interface
-;;;
-;;;    Do a Print-Nodes on Block and all blocks reachable from it by successor
-;;; links.
-;;;
-(defun print-blocks (block)
-  (setq block (block-or-lose block))
-  (do-blocks (block (block-component block) :both)
-    (setf (block-flag block) nil))
-  (labels ((walk (block)
-	     (unless (block-flag block)
-	       (setf (block-flag block) t)
-	       (when (block-start block)
-		 (print-nodes block))
-	       (dolist (block (block-succ block))
-		 (walk block)))))
-    (walk block))
-  (values))
-
-
-;;; Print-All-Blocks  --  Interface
-;;;
-;;;    Print all blocks in Block's component in DFO.
-;;;
-(defun print-all-blocks (thing)
-  (do-blocks (block (block-component (block-or-lose thing)))
-    (print-nodes block))
-  (values))
-
-
-(defvar *list-conflicts-table* (make-hash-table :test #'eq))
-
-;;; Add-Always-Live-TNs  --  Internal
-;;;
-;;;    Add all Always-Live TNs in Block to the conflicts.  TN is ignored when
-;;; it appears in the global conflicts.
-;;;
-(defun add-always-live-tns (block tn)
-  (declare (type ir2-block block) (type tn tn))
-  (do ((conf (ir2-block-global-tns block)
-	     (global-conflicts-next conf)))
-      ((null conf))
-    (when (eq (global-conflicts-kind conf) :live)
-      (let ((btn (global-conflicts-tn conf)))
-	(unless (eq btn tn)
-	  (setf (gethash btn *list-conflicts-table*) t)))))
-  (undefined-value))
-
-
-;;; Add-All-Local-TNs  --  Internal
-;;;
-;;;    Add all local TNs in block to the conflicts.
-;;;
-(defun add-all-local-tns (block)
-  (declare (type ir2-block block))
-  (let ((ltns (ir2-block-local-tns block)))
-    (dotimes (i (ir2-block-local-tn-count block))
-      (setf (gethash (svref ltns i) *list-conflicts-table*) t)))
-  (undefined-value))
-
-
-;;; Listify-Conflicts-Table  --  Internal
-;;;
-;;;    Make a list out of all of the recorded conflicts.
-;;;
-(defun listify-conflicts-table ()
-  (collect ((res))
-    (maphash #'(lambda (k v)
-		 (declare (ignore v))
-		 (when k
-		   (res k)))
-	     *list-conflicts-table*)
-    (clrhash *list-conflicts-table*)
-    (res)))
-  
-
-;;;  List-Conflicts  --  Interface
-;;;
-;;;    Return a list of a the TNs that conflict with TN.
-;;;
-(defun list-conflicts (tn)
-  (assert (member (tn-kind tn) '(:normal :cached-constant :environment)))
-  (let ((confs (tn-global-conflicts tn)))
-    (cond ((eq (tn-kind tn) :environment)
-	   (clrhash *list-conflicts-table*)
-	   (do ((env-block (ir2-environment-blocks (tn-environment tn))
-			   (ir2-block-environment-next env-block)))
-	       ((null env-block))
-	     (add-always-live-tns env-block tn)
-	     (add-all-local-tns env-block))
-	   (listify-conflicts-table))
-	  (confs
-	   (clrhash *list-conflicts-table*)
-	   (do ((conf confs (global-conflicts-tn-next conf)))
-	       ((null conf))
-	     (let ((block (global-conflicts-block conf)))
-	       (add-always-live-tns block tn)
-	       (if (eq (global-conflicts-kind conf) :live)
-		   (add-all-local-tns block)
-		   (let ((bconf (global-conflicts-conflicts conf))
-			 (ltns (ir2-block-local-tns block)))
-		     (dotimes (i (ir2-block-local-tn-count block))
-		       (when (/= (sbit bconf i) 0)
-			 (setf (gethash (svref ltns i) *list-conflicts-table*)
-			       t)))))))
-	   (listify-conflicts-table))
-	  (t
-	   (let* ((block (tn-local tn))
-		  (ltns (ir2-block-local-tns block))
-		  (confs (tn-local-conflicts tn)))
-	     (collect ((res))
-	       (dotimes (i (ir2-block-local-tn-count block))
-		 (when (/= (sbit confs i) 0)
-		   (let ((tn (svref ltns i)))
-		     (when (and tn (not (eq tn :more))
-				(not (tn-global-conflicts tn)))
-		       (res tn)))))
-	       (do ((gtn (ir2-block-global-tns block)
-			 (global-conflicts-next gtn)))
-		   ((null gtn))
-		 (when (or (eq (global-conflicts-kind gtn) :live)
-			   (/= (sbit confs (global-conflicts-number gtn)) 0))
-		   (res (global-conflicts-tn gtn))))
-	       (res)))))))
-
-
-;;; Nth-VOP  --  Interface
-;;;
-(defun nth-vop (thing n)
-  "Return the Nth VOP in the IR2-Block pointed to by Thing."
-  (let ((block (block-info (block-or-lose thing))))
-    (do ((i 0 (1+ i))
-	 (vop (ir2-block-start-vop block) (vop-next vop)))
-	((= i n) vop))))
diff --git a/compiler/dfo.lisp b/compiler/dfo.lisp
deleted file mode 100644
index 7f1846cabf99c69de01600d7667de9f04d811072..0000000000000000000000000000000000000000
--- a/compiler/dfo.lisp
+++ /dev/null
@@ -1,310 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;     This file contains the code that finds the initial components and DFO,
-;;; and recomputes the DFO if it is invalidated.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-
-;;; Find-DFO  --  Interface
-;;;
-;;;    Find the DFO for a component, deleting any unreached blocks and merging
-;;; any other components we reach.  We repeatedly iterate over the entry
-;;; points, since new ones may show up during the walk.
-;;;
-(proclaim '(function find-dfo (component) void))
-(defun find-dfo (component)
-  (clear-flags component)
-  (let ((head (component-head component)))
-    (do ()
-	((dolist (ep (block-succ head) t)
-	   (unless (block-flag ep)
-	     (find-dfo-aux ep head component)
-	     (return nil))))))
-
-  (let ((num 0))
-    (declare (fixnum num))
-    (do-blocks-backwards (block component :both)
-      (if (block-flag block)
-	  (setf (block-number block) (incf num))
-	  (delete-block block))))
-  (setf (component-reanalyze component) nil))
-
-
-;;; Join-Components  --  Internal
-;;;
-;;;    Move all the code and entry points from Old to New.  The code in Old is
-;;; inserted at the head of New.
-;;;
-(proclaim '(function join-components (component component) void))
-(defun join-components (new old)
-  (let ((old-head (component-head old))
-	(old-tail (component-tail old))
-	(head (component-head new))
-	(tail (component-tail new)))
-    
-    (do-blocks (block old)
-      (setf (block-flag block) nil)
-      (setf (block-component block) new))
-    
-    (let ((old-next (block-next old-head))
-	  (old-last (block-prev old-tail))
-	  (next (block-next head)))
-      (unless (eq old-next old-tail)
-	(setf (block-next head) old-next)
-	(setf (block-prev old-next) head)
-	
-	(setf (block-prev next) old-last)
-	(setf (block-next old-last) next))
-      
-      (setf (block-next old-head) old-tail)
-      (setf (block-prev old-tail) old-head))
-
-    (setf (component-lambdas new)
-	  (nconc (component-lambdas old) (component-lambdas new)))
-    (setf (component-lambdas old) ())
-    (setf (component-new-functions new)
-	  (nconc (component-new-functions old) (component-new-functions new)))
-    (setf (component-new-functions old) ())
-
-    (dolist (xp (block-pred old-tail))
-      (unlink-blocks xp old-tail)
-      (link-blocks xp tail))
-    (dolist (ep (block-succ old-head))
-      (unlink-blocks old-head ep)
-      (link-blocks head ep))))
-
-
-;;; Find-DFO-Aux  --  Internal
-;;;
-;;;    Do a depth-first walk from Block, inserting ourself in the DFO after
-;;; Head.  If we somehow find ourselves in another component, then we join that
-;;; component to our component.
-;;;
-(proclaim '(function find-dfo-aux (cblock cblock component) void))
-(defun find-dfo-aux (block head component)
-  (unless (eq (block-component block) component)
-    (join-components component (block-component block)))
-	
-  (unless (block-flag block)
-    (setf (block-flag block) t)
-    (dolist (succ (block-succ block))
-      (find-dfo-aux succ head component))
-
-    (remove-from-dfo block)
-    (add-to-dfo block head)))
-
-
-;;; Walk-Home-Call-Graph  --  Internal
-;;;
-;;;   This function ensures that all the blocks in a given environment will be
-;;; in the same component, even when they might not seem reachable from the
-;;; environment entry.  Consider the case of code that is only reachable from a
-;;; non-local exit.
-;;;
-;;;    This function is called on each block by Find-Initial-DFO-Aux before it
-;;; walks the successors.  It looks at the home lambda's bind block to see if
-;;; that block is in some other component:
-;;; -- If the block is in the initial component, then do DFO-Walk-Call-Graph on
-;;;    the home function to move it into component.
-;;; -- If the block is in some other component, join Component into it and
-;;;    return that component.
-;;;
-;;; This ensures that all the blocks in a given environment will be in the same
-;;; component, even when they might not seem reachable from the environment
-;;; entry.  Consider the case of code that is only reachable from a non-local
-;;; exit.
-;;;
-(defun walk-home-call-graph (block component)
-  (declare (type cblock block) (type component component))
-  (let* ((home (lambda-home (block-lambda block)))
-	 (bind-block (node-block (lambda-bind home)))
-	 (home-component (block-component bind-block)))
-    (cond ((eq (component-kind home-component) :initial)
-	   (dfo-walk-call-graph home component))
-	  ((eq home-component component)
-	   component)
-	  (t
-	   (join-components home-component component)
-	   home-component))))
-
-
-;;; Find-Initial-DFO-Aux  --  Internal
-;;;
-;;;    Somewhat similar to Find-DFO-Aux, except that it merges the current
-;;; component with any strange component, rather than the other way around.
-;;; This is more efficient in the common case where the current component
-;;; doesn't have much stuff in it.
-;;;
-;;;    We return the current component as a result, allowing the caller to
-;;; detect when the old current component has been merged with another.
-;;;
-;;;    We walk blocks in initial components as though they were already in the
-;;; current component, moving them to the current component in the process.
-;;; The blocks are inserted at the head of the current component.
-;;;
-(defun find-initial-dfo-aux (block component)
-  (declare (type cblock block) (type component component))
-  (let ((this (block-component block)))
-    (cond
-     ((not (or (eq this component)
-	       (eq (component-kind this) :initial)))
-      (join-components this component)
-      this)
-     ((block-flag block) component)
-     (t
-      (setf (block-flag block) t)
-      (let ((current (walk-home-call-graph block component)))
-	(dolist (succ (block-succ block))
-	  (setq current (find-initial-dfo-aux succ current)))
-	
-	(remove-from-dfo block)
-	(add-to-dfo block (component-head current))
-	current)))))
-
-
-;;; Find-Reference-Functions  --  Internal
-;;;
-;;;    Return a list of all the home lambdas that reference Fun (may contain
-;;; duplications).  References to XEP lambdas in top-level lambdas are excluded
-;;; to keep run-time definitions from being joined to load-time code.  We mark
-;;; any such top-level references as :notinline to prevent the (unlikely)
-;;; possiblity that they might later be converted.  This preserves the
-;;; invariant that local calls are always intra-component without joining in
-;;; all top-level code.
-;;;
-(defun find-reference-functions (fun)
-  (collect ((res))
-    (dolist (ref (leaf-refs fun))
-      (let ((home (lambda-home (block-lambda (node-block ref)))))
-	(if (and (eq (functional-kind home) :top-level)
-		 (eq (functional-kind fun) :external))
-	    (setf (ref-inlinep ref) :notinline)
-	    (res home))))
-    (res)))
-
-
-;;; DFO-Walk-Call-Graph  --  Internal
-;;;
-;;;    Move the code for Fun and all functions called by it into Component.
-;;;
-;;;    If the function is in an initial component, then we move its head and
-;;; tail to Component and add it to Component's lambdas.  We then do a
-;;; Find-DFO-Aux starting at the head of Fun.  If this flow-graph walk
-;;; encounters another component (which can only happen due to a non-local
-;;; exit), then we move code into that component instead.  We then recurse on
-;;; all functions called from Fun, moving code into whichever component the
-;;; preceding call returned.
-;;;
-;;;    If the function is an XEP, then we also walk all functions that contain
-;;; references to the XEP.  This is done so that environment analysis doesn't
-;;; need to cross component boundries.  This also ensures that conversion of a
-;;; full call to a local call won't result in a need to join components, since
-;;; the components will already be one.
-;;;
-;;;    If Fun is in the initial component, but the Block-Flag is set in the
-;;; bind block, then we just return Component, since we must have already
-;;; reached this function in the current walk (or the component would have been
-;;; changed).  If Fun is already in Component, then we just return that
-;;; component.
-;;;
-(defun dfo-walk-call-graph (fun component)
-  (declare (type clambda fun) (type component component))
-  (let* ((bind-block (node-block (lambda-bind fun)))
-	 (this (block-component bind-block))
-	 (return (lambda-return fun)))
-    (cond
-     ((eq this component) component)
-     ((not (eq (component-kind this) :initial))
-      (join-components this component)
-      this)
-     ((block-flag bind-block)
-      component)
-     (t
-      (push fun (component-lambdas component))
-      (link-blocks (component-head component) bind-block)
-      (unlink-blocks (component-head this) bind-block)
-      (when return
-	(let ((return-block (node-block return)))
-	  (link-blocks return-block (component-tail component))
-	  (unlink-blocks return-block (component-tail this))))
-      (let ((calls (if (eq (functional-kind fun) :external)
-		       (append (find-reference-functions fun)
-			       (lambda-calls fun))
-		       (lambda-calls fun))))
-	(do ((res (find-initial-dfo-aux bind-block component)
-		  (dfo-walk-call-graph (first funs) res))
-	     (funs calls (rest funs)))
-	    ((null funs) res)
-	  (declare (type component res))))))))
-	    
-
-;;; Find-Initial-DFO  --  Interface
-;;;
-;;;    Given a list of top-level lambdas, return a list of components
-;;; representing the actual component division.  We assign the DFO for each
-;;; component, and delete any unreachable blocks.  We assume that the Flags
-;;; have already been cleared.
-;;;
-;;;     We iterate over the lambdas in each initial component, trying to put
-;;; each function in its own component, but joining it to an existing component
-;;; if we find that there are references between them.
-;;;
-;;;    When we are done, we assign DFNs and delete any components that are
-;;; empty due to having been merged with another component.  Since all
-;;; functions are walked, moving all reachable code to another component, all
-;;; blocks remaining in the initial component may be deleted.  The only code
-;;; left will be in deleted functions or not reachable from the entry to the
-;;; function.
-;;;
-;;;   We also find components that contain a :Top-Level lambda and no :External
-;;; lambdas, marking them as :Top-Level.  Top-Level components are returned at
-;;; the end of the list so that we compile all real functions before we start
-;;; compiling any Top-Level references to them.  This allows DEFUN, etc., to
-;;; reference functions not in their component (which is normally forbidden).
-;;;
-(defun find-initial-dfo (lambdas)
-  (declare (list lambdas))
-  (collect ((components))
-    (let ((new (make-empty-component)))
-      (dolist (tll lambdas)
-	(let ((component (block-component (node-block (lambda-bind tll)))))
-	  (dolist (fun (component-lambdas component))
-	    (assert (member (functional-kind fun)
-			    '(:optional :external :top-level nil :escape
-					:cleanup)))
-	    (let ((res (dfo-walk-call-graph fun new)))
-	      (when (eq res new)
-		(components new)
-		(setq new (make-empty-component)))))
-      
-	  (do-blocks (block component)
-	    (delete-block block)))))
-    
-    (collect ((real)
-	      (top))
-      (dolist (com (components))
-	(let ((num 0))
-	  (declare (fixnum num))
-	  (do-blocks-backwards (block com :both)
-	    (setf (block-number block) (incf num)))
-	  (unless (= num 2)
-	    (setf (component-name com) (find-component-name com))
-	    (let ((funs (component-lambdas com)))
-	      (cond ((find :top-level funs :key #'functional-kind)
-		     (unless (find :external funs :key #'functional-kind)
-		       (setf (component-kind com) :top-level)
-		       (setf (component-name com) "Top-Level Form"))
-		     (top com))
-		    (t
-		     (real com)))))))
-      (nconc (real) (top)))))
diff --git a/compiler/dump.lisp b/compiler/dump.lisp
deleted file mode 100644
index 052db7ee50f2a0c1522abb6e6193631d8da52bc0..0000000000000000000000000000000000000000
--- a/compiler/dump.lisp
+++ /dev/null
@@ -1,1054 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/dump.lisp,v 1.4 1990/02/13 17:07:00 wlott Exp $
-;;;
-;;;    This file contains stuff that knows about dumping FASL files.
-;;;
-(in-package "C")
-
-(proclaim '(special compiler-version))
-
-
-
-;;;; Fasl dumper state:
-
-;;; The Fasl-File structure represents everything we need to know about dumping
-;;; to a fasl file.  We need to objectify the state, since the fasdumper must
-;;; be reentrant.
-;;;
-(defstruct (fasl-file
-	    (:print-function
-	     (lambda (s stream d)
-	       (declare (ignore d))
-	       (format stream "#<Fasl-File ~S>"
-		       (namestring (fasl-file-stream s))))))
-  ;;
-  ;; The stream we dump to.
-  (stream nil :type stream)
-  ;;
-  ;; Hashtables we use to keep track of dumped constants so that we can get
-  ;; them from the table rather than dumping them again.  The EQUAL-TABLE is
-  ;; used for lists and strings, and the EQ-TABLE is used for everything else.
-  ;; We use a separate EQ table to avoid performance patholigies with objects
-  ;; for which EQUAL degnerates to EQL.  Everything entered in the EQUAL table
-  ;; is also entered in the EQ table.
-  (equal-table (make-hash-table :test #'equal) :type hash-table)
-  (eq-table (make-hash-table :test #'eq) :type hash-table)
-  ;;
-  ;; The table's current free pointer: the next offset to be used.
-  (table-free 0 :type unsigned-byte)
-  ;;
-  ;; Alist (Package . Offset) of the table offsets for each package we have
-  ;; currently located.
-  (packages () :type list)
-  ;;
-  ;; Table mapping from the Entry-Info structures for dumped XEPs to the table
-  ;; offsets of the corresponding code pointers.
-  (entry-table (make-hash-table :test #'eq) :type hash-table)
-  ;;
-  ;; Table holding back-patching info for forward references to XEPs.  The key
-  ;; is the Entry-Info structure for the XEP, and the value is a list of conses
-  ;; (<code-handle> . <offset>), where <code-handle> is the offset in the table
-  ;; of the code object needing to be patched, and <offset> is the offset that
-  ;; must be patched.
-  (patch-table (make-hash-table :test #'eq) :type hash-table)
-  ;;
-  ;; A list of the table handles for all of the DEBUG-INFO structures dumped in
-  ;; this file.  These structures must be back-patched with source location
-  ;; information when the compilation is complete.
-  (debug-info () :type list)
-  ;;
-  ;; Used to keep track of objects that we are in the process of dumping so that
-  ;; circularities can be preserved.  The key is the object that we have
-  ;; previously seen, and the value is the object that we reference in the table
-  ;; to find this previously seen object.  (The value is never NIL.)
-  ;;
-  ;; Except with list objects, the key and the value are always the same.  In a
-  ;; list, the key will be some tail of the value.
-  (circularity-table (make-hash-table :test #'eq) :type hash-table))
-
-
-;;; This structure holds information about a circularity.
-;;;
-(defstruct circularity
-  ;;
-  ;; Kind of modification to make to create circularity.
-  (type nil :type (member :rplaca :rplacd :svset))
-  ;;
-  ;; Object containing circularity.
-  object
-  ;;
-  ;; Index in object for circularity.
-  (index nil :type unsigned-byte)
-  ;;
-  ;; The object to be stored at Index in Object.  This is that the key that we
-  ;; were using when we discovered the circularity.
-  value
-  ;;
-  ;; The value that was associated with Value in the CIRCULARITY-TABLE.  This
-  ;; is the object that we look up in the EQ-TABLE to locate Value.
-  enclosing-object)
-
-
-;;; A list of the Circularity structures for all of the circularities detected
-;;; in the the current top-level call to Dump-Object.  Setting this lobotomizes
-;;; circularity detection as well, since circular dumping uses the table.
-;;;
-(defvar *circularities-detected*)
-
-
-;;; Used to inhibit table access when dumping forms to be read by the cold
-;;; loader.
-;;;
-(defvar *cold-load-dump* nil)
-
-
-;;;; Utilities:
-
-;;; Dump-Byte  --  Internal
-;;;
-;;;    Write the byte B to the specified fasl-file stream.
-;;;
-(proclaim '(inline dump-byte))
-(defun dump-byte (b file)
-  (declare (type (unsigned-byte 8) b) (type fasl-file file))
-  (write-byte b (fasl-file-stream file))
-  (undefined-value))
-
-
-;;; Dump-FOP  --  Internal
-;;;
-;;;    Dump the FOP code for the named FOP to the specified fasl-file.
-;;;
-(defun dump-fop (fs file)
-  (declare (symbol fs) (type fasl-file file))
-  (let ((val (get fs 'lisp::fop-code)))
-    (assert val () "Compiler bug: ~S not a legal fasload operator." fs)
-    (dump-byte val file))
-  (undefined-value))
-
-
-;;; Dump-FOP*  --  Internal
-;;;
-;;;    Dump a FOP-Code along with an integer argument, choosing the FOP based
-;;; on whether the argument will fit in a single byte.
-;;;
-(defmacro dump-fop* (n byte-fop word-fop file)
-  (once-only ((n-n n)
-	      (n-file file))
-    `(cond ((< ,n-n 256)
-	    (dump-fop ',byte-fop ,n-file)
-	    (dump-byte ,n-n ,n-file))
-	   (t
-	    (dump-fop ',word-fop ,n-file)
-	    (quick-dump-number ,n-n 4 ,n-file)))))
-
-
-;;; Quick-Dump-Number  --  Internal
-;;;
-;;;    Dump Num to the fasl stream, represented by the specified number of
-;;; bytes.
-;;;
-(defun quick-dump-number (num bytes file)
-  (declare (integer num) (type unsigned-byte bytes) (type fasl-file file))
-  (let ((stream (fasl-file-stream file)))
-    (do ((n num (ash n -8))
-	 (i bytes (1- i)))
-	((= i 0))
-      (write-byte (logand n #xFF) stream)))
-  (undefined-value))
-
-
-;;; Dump-Push  --  Internal
-;;;
-;;;    Push the object at table offset Handle on the fasl stack.
-;;;
-(defun dump-push (handle file)
-  (declare (type unsigned-byte handle) (type fasl-file file))
-  (dump-fop* handle lisp::fop-byte-push lisp::fop-push file)
-  (undefined-value))
-
-
-;;; Dump-Pop  --  Internal
-;;;
-;;;    Pop the object currently on the fasl stack top into the table, and
-;;; return the table index, incrementing the free pointer.
-;;;
-(defun dump-pop (file)
-  (prog1 (fasl-file-table-free file)
-    (dump-fop 'lisp::fop-pop file)
-    (incf (fasl-file-table-free file))))
-
-
-;;; EQUAL-CHECK-TABLE  --  Internal
-;;;
-;;;    If X is in File's EQUAL-TABLE, then push the object and return T,
-;;; otherwise NIL.  If *COLD-LOAD-DUMP* is true, then do nothing and return
-;;; NIL.
-;;;
-(defun equal-check-table (x file)
-  (declare (type fasl-file file))
-  (unless *cold-load-dump*
-    (let ((handle (gethash x (fasl-file-equal-table file))))
-      (cond (handle
-	     (dump-push handle file)
-	     t)
-	    (t
-	     nil)))))
-
-
-;;; EQ-SAVE-OBJECT, EQUAL-SAVE-OBJECT  --  Internal
-;;;
-;;;    These functions are called after dumping an object to save the object in
-;;; the table.  The object (also passed in as X) must already be on the top of
-;;; the FOP stack.  If *COLD-LOAD-DUMP* is true, then we don't do anything.
-;;;
-(defun eq-save-object (x file)
-  (declare (type fasl-file file))
-  (unless *cold-load-dump*
-    (let ((handle (dump-pop file)))
-      (setf (gethash x (fasl-file-eq-table file)) handle)
-      (dump-push handle file)))
-  (undefined-value))
-;;;
-(defun equal-save-object (x file)
-  (declare (type fasl-file file))
-  (unless *cold-load-dump*
-    (let ((handle (dump-pop file)))
-      (setf (gethash x (fasl-file-equal-table file)) handle)
-      (setf (gethash x (fasl-file-eq-table file)) handle)
-      (dump-push handle file)))
-  (undefined-value))
-
-
-;;; NOTE-POTENTIAL-CIRCULARITY  --  Internal
-;;;
-;;;    Record X in File's CIRCULARITY-TABLE unless *COLD-LOAD-DUMP* is true.
-;;; This is called on objects that we are about to dump might have a circular
-;;; path through them.
-;;;
-;;; The object must not currently be in this table, since the dumper should
-;;; never be recursively called on a circular reference.  Instead, the dumping
-;;; function must detect the circularity and arrange for the dumped object to
-;;; be patched.
-;;;
-(defun note-potential-circularity (x file)
-  (unless *cold-load-dump*
-    (let ((circ (fasl-file-circularity-table file)))
-      (assert (not (gethash x circ)))
-      (setf (gethash x circ) x)))
-  (undefined-value))
-
-
-;;; Fasl-Dump-Cold-Load-Form  --  Interface
-;;;
-;;;    Dump Form to a fasl file so that it evaluated at load time in normal
-;;; load and at cold-load time in cold load.  This is used to dump package
-;;; frobbing forms.
-;;;
-(defun fasl-dump-cold-load-form (form file)
-  (declare (type fasl-file file))
-  (dump-fop 'lisp::fop-normal-load file)
-  (let ((*cold-load-dump* t))
-    (dump-object form file))
-  (dump-fop 'lisp::fop-eval-for-effect file)
-  (dump-fop 'lisp::fop-maybe-cold-load file)
-  (undefined-value))
-
-
-;;;; Opening and closing:
-
-;;; Open-Fasl-File  --  Interface
-;;;
-;;;    Return a Fasl-File object for dumping to the named file.  Some
-;;; information about the source is specified by the string Where.
-;;;
-(defun open-fasl-file (name where)
-  (declare (type pathname name))
-  (let* ((stream (open name :direction :output
-		       :if-exists :new-version
-		       :element-type '(unsigned-byte 8)))
-	 (res (make-fasl-file :stream stream)))
-    (format stream
-	    "FASL FILE output from ~A.~@
-	    Compiled ~A on ~A~@
-	    Compiler ~A, Lisp ~A~@
-	    Targeted for ~A, FASL code format ~D~%"
-	    where
-	    (ext:format-universal-time nil (get-universal-time))
-	    (machine-instance) compiler-version
-	    (lisp-implementation-version) vm-version target-fasl-code-format)
-    ;;
-    ;; Terminate header.
-    (dump-byte 255 res)
-    ;;
-    ;; Specify code format.
-    (dump-fop 'lisp::fop-code-format res)
-    (dump-byte target-fasl-code-format res)
-
-    res))
-
-
-;;; Close-Fasl-File  --  Interface
-;;;
-;;;    Close the specified Fasl-File, aborting the write if Abort-P is true.
-;;; We do various sanity checks, then end the group.
-;;;
-(defun close-fasl-file (file abort-p)
-  (declare (type fasl-file file))
-  (dump-fop 'lisp::fop-verify-empty-stack file)
-  (dump-fop 'lisp::fop-verify-table-size file)
-  (quick-dump-number (fasl-file-table-free file) 4 file)
-  (dump-fop 'lisp::fop-end-group file)
-  (close (fasl-file-stream file) :abort abort-p)
-  (undefined-value))
-
-
-;;;; Component (function) dumping:
-
-;;; Dump-Code-Object  --  Internal
-;;;
-;;;    Dump out the constant pool and code-vector for component, push the
-;;; result in the table and return the offset.
-;;;
-;;;    The only tricky thing is handling constant-pool references to functions.
-;;; If we have already dumped the function, then we just push the code pointer.
-;;; Otherwise, we must create back-patching information so that the constant
-;;; will be set when the function is eventually dumped.  This is a bit awkward,
-;;; since we don't have the handle for the code object being dumped while we
-;;; are dumping its constants.
-;;;
-;;;    We dump a trap object as a placeholder for the code vector, which is
-;;; actually filled in by the loader.
-;;;
-(defun dump-code-object (component code-vector code-length node-vector
-				   nodes-length file)
-  (declare (type component component) (type fasl-file file)
-	   (simple-vector node-vector)
-	   (type unsigned-byte code-length nodes-length))
-  (let* ((2comp (component-info component))
-	 (constants (ir2-component-constants 2comp))
-	 (num-consts (length constants)))
-    (collect ((patches))
-
-      ;; Dump the constants, noting any :entries that have to be fixed up.
-      (do ((i vm:code-constants-offset (1+ i)))
-	  ((= i num-consts))
-	(let ((entry (aref constants i)))
-	  (etypecase entry
-	    (constant
-	     (dump-object (constant-value entry) file))
-	    (cons
-	     (ecase (car entry)
-	       (:entry
-		(let* ((info (leaf-info (cdr entry)))
-		       (handle (gethash info (fasl-file-entry-table file))))
-		  (cond
-		   (handle
-		    (dump-push handle file))
-		   (t
-		    (patches (cons info i))
-		    (dump-fop 'lisp::fop-misc-trap file)))))
-	       (:label
-		(dump-object (+ (label-location (cdr entry))
-				clc::i-vector-header-size)
-			     file))))
-	    (null
-	     (dump-fop 'lisp::fop-misc-trap file)))))
-
-      ;; Dump the debug info.
-      (let ((info (debug-info-for-component component node-vector
-					    nodes-length)))
-	(dump-object info file)
-	(let ((info-handle (dump-pop file)))
-	  (dump-push info-handle file)
-	  (push info-handle (fasl-file-debug-info file))))
-
-      (let ((num-consts (- num-consts vm:code-constants-offset)))
-	(cond ((and (< num-consts #x100) (< code-length #x10000))
-	       (dump-fop 'lisp::fop-small-code file)
-	       (dump-byte num-consts file)
-	       (quick-dump-number code-length 2 file))
-	      (t
-	       (dump-fop 'lisp::fop-code file)
-	       (quick-dump-number num-consts 4 file)
-	       (quick-dump-number code-length 4 file))))
-      
-      (write-string code-vector (fasl-file-stream file) :end code-length)
-      
-      (let ((handle (dump-pop file)))
-	(dolist (patch (patches))
-	  (push (cons handle (cdr patch))
-		(gethash (car patch) (fasl-file-patch-table file))))
-	handle))))
-
-
-;;; Dump-Fixups  --  Internal
-;;;
-;;;    Dump all the fixups.  Currently there are only miscop fixups, and we
-;;; always access them by name rather than number.  There is no reason for
-;;; using miscop numbers other than a minor load-time efficiency win.
-;;;
-(defun dump-fixups (code-handle fixups file)
-  (declare (type unsigned-byte code-handle) (list fixups)
-	   (type fasl-file file))
-  (when fixups
-    (dump-push code-handle file)
-    (dolist (fixup fixups)
-      (let ((offset (second fixup))
-	    (value (third fixup)))
-	(ecase (first fixup)
-	  #+nil
-	  (:miscop
-	   (assert (symbolp value))
-	   (dump-object value file)
-	   (dump-fop 'lisp::fop-user-miscop-fixup file)
-	   (quick-dump-number offset 4 file))
-	  (:foreign
-	   (assert (stringp value))
-	   (dump-fop 'lisp::fop-foreign-fixup file)
-	   (quick-dump-number offset 4 file)
-	   (let ((len (length value)))
-	     (assert (< len 256))
-	     (dump-byte len file)
-	     (dotimes (i len)
-	       (dump-byte (char-code (schar value i)) file)))))))
-    (dump-fop 'lisp::fop-pop-for-effect file))
-  (undefined-value))
-
-
-;;; Dump-One-Entry  --  Internal
-;;;
-;;;    Dump a function-entry data structure corresponding to Entry to File.
-;;; Code-Handle is the table offset of the code object for the component.
-;;;
-;;; If the entry is a DEFUN, then we also dump a FOP-FSET so that the cold
-;;; loader can instantiate the definition at cold-load time, allowing forward
-;;; references to functions in top-level forms.
-;;;
-(defun dump-one-entry (entry code-handle file)
-  (declare (type entry-info entry) (type unsigned-byte code-handle)
-	   (type fasl-file file))
-  (let ((name (entry-info-name entry)))
-    ;; ### Do something special for closure functions?
-    (dump-push code-handle file)
-    (dump-object name file)
-    (dump-object (entry-info-arguments entry) file)
-    (dump-object (entry-info-type entry) file)
-    (dump-fop 'lisp::fop-function-entry file)
-    (quick-dump-number (label-location (entry-info-offset entry))
-		       4 file)
-    (let ((handle (dump-pop file)))
-      (when (and name (symbolp name))
-	(dump-object name file)
-	(dump-push handle file)
-	(dump-fop 'lisp::fop-fset file))
-      handle)))
-
-;;; Alter-Code-Object  --  Internal
-;;;
-;;;    Alter the code object referenced by Code-Handle at the specified Offset,
-;;; storing the object referenced by Entry-Handle.
-;;;
-(defun alter-code-object (code-handle offset entry-handle file)
-  (dump-push code-handle file)
-  (dump-push entry-handle file)
-  (dump-fop* offset lisp::fop-byte-alter-code lisp::fop-alter-code file)
-  (undefined-value))
-
-
-;;; Fasl-Dump-Component  --  Interface
-;;;
-;;;    Dump the code, constants, etc. for component.  We pass in the assembler
-;;; fixups, code vector and node info.
-;;;
-(defun fasl-dump-component (component code-vector code-length
-				      node-vector nodes-length
-				      fixups file)
-  (declare (type component component) (type unsigned-byte length)
-	   (list fixups) (type fasl-file file))
-
-  (dump-fop 'lisp::fop-verify-empty-stack file)
-  (dump-fop 'lisp::fop-verify-table-size file)
-  (quick-dump-number (fasl-file-table-free file) 4 file)
-
-  (let ((code-handle (dump-code-object component code-vector code-length
-				       node-vector nodes-length file))
-	(2comp (component-info component)))
-    (dump-fixups code-handle fixups file)
-    (dump-fop 'lisp::fop-verify-empty-stack file)
-
-    (dolist (entry (ir2-component-entries 2comp))
-      (let ((entry-handle (dump-one-entry entry code-handle file)))
-	(setf (gethash entry (fasl-file-entry-table file)) entry-handle)
-
-	(let ((old (gethash entry (fasl-file-patch-table file))))
-	  (when old
-	    (dolist (patch old)
-	      (alter-code-object (car patch) (cdr patch) entry-handle file))
-	    (remhash entry (fasl-file-patch-table file)))))))
-
-  (assert (zerop (hash-table-count (fasl-file-patch-table file))))
-
-  (undefined-value))
-
-
-;;; FASL-DUMP-TOP-LEVEL-LAMBDA-CALL  --  Interface
-;;;
-;;;    Dump a FOP-FUNCALL to call an already dumped top-level lambda at load
-;;; time.  
-;;;
-(defun fasl-dump-top-level-lambda-call (fun file)
-  (declare (type clambda fun) (type fasl-file file))
-  (let ((handle (gethash (leaf-info fun) (fasl-file-entry-table file))))
-    (assert handle)
-    (dump-push handle file)
-    (dump-fop 'lisp::fop-funcall-for-effect file)
-    (dump-byte 0 file))
-  (undefined-value))
-
-
-;;; FASL-DUMP-SOURCE-INFO  --  Interface
-;;;
-;;;    Compute the correct list of DEBUG-SOURCE structures and backpatch all of
-;;; the dumped DEBUG-INFO structures.  We clear the FASL-FILE-DEBUG-INFO,
-;;; so that subsequent components with different source info may be dumped.
-;;;
-(defun fasl-dump-source-info (info file)
-  (declare (type source-info info) (type fasl-file file))
-  (let ((res (debug-source-for-info info)))
-    (dump-object res file)
-    (let ((res-handle (dump-pop file)))
-      (dolist (info-handle (fasl-file-debug-info file))
-	(dump-push res-handle file)
-	(dump-fop 'lisp::fop-svset file)
-	(quick-dump-number info-handle 4 file)
-	(quick-dump-number 2 4 file))))
-
-  (setf (fasl-file-debug-info file) ())
-  (undefined-value))
-
-
-;;;; Main entries to object dumping:
-
-;;; Dump-Non-Immediate-Object  --  Internal
-;;;
-;;;    This function deals with dumping objects that are complex enough so that
-;;; we want to cache them in the table, rather than repeatedly dumping them.
-;;; If the object is in the EQ-TABLE, then we push it, otherwise, we do a type
-;;; dispatch to a type specific dumping function.  The type specific branches
-;;; do any appropriate EQUAL-TABLE check and table entry.
-;;;
-;;;    When we go to dump the object, we enter it in the CIRCULARITY-TABLE.
-;;;
-(defun dump-non-immediate-object (x file)
-  (let ((index (gethash x (fasl-file-eq-table file))))
-    (cond ((and index (not *cold-load-dump*))
-	   (dump-push index file))
-	  (t
-	   (typecase x
-	     (symbol (dump-symbol x file))
-	     (list
-	      (unless (equal-check-table x file)
-		(dump-list x file)
-		(equal-save-object x file)))
-	     (structure
-	      (dump-structure x file))
-	     (vector
-	      (cond ((stringp x)
-		     (unless (equal-check-table x file)
-		       (dump-string x file)
-		       (equal-save-object x file)))
-		    ((subtypep (array-element-type x)
-			       '(unsigned-byte 16))
-		     (dump-i-vector x file)
-		     (eq-save-object x file))
-		    (t
-		     (dump-vector x file)
-		     (eq-save-object x file))))
-	     (array
-	      (dump-array x file)
-	      (eq-save-object x file))
-	     (number
-	      (unless (equal-check-table x file)
-		(etypecase x
-		  (ratio (dump-ratio x file))
-		  (complex (dump-complex x file))
-		  (long-float (dump-long-float x file))
-		  (integer (dump-integer x file)))
-		(equal-save-object x file)))
-#|
-	     (compiled-function
-	      (dump-function x file)
-	      (eq-save-object x file))
-|#
-	     (t
-	      (compiler-error
-	       "This object cannot be dumped into a fasl file:~% ~S"
-	       x))))))
-
-  (undefined-value))
-
-
-;;; Sub-Dump-Object  --  Internal
-;;;
-;;;    Dump an object of any type by dispatching to the correct type-specific
-;;; dumping function.  We pick off immediate objects, symbols and and magic
-;;; lists here.  Other objects are handled by Dump-Non-Immediate-Object.
-;;;
-;;; This is the function used for recursive calls to the fasl dumper.  We don't
-;;; worry about creating circularities here, since it is assumed that there is
-;;; a top-level call to Dump-Object.
-;;;
-(defun sub-dump-object (x file)
-  (cond ((listp x)
-	 (cond ((null x) (dump-fop 'lisp::fop-empty-list file))
-	       #|
-	       ((eq (car x) '%eval-at-load-time) (load-time-eval x))
-	       |#
-	       (t
-		(dump-non-immediate-object x file))))
-	((symbolp x)
-	 (if (eq x t)
-	     (dump-fop 'lisp::fop-truth file)
-	     (dump-non-immediate-object x file)))
-	((fixnump x) (dump-integer x file))
-	((characterp x) (dump-character x file))
-	((typep x 'short-float) (dump-short-float x file))
-#| Probably a bug to ever dump a trap object...
-	((lisp::trap-object-p x)
-	 (dump-fop 'lisp::fop-misc-trap file))
-|#
-	(t
-	 (dump-non-immediate-object x file))))
-
-
-;;; Dump-Circularities  --  Internal
-;;;
-;;;    Dump stuff to backpatch already dumped objects.  Infos is the list of
-;;; Circularity structures describing what to do.  The patching FOPs take the
-;;; value to store on the stack.  We compute this value by fetching the
-;;; enclosing object from the table, and then CDR'ing it if necessary.
-;;;
-(defun dump-circularities (infos file)
-  (let ((table (fasl-file-eq-table file)))
-    (dolist (info infos)
-      (let* ((value (circularity-value info))
-	     (enclosing (circularity-enclosing-object info)))
-	(dump-push (gethash enclosing table) file)
-	(unless (eq enclosing value)
-	  (do ((current enclosing (cdr current))
-	       (i 0 (1+ i)))
-	      ((eq current value)
-	       (dump-fop 'lisp::fop-nthcdr file)
-	       (quick-dump-number i 4 file)))))
-      
-      (dump-fop (case (circularity-type info)
-		  (:rplaca 'lisp::fop-rplaca)
-		  (:rplacd 'lisp::fop-rplacd)
-		  (:svset 'lisp::fop-svset))
-		file)
-      (quick-dump-number (gethash (circularity-object info) table) 4 file)
-      (quick-dump-number (circularity-index info) 4 file))))
-
-
-;;; Dump-Object  -- Interface
-;;;
-;;;    Set up stuff for circularity detection, then dump an object.  All shared
-;;; and circular structure will be exactly preserved within a single call to
-;;; Dump-Object.  Sharing between objects dumped by separate calls is only
-;;; preserved when convenient.
-;;;
-;;;    We peek at the objec type so that we only pay the circular detection
-;;; overhead on types of objects that might be circular.
-;;;
-(defun dump-object (x file)
-  (if (or (arrayp x) (consp x))
-      (let ((*circularities-detected* ())
-	    (circ (fasl-file-circularity-table file)))
-	(clrhash circ)
-	(sub-dump-object x file)
-	(when *circularities-detected*
-	  (dump-circularities *circularities-detected* file)
-	  (clrhash circ)))
-      (sub-dump-object x file)))
-
-
-#|
-;;; Load-Time-Eval  --  Internal
-;;;
-;;;    This guy deals with the magical %Eval-At-Load-Time marker that
-;;; #, turns into when the *compiler-is-reading* and a fasl file is being
-;;; written.
-;;;
-(defun load-time-eval (x file)
-  (when *compile-to-lisp*
-    (compiler-error "#,~S in a bad place." (third x)))
-  (assemble-one-lambda (cadr x))
-  (dump-fop 'lisp::fop-funcall file)
-  (dump-byte 0 file))
-|#
-
-;;;; Number Dumping:
-
-;;; Dump a ratio
-
-(defun dump-ratio (x file)
-  (sub-dump-object (numerator x) file)
-  (sub-dump-object (denominator x) file)
-  (dump-fop 'lisp::fop-ratio file))
-
-;;; Or a complex...
-
-(defun dump-complex (x file)
-  (sub-dump-object (realpart x) file)
-  (sub-dump-object (imagpart x) file)
-  (dump-fop 'lisp::fop-complex file))
-
-;;; Dump an integer.
-
-(defun dump-integer (n file)
-  (let* ((bytes (compute-bytes n)))
-    (cond ((= bytes 1)
-	   (dump-fop 'lisp::fop-byte-integer file)
-	   (dump-byte (logand #xFF n) file))
-	  ((< bytes 5)
-	   (dump-fop 'lisp::fop-word-integer file)
-	   (quick-dump-number n 4 file))
-	  ((< bytes 256)
-	   (dump-fop 'lisp::fop-small-integer file)
-	   (dump-byte bytes file)
-	   (quick-dump-number n bytes file))
-	  (t (dump-fop 'lisp::fop-integer file)
-	     (quick-dump-number bytes 4 file)
-	     (quick-dump-number n bytes file)))))
-
-;;; Compute how many bytes it will take to represent signed integer N.
-
-(defun compute-bytes (n)
-  (truncate (+ (integer-length n) 8) 8))
-
-;;;
-;;; These two are almost exactly alike, and could easily be the same function.
-
-(defun dump-short-float (x file)
-  (multiple-value-bind (f exponent sign) (decode-float x)
-    (let ((mantissa (truncate (scale-float (* f sign) (float-precision f)))))
-      (dump-fop 'lisp::fop-float file)
-      (dump-byte (1+ (integer-length exponent)) file)
-      (quick-dump-number exponent (compute-bytes exponent) file)
-      (dump-byte (1+ (integer-length mantissa)) file)
-      (quick-dump-number mantissa (compute-bytes mantissa) file))))
-
-#|
-(defun dump-single-float (x file)
-  (multiple-value-bind (f exponent sign) (decode-float x)
-    (let ((mantissa (truncate (scale-float (* f sign) (float-precision f)))))
-      (dump-fop 'lisp::fop-float file)
-      (dump-byte (1+ (integer-length exponent)) file)
-      (dump-byte exponent file)
-      (dump-byte (1+ (integer-length mantissa)) file)
-      (quick-dump-number mantissa (compute-bytes mantissa) file))))
-|#
-;;; For long-floats we're careful that the dumped mantissa actually
-;;; has 63 significant bits, so the fasloader can recognize it as such.
-
-(defun dump-long-float (x file)
-  (multiple-value-bind (f exponent sign) (decode-float x)
-    (let ((mantissa (truncate (scale-float (* f sign) (float-precision f)))))
-      (dump-fop 'lisp::fop-float file)
-      (dump-byte (1+ (integer-length exponent)) file)
-      (quick-dump-number exponent (compute-bytes exponent) file)
-      (dump-byte (1+ (integer-length mantissa)) file)
-      (quick-dump-number mantissa (compute-bytes mantissa) file))))
-
-
-;;;; Symbol Dumping:
-
-;;; Dump-Package  --  Internal
-;;;
-;;;    Return the table index of Pkg, adding the package to the table if
-;;; necessary.  During cold load, we read the string as a normal string so that
-;;; we can do the package lookup at cold load time.
-;;;
-(defun dump-package (pkg file)
-  (cond ((cdr (assoc pkg (fasl-file-packages file))))
-	(t
-	 (unless *cold-load-dump*
-	   (dump-fop 'lisp::fop-normal-load file))
-	 (dump-string (package-name pkg) file)
-	 (dump-fop 'lisp::fop-package file)
-	 (unless *cold-load-dump*
-	   (dump-fop 'lisp::fop-maybe-cold-load file))
-	 (let ((entry (dump-pop file)))
-	   (push (cons pkg entry) (fasl-file-packages file))
-	   entry))))
-
-
-;;; Dump-Symbol  --  Internal
-;;;
-;;;    If we get here, it is assumed that the symbol isn't in the table, but we
-;;; are responsible for putting it there when appropriate.  To avoid too much
-;;; special-casing, we always push the symbol in the table, but don't record
-;;; that we have done so if *Cold-Load-Dump* is true.
-;;;
-(defun dump-symbol (s file)
-  (let* ((pname (symbol-name s))
-	 (pname-length (length pname))
-	 (pkg (symbol-package s)))
-
-    (cond ((null pkg)
-	   (dump-fop* pname-length lisp::fop-uninterned-small-symbol-save
-		      lisp::fop-uninterned-symbol-save file))
-	  ((eq pkg *package*)
-	   (dump-fop* pname-length lisp::fop-small-symbol-save
-		      lisp::fop-symbol-save file))
-	  ((eq pkg ext:*lisp-package*)
-	   (dump-fop* pname-length lisp::fop-lisp-small-symbol-save
-		      lisp::fop-lisp-symbol-save file))
-	  ((eq pkg ext:*keyword-package*)
-	   (dump-fop* pname-length lisp::fop-keyword-small-symbol-save
-		      lisp::fop-keyword-symbol-save file))
-	  ((< pname-length 256)
-	   (dump-fop* (dump-package pkg file)
-		      lisp::fop-small-symbol-in-byte-package-save
-		      lisp::fop-small-symbol-in-package-save file)
-	   (dump-byte pname-length file))
-	  (t
-	   (dump-fop* (dump-package pkg file)
-		      lisp::fop-symbol-in-byte-package-save
-		      lisp::fop-symbol-in-package-save file)
-	   (quick-dump-number pname-length 4 file)))
-
-    (write-string pname (fasl-file-stream file))
-
-    (unless *cold-load-dump*
-      (setf (gethash s (fasl-file-eq-table file)) (fasl-file-table-free file)))
-
-    (incf (fasl-file-table-free file)))
-
-  (undefined-value))
-
-
-;;; Dumper for lists.
-
-;;; Dump-List  --  Internal
-;;;
-;;;    Dump a list, setting up patching information when there are
-;;; circularities.  We scan down the list, checking for CDR and CAR
-;;; circularities.
-;;;
-;;; If there is a CDR circularity, we terminate the list with NIL and make a
-;;; Circularity notation for the CDR of the previous cons.
-;;;
-;;; If there is no CDR circularity, then we mark the current cons and check for
-;;; a CAR circularity.  When there is a CAR circularity, we make the CAR NIL
-;;; initially, arranging for the current cons to be patched later.
-;;;
-;;; Otherwise, we recursively call the dumper to dump the current element.
-;;;
-;;; Marking of the conses is inhibited when *cold-load-dump* is true.  This
-;;; inhibits all circularity detection.
-;;;
-(defun dump-list (list file)
-  (assert (and list
-	       (not (gethash list (fasl-file-circularity-table file)))))
-  (do* ((l list (cdr l))
-	(n 0 (1+ n))
-	(circ (fasl-file-circularity-table file)))
-       ((atom l)
-	(cond ((null l)
-	       (terminate-undotted-list n file))
-	      (t
-	       (sub-dump-object l file)
-	       (terminate-dotted-list n file))))
-
-    (let ((ref (gethash l circ)))
-      (when ref
-	(push (make-circularity :type :rplacd  :object list  :index (1- n)
-				:value l  :enclosing-object ref)
-	      *circularities-detected*)
-	(terminate-undotted-list n file)
-	(return)))
-
-    (unless *cold-load-dump*
-      (setf (gethash l circ) list))
-
-    (let* ((obj (car l))
-	   (ref (gethash obj circ)))
-      (cond (ref
-	     (push (make-circularity :type :rplaca  :object list  :index n
-				     :value obj  :enclosing-object ref)
-		   *circularities-detected*)
-	     (sub-dump-object nil file))
-	    (t
-	     (sub-dump-object obj file))))))
-
-
-(defun terminate-dotted-list (n file)
-  (case n
-    (1 (dump-fop 'lisp::fop-list*-1 file))
-    (2 (dump-fop 'lisp::fop-list*-2 file))
-    (3 (dump-fop 'lisp::fop-list*-3 file))
-    (4 (dump-fop 'lisp::fop-list*-4 file))
-    (5 (dump-fop 'lisp::fop-list*-5 file))
-    (6 (dump-fop 'lisp::fop-list*-6 file))
-    (7 (dump-fop 'lisp::fop-list*-7 file))
-    (8 (dump-fop 'lisp::fop-list*-8 file))
-    (T (do ((nn n (- nn 255)))
-	   ((< nn 256)
-	    (dump-fop 'lisp::fop-list* file)
-	    (dump-byte nn file))
-	 (dump-fop 'lisp::fop-list* file)
-	 (dump-byte 255 file)))))
-
-;;; If N > 255, must build list with one list operator, then list* operators.
-
-(defun terminate-undotted-list (n file)
-    (case n
-      (1 (dump-fop 'lisp::fop-list-1 file))
-      (2 (dump-fop 'lisp::fop-list-2 file))
-      (3 (dump-fop 'lisp::fop-list-3 file))
-      (4 (dump-fop 'lisp::fop-list-4 file))
-      (5 (dump-fop 'lisp::fop-list-5 file))
-      (6 (dump-fop 'lisp::fop-list-6 file))
-      (7 (dump-fop 'lisp::fop-list-7 file))
-      (8 (dump-fop 'lisp::fop-list-8 file))
-      (T (cond ((< n 256)
-		(dump-fop 'lisp::fop-list file)
-		(dump-byte n file))
-	       (t (dump-fop 'lisp::fop-list file)
-		  (dump-byte 255 file)
-		  (do ((nn (- n 255) (- nn 255)))
-		      ((< nn 256)
-		       (dump-fop 'lisp::fop-list* file)
-		       (dump-byte nn file))
-		    (dump-fop 'lisp::fop-list* file)
-		    (dump-byte 255 file)))))))
-
-;;;; Array dumping:
-
-(defun dump-vector (v file)
-  (note-potential-circularity v file)
-  (do ((index 0 (1+ index))
-       (length (length v))
-       (circ (fasl-file-circularity-table file)))
-      ((= index length)
-       (dump-fop* length lisp::fop-small-vector lisp::fop-vector file))
-    (let* ((obj (aref v index))
-	   (ref (gethash obj circ)))
-      (cond (ref
-	     (push (make-circularity :type :svset  :object v  :index index
-				     :value obj  :enclosing-object ref)
-		   *circularities-detected*)
-	     (sub-dump-object nil file))
-	    (t
-	     (sub-dump-object obj file))))))
-
-;;; Dump a string.
-
-(defun dump-string (s file)
-  (let ((length (length s)))
-    (dump-fop* length lisp::fop-small-string lisp::fop-string file)
-    (dotimes (i length)
-      (dump-byte (char-code (char s i)) file))))
-
-;;; Dump-Array  --  Internal
-;;;
-;;;    Dump a multi-dimensional array.  Someday when we figure out what
-;;; a displaced array looks like, we can fix this.
-;;;
-(defun dump-array (array file)
-  (declare (ignore array file))
-  (compiler-error "Can't dump arrays, bozo.")
-  (dump-fop 'lisp::fop-misc-trap file))
-
-#|
-(
-  (unless (zerop (%primitive header-ref array %array-displacement-slot))
-    (compiler-error
-     "Attempt to dump an array with a displacement, you lose big."))
-  (let ((rank (array-rank array)))
-    (dotimes (i rank)
-      (dump-integer (array-dimension array i) file))
-    (sub-dump-object (%primitive header-ref array %array-data-slot) file)
-    (dump-fop 'lisp::fop-array file)
-    (quick-dump-number rank 4 file)))
-
-|#
-
-;;; Dump-I-Vector  --  Internal  
-;;;
-;;;    Dump an I-Vector using the Guy Steele memorial fasl-operation.
-;;;
-(defun dump-i-vector (vec file)
-  (declare (ignore vec file))
-  (compiler-error "Can't dump i-vectors, bozo.")
-  (dump-fop 'lisp::fop-misc-trap file))
-
-#|
-  (let* ((len (length vec))
-	 (ac (%primitive get-vector-access-code
-			 (if #-new-compiler (%primitive complex-array-p vec)
-			     #+new-compiler (array-header-p vec)
-			     (%primitive header-ref vec %array-data-slot)
-			     vec)))
-	 (size (ash 1 ac))
-	 (count (ceiling size 8))
-	 (ints-per-entry (floor (* count 8) size)))
-    (declare (fixnum len ac size count ints-per-entry))
-    (dump-fop 'lisp::fop-int-vector file)
-    (quick-dump-number len 4 file)
-    (dump-byte size file)
-    (dump-byte count file)
-    (if (> ints-per-entry 1)
-	(do ((prev 0 end)
-	     (end ints-per-entry (the fixnum (+ end ints-per-entry))))
-	    ((>= end len)
-	     (unless (= prev len)
-	       (do ((pos (* (1- ints-per-entry) size) (- pos size))
-		    (idx prev (1+ idx))
-		    (res 0))
-		   ((= idx len)
-		    (dump-byte res file))
-		 (setq res (dpb (aref vec idx) (byte size pos) res)))))
-	  (declare (fixnum prev end))
-	  (do* ((idx prev (1+ idx))
-		(res 0))
-	       ((= idx end)
-		(dump-byte res file))
-	    (declare (fixnum idx))
-	    (setq res (logior (ash res size) (aref vec idx)))))
-	(dotimes (i len)
-	  (declare (fixnum i))
-	  (quick-dump-number (aref vec i) count file)))))
-|#
-
-
-;;; Dump a character.
-
-(defun dump-character (ch file)
-  (cond
-   ((string-char-p ch)
-    (dump-fop 'lisp::fop-short-character file)
-    (dump-byte (char-code ch) file))
-   (t
-    (dump-fop 'lisp::fop-character file)
-    (dump-byte (char-code ch) file)
-    (dump-byte (char-bits ch) file)
-    (dump-byte (char-font ch) file))))
-
-
-;;; Dump a structure.
-
-(defun dump-structure (obj file)
-  (dump-vector obj file)
-  (dump-fop 'lisp::fop-structure file))
-
diff --git a/compiler/entry.lisp b/compiler/entry.lisp
deleted file mode 100644
index f9b772acd21f5f264457b43dabfc0dbfd0fe154c..0000000000000000000000000000000000000000
--- a/compiler/entry.lisp
+++ /dev/null
@@ -1,73 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    Code in this file handles VM-independent details of run-time
-;;; function representation that primarily concern IR2 conversion and the
-;;; dumper/loader. 
-;;; 
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-
-;;; Entry-Analyze  --  Interface
-;;;
-;;;    This phase runs before IR2 conversion, assigning each XEP a Entry-Info
-;;; structure.  We call the VM-supplied Select-Component-Format function to
-;;; make VM-dependent initializations in the IR2-Component.  This includes
-;;; setting the IR2-Component-Kind and allocating fixed implementation overhead
-;;; in the constant pool.
-;;;
-(defun entry-analyze (component)
-  (let ((2comp (component-info component)))
-    (dolist (fun (component-lambdas component))
-      (when (external-entry-point-p fun)
-	(let ((info (compute-entry-info fun)))
-	  (setf (leaf-info fun) info)
-	  (push info (ir2-component-entries 2comp))))))
-
-  (select-component-format component)
-  (undefined-value))
-
-
-;;; Make-Arg-Names  --  Internal
-;;;
-;;;    Takes the list representation of the debug arglist and turns it into a
-;;; string.
-;;;
-(defun make-arg-names (x)
-  (declare (type functional x))
-  (let ((args (functional-arg-documentation x)))
-    (assert (not (eq args :unspecified)))
-    (if (null args)
-	"()"
-	(let ((*print-pretty* t)
-	      (*print-escape* t)
-	      (*print-base* 10)
-	      (*print-radix* nil)
-	      (*print-case* :downcase))
-	  (write-to-string args)))))
-  
-
-;;; Compute-Entry-Info  --  Internal
-;;;
-;;;    Return the an Entry-Info structure corresponding to the XEP lambda Fun.
-;;;
-(defun compute-entry-info (fun)
-  (declare (type clambda fun))
-  (let ((block (node-block (lambda-bind fun)))
-	(internal-fun (functional-entry-function fun)))
-    (make-entry-info
-     :closure-p (not (null (environment-closure (lambda-environment fun))))
-     :offset (block-label block)
-     :name (let ((name (leaf-name internal-fun)))
-	     (or name
-		 (component-name (block-component block))))
-     :arguments (make-arg-names internal-fun)
-     :type (type-specifier (definition-type internal-fun)))))
diff --git a/compiler/envanal.lisp b/compiler/envanal.lisp
deleted file mode 100644
index 9a891b693bbb215061fce01e61ffaeb80bb94529..0000000000000000000000000000000000000000
--- a/compiler/envanal.lisp
+++ /dev/null
@@ -1,319 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    The environment analysis phase for the compiler.  This phase annotates
-;;; IR1 with a hierarchy environment structures, determining the environment
-;;; that each Lambda allocates its variables and finding what values are closed
-;;; over by each environment.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-
-;;; Environment-Analyze  --  Interface
-;;;
-;;;    Do environment analysis on the code in Component.  This involves various
-;;; things:
-;;;  1] Make an Environment structure for each non-let lambda, assigning the
-;;;     lambda-environment for all lambdas.
-;;;  2] Find all values that need to be closed over by each environment.
-;;;  3] Find any unreferenced variables in the lambdas in the component.
-;;;  4] Scan the blocks in the component closing over non-local-exit
-;;;     continuations.
-;;;
-(defun environment-analyze (component)
-  (declare (type component component))
-  (assert (not (component-new-functions component)))
-  (dolist (fun (component-lambdas component))
-    (let ((res (make-environment :function fun)))
-      (setf (lambda-environment fun) res)
-      (dolist (lambda (lambda-lets fun))
-	(setf (lambda-environment lambda) res))))
-  
-  (dolist (fun (component-lambdas component))
-    (compute-closure fun)
-    (dolist (let (lambda-lets fun))
-      (compute-closure let)))
-  
-  (find-non-local-exits component)
-  (find-cleanup-points component)
-  (tail-annotate component)
-  (undefined-value))
-
-
-;;; Compute-Closure  --  Internal
-;;;
-;;;    Find any variables in Fun with references outside of the home
-;;; environment and close over them.  If a closed over variable is set, then we
-;;; set the Indirect flag so that we will know the closed over value is really
-;;; a pointer to the value cell.  We also warn about unreferenced variables
-;;; here, just because it's a convenient place to do it.
-;;;
-(defun compute-closure (fun)
-  (declare (type clambda fun))
-  (let ((env (lambda-environment fun)))
-    (dolist (var (lambda-vars fun))
-      (unless (or (leaf-ever-used var)
-		  (lambda-var-ignorep var))
-	(let ((*compiler-error-context* (lambda-bind fun)))
-	  (compiler-warning "Variable ~S defined but never used."
-			    (leaf-name var))))
-      
-      (dolist (ref (leaf-refs var))
-	(let ((ref-env (node-environment ref)))
-	  (unless (eq ref-env env)
-	    (when (lambda-var-sets var)
-	      (setf (lambda-var-indirect var) t))
-	    (close-over var ref-env env))))
-      
-      (dolist (set (basic-var-sets var))
-	(let ((set-env (node-environment set)))
-	  (unless (eq set-env env)
-	    (setf (lambda-var-indirect var) t)
-	    (close-over var set-env env))))))
-  
-  (undefined-value))
-
-
-;;; Close-Over  --  Internal
-;;;
-;;;    Make sure that Thing is closed over in Ref-Env and in all environments
-;;; for the functions that reference Ref-Env's function (not just calls.)
-;;; Home-Env is Thing's home environment.  When we reach the home environment,
-;;; we stop propagating the closure.
-;;;
-(defun close-over (thing ref-env home-env)
-  (declare (type environment ref-env home-env))
-  (cond ((eq ref-env home-env))
-	((member thing (environment-closure ref-env)))
-	(t
-	 (push thing (environment-closure ref-env))
-	 (dolist (call (leaf-refs (environment-function ref-env)))
-	   (close-over thing (node-environment call) home-env))))
-  (undefined-value))
-
-
-;;; Find-NLX-Cleanup  --  Internal
-;;;
-;;;    Given an Exit node, return the associated cleanup.  We do this by
-;;; scanning up the cleanups from the ending cleanup of the Entry's block,
-;;; looking for an :Entry cleanup whose mess-up is Entry.
-;;;
-;;; If the previous cleanup was a :Catch or :Unwind-Protect, then we return the
-;;; previous cleanup instead, since we want to return the catch or UWP cleanup
-;;; when that is what the exit really represents.  This assumes that the :Catch
-;;; or :Unwind-Protect cleanup is always nested immediately inside the
-;;; corresponding Entry cleanup, and that the catch or UWP mess-up is always
-;;; converted in the same block as the Entry.
-;;;
-(defun find-nlx-cleanup (exit)
-  (declare (type exit exit))
-  (let ((entry (exit-entry exit)))
-    (let ((cleanup (find-enclosing-cleanup
-		    (block-end-cleanup (node-block entry))))
-	  (return-prev nil))
-      (loop
-	(ecase (cleanup-kind cleanup)
-	  (:special-bind
-	   (assert (not return-prev)))
-	  (:entry
-	   (when (eq (continuation-use (cleanup-start cleanup)) entry)
-	     (return (or return-prev cleanup)))
-	   (setq return-prev nil))
-	  ((:catch :unwind-protect)
-	   (setq return-prev cleanup)))
-	(setq cleanup (find-enclosing-cleanup (cleanup-enclosing cleanup)))))))
-
-
-;;; Insert-NLX-Entry-Stub  --  Internal
-;;;
-;;;    Insert the entry stub before the original exit target, and add a new
-;;; entry to the Environment-Nlx-Info.  The %NLX-Entry call in the stub is
-;;; passed the NLX-Info as an argument so that the back end knows what entry is
-;;; being done.
-;;;
-;;; The link from the Exit block to the entry stub is changed to be a lonk to
-;;; the component head.  This leaves the entry stub reachable, but makes the
-;;; flow graph less confusing to flow analysis.
-;;;
-;;; The ending cleanup of the entry stub is set to the enclosing cleanup for
-;;; the entry's cleanup, since this represents the dynamic state that was saved
-;;; at mess-up point.  It may be that additional local cleanups need to be done
-;;; before actually transferring control to the destination.
-;;;
-(defun insert-nlx-entry-stub (exit env)
-  (declare (type environment env) (type exit exit))
-  (let* ((exit-block (node-block exit))
-	 (next-block (first (block-succ exit-block)))
-	 (cleanup (find-nlx-cleanup exit))
-	 (info (make-nlx-info :cleanup cleanup
-			      :continuation (node-cont exit)))
-	 (new-block (insert-cleanup-code exit-block next-block
-					 (exit-entry exit)
-					 `(%nlx-entry ',info))))
-    (unlink-blocks exit-block new-block)
-    (link-blocks (component-head (block-component new-block)) new-block)
-    
-    (setf (nlx-info-target info) new-block)
-    (push info (environment-nlx-info env))
-    (push info (cleanup-nlx-info cleanup))
-    (setf (block-end-cleanup new-block) (cleanup-enclosing cleanup)))
-
-  (undefined-value))
-
-
-;;; Note-Non-Local-Exit  --  Internal
-;;;
-;;;    Do stuff necessary to represent a non-local exit from the node Exit into
-;;; Env.  This is called for each non-local exit node, of which there may be
-;;; several per exit continuation.  This is what we do:
-;;; -- If there isn't any NLX-Info entry in the environment, make an entry
-;;;    stub, otherwise just unlink the exit block from its successor. 
-;;; -- Close over the NLX-Info in the exit environment.
-;;; -- If the exit is from an :Escape function, then substitute a constant
-;;;    reference to NLX-Info structure for the escape function reference.  This
-;;;    will cause the escape function to be deleted (although not removed from
-;;;    the DFO.)  The escape function is no longer needed, and we don't want to
-;;;    emit code for it.
-;;;
-(defun note-non-local-exit (env exit)
-  (declare (type environment env) (type exit exit))
-  (let ((entry (exit-entry exit))
-	(cont (node-cont exit))
-	(exit-fun (lambda-home (block-lambda (node-block exit)))))
-
-    (if (find-nlx-info entry cont)
-	(let ((block (node-block exit)))
-	  (assert (= (length (block-succ block)) 1))
-	  (unlink-blocks block (first (block-succ block))))
-	(insert-nlx-entry-stub exit env))
-
-    (let ((info (find-nlx-info entry cont)))
-      (assert info)
-      (close-over info (node-environment exit) env)
-      (when (eq (functional-kind exit-fun) :escape)
-	(substitute-leaf (find-constant info) exit-fun))))
-
-  (undefined-value))
-
-
-;;; Find-Non-Local-Exits  --  Internal
-;;;
-;;;    Iterate over the blocks in Component, calling Note-Non-Local-Exit when
-;;; we find a block that ends in a non-local Exit node.  We also ensure that
-;;; all Exit nodes are either non-local or degenerate by calling
-;;; IR1-Optimize-Exit on local exits.  This makes life simpler for later
-;;; phases.
-;;;
-(defun find-non-local-exits (component)
-  (declare (type component component))
-  (do-blocks (block component)
-    (let ((last (block-last block)))
-      (when (exit-p last)
-	(let ((target-env (lambda-environment
-			   (block-lambda (first (block-succ block)))))) 
-	    (if (eq (node-environment last) target-env)
-		(unless *converting-for-interpreter*
-		  (maybe-delete-exit last))
-		(note-non-local-exit target-env last))))))
-
-  (undefined-value))
-
-
-;;; Emit-Cleanups  --  Internal
-;;;
-;;;    Zoom up the Cleanup-Enclosing thread until we hit Cleanup1, accumulating
-;;; cleanup code as we go.  When we are done, convert the cleanup code in an
-;;; implicit MV-Prog1.  We have to force local call analysis of new references
-;;; to Unwind-Protect cleanup functions.
-;;;
-;;;    If we don't actually have to do anything, then we don't insert any
-;;; cleanup code.  In this case, we set Block1's End-Cleanup to be the
-;;; Start-Cleanup for block2 to indicate that no cleanup is necessary.
-;;;
-(defun emit-cleanups (block1 block2)
-  (declare (type cblock block1 block2))
-  (collect ((code)
-	    (reanalyze-funs))
-    (let ((cleanup2 (find-enclosing-cleanup (block-start-cleanup block2))))
-      (do ((cleanup (find-enclosing-cleanup (block-end-cleanup block1))
-		    (find-enclosing-cleanup (cleanup-enclosing cleanup))))
-	  ((eq cleanup cleanup2))
-	(let* ((node (continuation-use (cleanup-start cleanup)))
-	       (args (when (basic-combination-p node)
-		       (basic-combination-args node))))
-	  (ecase (cleanup-kind cleanup)
-	    (:special-bind
-	     (code `(%special-unbind ',(continuation-value (first args)))))
-	    (:catch
-	     (code `(%catch-breakup)))
-	    (:unwind-protect
-	     (code `(%unwind-protect-breakup))
-	     (let ((fun (ref-leaf (continuation-use (second args)))))
-	       (reanalyze-funs fun)
-	       (code `(%funcall ,fun))))
-	    (:entry
-	     (dolist (nlx (cleanup-nlx-info cleanup))
-	       (code `(%lexical-exit-breakup ',nlx)))))))
-
-      (cond ((code)
-	     (let ((block (insert-cleanup-code block1 block2
-					       (block-last block1)
-					       `(progn ,@(code)))))
-	       (setf (block-end-cleanup block) cleanup2))
-	     (dolist (fun (reanalyze-funs))
-	       (local-call-analyze-1 fun)))
-	    (t
-	     (setf (block-end-cleanup block1) cleanup2)))))
-
-  (undefined-value))
-
-
-;;; Find-Cleanup-Points  --  Internal
-;;;
-;;;    Loop over the blocks in component, calling Emit-Cleanups when we see a
-;;; successor in the same environment with a different cleanup.  
-;;;
-(defun find-cleanup-points (component)
-  (declare (type component component))
-  (do-blocks (block1 component)
-    (let ((env1 (lambda-environment (block-lambda block1)))
-	  (cleanup1 (find-enclosing-cleanup (block-end-cleanup block1))))
-      (dolist (block2 (block-succ block1))
-	(let ((fun2 (block-lambda block2)))
-	  (when fun2
-	    (let ((env2 (lambda-environment fun2)))
-	      (when (and (eq env2 env1)
-			 (not (eq (find-enclosing-cleanup
-				   (block-start-cleanup block2))
-				  cleanup1)))
-		(emit-cleanups block1 block2))))))))
-  (undefined-value))
-
-
-;;; Tail-Annotate  --  Internal
-;;;
-;;;    Mark all tail-recursive uses of function result continuations with the
-;;; corresponding tail-set.  Nodes whose type is NIL (i.e. don't return) such
-;;; as calls to ERROR are never annotated as tail, so as to preserve debugging
-;;; information.
-;;;
-(defun tail-annotate (component)
-  (declare (type component component))
-  (dolist (fun (component-lambdas component))
-    (let ((ret (lambda-return fun)))
-      (when ret
-	(let ((result (return-result ret))
-	      (tails (lambda-tail-set fun)))
-	  (do-uses (use result)
-	    (when (and (immediately-used-p result use)
-		       (not (eq (node-derived-type use) *empty-type*)))
-	      (setf (node-tail-p use) tails)))))))
-  (undefined-value))
diff --git a/compiler/eval-comp.lisp b/compiler/eval-comp.lisp
deleted file mode 100644
index 375eb005bbec7bc873fc94484571bd393c6fe6d8..0000000000000000000000000000000000000000
--- a/compiler/eval-comp.lisp
+++ /dev/null
@@ -1,294 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; This file represents the current state of on-going development on compiler
-;;; hooks for an interpreter that takes the compiler's IR1 of a program.
-;;;
-;;; Written by Bill Chiles.
-;;;
-
-(in-package "C")
-
-(proclaim '(special *constants* *free-variables* *compile-component*
-		    *code-vector* *next-location* *result-fixups*
-		    *free-functions* *source-paths* *failed-optimizations*
-		    *seen-blocks* *seen-functions* *list-conflicts-table*
-		    *continuation-number* *continuation-numbers*
-		    *number-continuations* *tn-id* *tn-ids* *id-tns*
-		    *label-ids* *label-id* *id-labels* *sb-list*
-		    *unknown-functions* *compiler-error-count*
-		    *compiler-warning-count* *compiler-note-count*
-		    *compiler-error-output* *compiler-error-bailout*
-		    *compiler-trace-output*
-		    *last-source-context* *last-original-source*
-		    *last-source-form* *last-format-string* *last-format-args*
-		    *last-message-count* *check-consistency*
-		    *all-components* *converting-for-interpreter*
-		    *source-info* *block-compile* *current-path*
-		    *current-component* *fenv*))
-
-(export '(compile-for-eval lambda-eval-info-frame-size
-	  lambda-eval-info-args-passed lambda-eval-info-entries
-	  lambda-eval-info-function entry-node-info-st-top
-	  entry-node-info-nlx-tag))
-
-
-;;; COMPILE-FOR-EVAL -- Public.
-;;;
-;;; This translates form into the compiler's IR1 and performs environment
-;;; analysis.  It is sort of a combination of NCOMPILE-FILE, SUB-COMPILE-FILE,
-;;; COMPILE-TOP-LEVEL, and COMPILE-COMPONENT.
-;;;
-(defun compile-for-eval (form quietly)
-  (with-ir1-namespace
-    (let* ((*block-compile* nil)
-	   (*fenv* ())
-	   ;;
-	   (*compiler-error-output*
-	    (if quietly
-		(make-broadcast-stream)
-		*error-output*))
-	   (*compiler-trace-output* nil)
-	   (*compiler-error-bailout*
-	    #'(lambda () (error "Fatal error, aborting evaluation.")))
-	   ;;
-	   (*last-source-context* nil)
-	   (*last-original-source* nil)
-	   (*last-source-form* nil)
-	   (*last-format-string* nil)
-	   (*last-format-args* nil)
-	   (*last-message-count* 0)
-	   ;;
-	   (*unknown-functions* nil)
-	   (*compiler-error-count* 0)
-	   (*compiler-warning-count* 0)
-	   (*compiler-note-count* 0)
-	   (*source-info* (make-lisp-source-info form)))
-      (clear-stuff)
-      (find-source-paths form 0)
-      ;;
-      ;; This LET comes from COMPILE-TOP-LEVEL.
-      ;; The noted DOLIST is a splice from a call that COMPILE-TOP-LEVEL makes.
-      (let* ((*converting-for-interpreter* t)
-	     (lambdas (list (ir1-top-level form 0 t))))
-	(declare (list lambdas))
-	(dolist (lambda lambdas)
-	  (let* ((component
-		  (block-component (node-block (lambda-bind lambda))))
-		 (*all-components* (list component)))
-	    (local-call-analyze component)))
-	(let* ((components (find-initial-dfo lambdas))
-	       (*all-components* components))
-	  (when *check-consistency*
-	    (maybe-mumble "[Check]~%")
-	    (check-ir1-consistency components))
-	  ;;
-	  ;; This DOLIST body comes from the beginning of COMPILE-COMPONENT.
-	  (dolist (component components)
-	    (let ((*compile-component* component))
-	      (maybe-mumble "Env ")
-	      (environment-analyze component))
-	    (annotate-component-for-eval component))
-	  (when *check-consistency*
-	    (maybe-mumble "[Check]~%")
-	    (check-ir1-consistency components)))
-	(ir1-finalize)
-	(car lambdas)))))
-
-
-;;;; Annotating IR1 for interpretation.
-
-(defstruct (lambda-eval-info (:print-function print-lambda-eval-info)
-			     (:constructor make-lambda-eval-info
-					   (frame-size args-passed entries)))
-  frame-size		;Number of stack locations needed to hold locals.
-  args-passed		;Number of referenced arguments passed to lambda.
-  entries		;A-list mapping entry nodes to stack locations.
-  (function nil))	;A function object corresponding to this lambda.
-
-(defun print-lambda-eval-info (obj str n)
-  (declare (ignore n obj))
-  (format str "#<Lambda-eval-info>"))
-
-(defstruct (entry-node-info (:print-function print-entry-node-info)
-			    (:constructor make-entry-node-info
-					  (st-top nlx-tag)))
-  st-top	;Stack top when we encounter the entry node.
-  nlx-tag)	;Tag to which to throw to get back entry node's context.
-
-(defun print-entry-node-info (obj str n)
-  (declare (ignore n obj))
-  (format str "#<Entry-node-info>"))
-
-
-;;; Some compiler funny functions have definitions, so the interpreter can
-;;; call them.  These require special action to coordinate the interpreter,
-;;; system call stack, and the environment.  The annotation prepass marks the
-;;; references to these as :unused, so the interpreter doesn't try to fetch
-;;; function's through these undefined symbols.
-;;;
-(defconstant undefined-funny-funs
-  '(%special-bind %special-unbind %more-arg-context %unknown-values %catch
-    %unwind-protect %catch-breakup %unwind-protect-breakup %lexical-exit-breakup
-    %continue-unwind %nlx-entry))
-
-;;; Some kinds of functions are only passed as arguments to funny functions,
-;;; and are never actually evaluated at run time.
-;;;
-(defconstant non-closed-function-kinds '(:cleanup :escape))
-
-;;; ANNOTATE-COMPONENT-FOR-EVAL -- Internal.
-;;;
-;;; This annotates continuations, lambda-vars, and lambdas.  For each
-;;; continuation, we cache how its destination uses its value.  This only buys
-;;; efficiency when the code executes more than once, but the overhead of this
-;;; part of the prepass for code executed only once should be negligible.
-;;;
-;;; As a special case to aid interpreting local function calls, we sometimes
-;;; note the continuation as :unused.  This occurs when there is a local call,
-;;; and there is no actual function object to call; we mark the continuation as
-;;; :unused since there is nothing to push on the interpreter's stack.
-;;; Normally we would see a reference to a function that we would push on the
-;;; stack to later pop and apply to the arguments on the stack.  To determine
-;;; when we have a local call with no real function object, we look at the node
-;;; to see if it is a reference with a destination that is a :local combination
-;;; whose function is the reference node's continuation.
-;;;
-;;; After checking for virtual local calls, we check for funny functions the
-;;; compiler refers to for calling to note certain operations.  These functions
-;;; are undefined, and if the interpreter tried to reference the function cells
-;;; of these symbols, it would get an error.  We mark the continuations
-;;; delivering the values of these references as :unused, so the reference
-;;; never takes place.
-;;;
-;;; For each lambda-var, including a lambda's vars and its let's vars, we note
-;;; the stack offset used to access and store that variable.  Then we note the
-;;; lambda with the total number of variables, so we know how big its stack
-;;; frame is.  Also in the lambda's info is the number of its arguments that it
-;;; actually references; the interpreter never pushes or pops an unreferenced
-;;; argument, so we can't just use LENGTH on LAMBDA-VARS to know how many args
-;;; the caller passed.
-;;;
-;;; For each entry node in a lambda, we associate in the lambda-eval-info the
-;;; entry node with a stack offset.  Evaluation code stores the frame pointer
-;;; in this slot upon processing the entry node to aid stack cleanup and
-;;; correct frame manipulation when processing exit nodes.
-;;;
-(defun annotate-component-for-eval (component)
-  (do-blocks (b component)
-    (do-nodes (node cont b)
-      (let* ((dest (continuation-dest cont))
-	     (refp (typep node 'ref))
-	     (leaf (if refp (ref-leaf node))))
-	(setf (continuation-info cont)
-	      (cond ((and refp dest (typep dest 'basic-combination)
-			  (eq (basic-combination-kind dest) :local)
-			  (eq (basic-combination-fun dest) cont))
-		     :unused)
-		    ((and leaf (typep leaf 'global-var)
-			  (eq (global-var-kind leaf) :global-function)
-			  (member (c::global-var-name leaf) undefined-funny-funs
-				  :test #'eq))
-		     :unused)
-		    ((and leaf (typep leaf 'clambda)
-			  (member (functional-kind leaf)
-				  non-closed-function-kinds))
-		     (assert (not (eq (functional-kind leaf) :escape)))
-		     :unused)
-		    (t
-		     (typecase dest
-		       ;; Change locations in eval.lisp that think :return could
-		       ;; occur.
-		       ((or mv-combination creturn exit) :multiple)
-		       (null :unused)
-		       (t :single))))))))
-  (dolist (lambda (component-lambdas component))
-    (let ((locals-count 0)
-	  (args-passed-count 0))
-      (dolist (var (lambda-vars lambda))
-	(setf (leaf-info var) locals-count)
-	(incf locals-count)
-	(when (leaf-refs var) (incf args-passed-count)))
-      (dolist (let (lambda-lets lambda))
-	(dolist (var (lambda-vars let))
-	  (setf (leaf-info var) locals-count)
-	  (incf locals-count)))
-      (let ((entries nil))
-	(dolist (e (lambda-entries lambda))
-	  (ecase (process-entry-node-p e)
-	    (:blow-it-off)
-	    (:local-lexical-exit
-	     (push (cons e (make-entry-node-info locals-count nil))
-		   entries)
-	     (incf locals-count))
-	    (:non-local-lexical-exit
-	     (push (cons e
-			 (make-entry-node-info locals-count (incf locals-count)))
-		   entries)
-	     (incf locals-count))))
-	(setf (lambda-info lambda)
-	      (make-lambda-eval-info locals-count args-passed-count
-				     entries))))))
-
-;;; PROCESS-ENTRY-NODE-P -- Internal.
-;;; 
-(defun process-entry-node-p (entry)
-  (dolist (nlx (environment-nlx-info (node-environment entry))
-	       :local-lexical-exit)
-    (let ((cleanup (nlx-info-cleanup nlx)))
-      (ecase (cleanup-kind cleanup)
-	(:entry
-	 (when (eq (continuation-use (cleanup-start cleanup))
-		   entry)
-	   (return :non-local-lexical-exit)))
-	((:catch :unwind-protect)
-	 (when (eq (continuation-use (cleanup-start (cleanup-enclosing cleanup)))
-		   entry)
-	   (return :blow-it-off)))))))
-
-
-;;; Sometime consider annotations to exclude processign of exit nodes when
-;;; we want to do a tail-p thing.
-;;;
-
-
-;;;; Defining funny functions for interpreter.
-
-#|
-%listify-rest-args %more-arg %verify-argument-count %argument-count-error
-%odd-keyword-arguments-error %unknown-keyword-argument-error
-|#
-
-(defun %verify-argument-count (supplied-args defined-args)
-  (unless (= supplied-args defined-args)
-    (error "Wrong argument count, wanted ~D and got ~D."
-	   defined-args supplied-args)))
-
-(defun %throw (tag &rest args)
-  (throw tag (values-list args)))
-
-(defun %more-arg (args index)
-  (nth index args))
-
-(defun %listify-rest-args (ptr count)
-  (declare (ignore count))
-  ptr)
-
-(defun %argument-count-error (args-passed-count)
-  (error "Wrong number of arguments passed -- ~S." args-passed-count))
-
-(defun %odd-keyword-arguments-error ()
-  (error "Function called with odd number of keyword arguments."))
-
-(defun %unknown-keyword-argument-error (keyword)
-  (error "Unknown keyword argument -- ~S." keyword))
-
-(defun %progv (vars vals fun)
-  (progv vars vals
-    (funcall fun)))
diff --git a/compiler/eval.lisp b/compiler/eval.lisp
deleted file mode 100644
index 8d0fe6ab1570620cfeb61ea550194bd3e58ddf05..0000000000000000000000000000000000000000
--- a/compiler/eval.lisp
+++ /dev/null
@@ -1,1205 +0,0 @@
-;;; -*- Package: eval; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; This file contains the interpreter.  We first convert to the compiler's
-;;; IR1 and interpret that.
-;;;
-;;; Written by Bill Chiles.
-;;;
-(in-package "EVAL")
-
-(export '(internal-eval *eval-stack-trace* *internal-apply-node-trace*
-			*interpreted-function-cache-minimum-size*
-			*interpreted-function-cache-threshold*
-			trace-eval interpreted-function-p
-			interpreted-function-lambda-expression
-			interpreted-function-closure
-			interpreted-function-name
-			interpreted-function-arglist
-			make-interpreted-function))
-
-
-;;;; Interpreter stack.
-
-(defvar *eval-stack* (make-array 100)
-  "This is the interpreter's evaluation stack.")
-(defvar *eval-stack-top* 0
-  "This is the next free element of the interpreter's evaluation stack.")
-
-;;; Setting this causes the stack operations to dump a trace.
-;;;
-(defvar *eval-stack-trace* nil)
-
-
-;;; EVAL-STACK-PUSH -- Internal.
-;;;
-;;; Push value on *eval-stack*, growing the stack if necessary.  This returns
-;;; value.  We save *eval-stack-top* in a local and increment the global before
-;;; storing value on the stack to prevent a GC timing problem.  If we stored
-;;; value on the stack using *eval-stack-top* as an index, and we GC'ed before
-;;; incrementing *eval-stack-top*, then INTERPRETER-GC-HOOK would clear the
-;;; location.
-;;;
-(defun eval-stack-push (value)
-  (let ((len (length (the simple-vector *eval-stack*))))
-    (when (= len *eval-stack-top*)
-      (when *eval-stack-trace* (format t "[PUSH: growing stack.]~%"))
-      (let ((new-stack (make-array (ash len 1))))
-	(replace new-stack *eval-stack* :end1 len :end2 len)
-	(setf *eval-stack* new-stack))))
-  (let ((top *eval-stack-top*))
-    (when *eval-stack-trace* (format t "pushing ~D.~%" top))
-    (incf *eval-stack-top*)
-    (setf (svref *eval-stack* top) value)))
-
-;;; EVAL-STACK-POP -- Internal.
-;;;
-;;; This returns the last value pushed on *eval-stack* and decrements the top
-;;; pointer.  We forego setting elements off the end of the stack to nil for GC
-;;; purposes because there is a *before-gc-hook* to take care of this for us.
-;;; However, because of the GC hook, we must be careful to grab the value
-;;; before decrementing *eval-stack-top* since we could GC between the
-;;; decrement and the reference, and the hook would clear the stack slot.
-;;;
-(defun eval-stack-pop ()
-  (when (zerop *eval-stack-top*)
-    (error "Attempt to pop empty eval stack."))
-  (let* ((new-top (1- *eval-stack-top*))
-	 (value (svref *eval-stack* new-top)))
-    (when *eval-stack-trace* (format t "popping ~D --> ~S.~%" new-top value))
-    (setf *eval-stack-top* new-top)
-    value))
-
-;;; EVAL-STACK-EXTEND -- Internal.
-;;;
-;;; This allocates n locations on the stack, bumping the top pointer and
-;;; growing the stack if necessary.  We set new slots to nil in case we GC
-;;; before having set them; we don't want to hold on to potential garbage
-;;; from old stack fluctuations.
-;;;
-(defun eval-stack-extend (n)
-  (let ((len (length (the simple-vector *eval-stack*))))
-    (when (> (+ n *eval-stack-top*) len)
-      (when *eval-stack-trace* (format t "[EXTEND: growing stack.]~%"))
-      (let ((new-stack (make-array (+ n (ash len 1)))))
-	(replace new-stack *eval-stack* :end1 len :end2 len)
-	(setf *eval-stack* new-stack))))
-  (let ((new-top (+ *eval-stack-top* n)))
-  (when *eval-stack-trace* (format t "extending to ~D.~%" new-top))
-    (do ((i *eval-stack-top* (1+ i)))
-	((= i new-top))
-      (setf (svref *eval-stack* i) nil))
-    (setf *eval-stack-top* new-top)))
-
-;;; EVAL-STACK-SHRINK -- Internal.
-;;;
-;;; The anthesis of EVAL-STACK-EXTEND.
-;;;
-(defun eval-stack-shrink (n)
-  (when *eval-stack-trace*
-    (format t "shrinking to ~D.~%" (- *eval-stack-top* n)))
-  (decf *eval-stack-top* n))
-
-;;; EVAL-STACK-SET-TOP -- Internal.
-;;;
-;;; This is used to shrink the stack back to a previous frame pointer.
-;;;
-(defun eval-stack-set-top (ptr)
-  (when *eval-stack-trace* (format t "setting top to ~D.~%" ptr))
-  (setf *eval-stack-top* ptr))
-
-
-;;; EVAL-STACK-LOCAL -- Internal.
-;;;
-;;; This returns a local variable from the current stack frame.  This is used
-;;; for references the compiler represents as a lambda-var leaf.  This is a
-;;; macro for SETF purposes.
-;;;
-(defmacro eval-stack-local (fp offset)
-  `(svref *eval-stack* (+ ,fp ,offset)))
-
-
-;;;; Interpreted functions:
-
-(defstruct (eval-function
-	    (:print-function
-	     (lambda (s stream d)
-	       (declare (ignore d))
-	       (format stream "#<EVAL-FUNCTION ~S>"
-		       (eval-function-name s)))))
-  ;;
-  ;; The name of this interpreted function, or NIL if none specified.
-  (name nil)
-  ;;
-  ;; This function's debug arglist.
-  (arglist nil)
-  ;;
-  ;; A lambda that can be converted to get the definition.
-  (lambda nil)
-  ;;
-  ;; If this function has been converted, then this is the XEP.  If this is
-  ;; false, then the function is not in the cache (or is in the process of
-  ;; being removed.)
-  (definition nil :type (or c::clambda null))
-  ;;
-  ;; The number of consequtive GCs that this function has been unused.  This is
-  ;; used to control cache replacement.
-  (gcs 0 :type c::index)
-  ;;
-  ;; True if Lambda has been converted at least once, and thus warnings should
-  ;; be suppressed on additional conversions.
-  (converted-once nil))
-
-
-(defvar *interpreted-function-cache-minimum-size* 25
-  "If the interpreted function cache has more functions than this come GC time,
-  then attempt to prune it according to
-  *INTERPRETED-FUNCTION-CACHE-THRESHOLD*.")
-
-(defvar *interpreted-function-cache-threshold* 3
-  "If an interpreted function goes uncalled for more than this many GCs, then
-  it is eligible for flushing from the cache.")
-
-(proclaim '(type c::index
-		 *interpreted-function-cache-minimum-size*
-		 *interpreted-function-cache-threshold*))
-
-
-;;; The list of EVAL-FUNCTIONS that have translated definitions.
-;;;
-(defvar *interpreted-function-cache* nil)
-(proclaim '(type list *interpreted-function-cache*))
-
-
-;;; MAKE-INTERPRETED-FUNCTION  --  Interface
-;;;
-;;;    Return a function that will lazily convert Lambda when called, and will
-;;; cache translations.
-;;;
-(defun make-interpreted-function (lambda)
-  (let ((eval-fun (make-eval-function :lambda lambda)))
-    #'(lambda (&rest args)
-	(let ((fun (eval-function-definition eval-fun))
-	      (args (cons (length args) args)))
-	  (setf (eval-function-gcs eval-fun) 0)
-	  (internal-apply (or fun (convert-eval-fun eval-fun))
-			  args '#())))))
-
-
-;;; GET-EVAL-FUNCTION  --  Internal
-;;;
-(defun get-eval-function (x)
-  (let ((res (system:find-if-in-closure #'eval-function-p x)))
-    (assert res)
-    res))
-
-
-;;; CONVERT-EVAL-FUN  --  Internal
-;;;
-;;;    Eval a FUNCTION form, grab the definition and stick it in.
-;;;
-(defun convert-eval-fun (eval-fun)
-  (declare (type eval-function eval-fun))
-  (let* ((new (eval-function-definition
-	       (get-eval-function
-		(internal-eval `#',(eval-function-lambda eval-fun)
-			       (eval-function-converted-once eval-fun))))))
-    (setf (eval-function-definition eval-fun) new)
-    (setf (eval-function-converted-once eval-fun) t)
-    (push eval-fun *interpreted-function-cache*)
-    new))
-
-
-;;; INTERPRETED-FUNCTION-LAMDBA-EXPRESSION  --  Interface
-;;;
-;;;    Get the CLAMBDA for the XEP, then look at the inline expansion info in
-;;; the real function.
-;;;
-(defun interpreted-function-lambda-expression (x)
-  (let* ((eval-fun (get-eval-function x))
-	 (lambda (eval-function-lambda eval-fun)))
-    (if lambda
-	(values lambda nil (eval-function-name eval-fun))
-	(let ((fun (c::functional-entry-function
-		    (eval-function-definition eval-fun))))
-	  (values (c::functional-inline-expansion fun)
-		  (if (or (c::functional-fenv fun)
-			  (c::functional-venv fun)
-			  (c::functional-benv fun)
-			  (c::functional-tenv fun))
-		      t nil)
-		  (or (eval-function-name eval-fun)
-		      (c::component-name
-		       (c::block-component
-			(c::node-block (c::lambda-bind fun))))))))))
-
-
-;;; INTERPRETED-FUNCTION-{NAME,ARGLIST}  --  Interface
-;;;
-(defun interpreted-function-name (x)
-  (multiple-value-bind (ig1 ig2 res)
-		       (interpreted-function-lambda-expression x)
-    (declare (ignore ig1 ig2))
-    res))
-;;;
-(defun (setf interpreted-function-name) (x val)
-  (setf (eval-function-name (get-eval-function x)) val))
-;;;
-(defun interpreted-function-arglist (x)
-  (eval-function-arglist (get-eval-function x)))
-;;;
-(defun (setf interpreted-function-arglist) (x val)
-  (setf (eval-function-arglist (get-eval-function x)) val))
-
-
-;;; INTERPRETED-FUNCTION-ENVIRONMENT  --  Interface
-;;;
-;;;    The environment should be the only SIMPLE-VECTOR in the closure.  We
-;;; have to throw in the EVAL-FUNCTION-P test, since structure are currently
-;;; also SIMPLE-VECTORs.
-;;;
-(defun interpreted-function-closure (x)
-  (system:find-if-in-closure #'(lambda (x)
-				 (and (simple-vector-p x)
-				      (not (eval-function-p x))))
-			     x))
-
-
-;;; INTERPRETER-GC-HOOK  --  Internal
-;;;
-;;;    Clear the unused portion of the eval stack, and flush the definitions of
-;;; all functions in the cache that haven't been used enough.
-;;;
-(defun interpreter-gc-hook ()
-  (let ((len (length (the simple-vector *eval-stack*))))
-    (do ((i *eval-stack-top* (1+ i)))
-	((= i len))
-      (setf (svref *eval-stack* i) nil)))
-
-  (let ((num (- (length *interpreted-function-cache*)
-		*interpreted-function-cache-minimum-size*)))
-    (when (plusp num)
-      (setq *interpreted-function-cache*
-	    (delete-if #'(lambda (x)
-			   (when (>= (eval-function-gcs x)
-				     *interpreted-function-cache-threshold*)
-			     (setf (eval-function-definition x) nil)
-			     t))
-		       *interpreted-function-cache*
-		       :count num))))
-
-  (dolist (fun *interpreted-function-cache*)
-    (incf (eval-function-gcs fun))))
-;;;
-(pushnew 'interpreter-gc-hook ext:*before-gc-hooks*)
-
-
-
-;;;; INTERNAL-APPLY-LOOP macros.
-
-;;; These macros are intimately related to INTERNAL-APPLY-LOOP.  They assume
-;;; variables established by this function, and they assume they can return
-;;; from a block by that name.  This is sleazy, but we justify it as follows:
-;;; They are so specialized in use, and their invocation became lengthy, that
-;;; we allowed them to slime some access to things in their expanding
-;;; environment.  These macros don't really extend our Lisp syntax, but they do
-;;; provide some template expansion service; it is these cleaner circumstance
-;;; that require a more rigid programming style.
-;;;
-;;; Since these are macros expanded almost solely for c::combination nodes,
-;;; they cascade from the end of this logical page to the beginning here.
-;;; Therefore, it is best you start looking at them from the end of this
-;;; section, backwards from normal scanning mode for Lisp code.
-;;;
-
-;;; DO-COMBINATION -- Internal.
-;;;
-;;; This runs a function on some arguments from the stack.  If the combination
-;;; occurs in a tail recursive position, then we do the call such that we
-;;; return from tail-p-function with whatever values the call produces.  With a
-;;; :local call, we have to restore the stack to its previous frame before
-;;; doing the call.  The :full call mechanism does this for us.  If it is NOT a
-;;; tail recursive call, and we're in a multiple value context, then then push
-;;; a list of the returned values.  Do the same thing if we're in a :return
-;;; context.  Push a single value, without listifying it, for a :single value
-;;; context.  Otherwise, just call for side effect.
-;;;
-;;; Node is the combination node, and cont is its continuation.  Frame-ptr
-;;; is the current frame pointer, and closure is the current environment for
-;;; closure variables.  Call-type is either :full or :local, and when it is
-;;; local, lambda is the IR1 lambda to apply.
-;;;
-;;; This assumes the following variables are present: node, cont, frame-ptr,
-;;; and closure.  It also assumes a block named internal-apply-loop.
-;;;
-(defmacro do-combination (call-type lambda mv-or-normal)
-  (let* ((args (gensym))
-	 (calling-closure (gensym))
-	 (invoke-fun (ecase mv-or-normal
-		       (:mv-call 'mv-internal-invoke)
-		       (:normal 'internal-invoke)))
-	 (args-form (ecase mv-or-normal
-		      (:mv-call
-		       `(mv-eval-stack-args
-			 (length (c::mv-combination-args node))))
-		      (:normal
-		       `(eval-stack-args (c:lambda-eval-info-args-passed
-					  (c::lambda-info ,lambda))))))
-	 (call-form (ecase call-type
-		      (:full `(,invoke-fun
-			       (length (c::basic-combination-args node))))
-		      (:local `(internal-apply
-				,lambda ,args-form
-				(compute-closure node ,lambda frame-ptr
-						 closure)))))
-	 (tailp-call-form
-	  (ecase call-type
-	    (:full `(return-from
-		     internal-apply-loop
-		     ;; INVOKE-FUN takes care of the stack itself.
-		     (,invoke-fun (length (c::basic-combination-args node))
-				  frame-ptr)))
-	    (:local `(let ((,args ,args-form)
-			   (,calling-closure
-			    (compute-closure node ,lambda frame-ptr closure)))
-		       ;; No need to clean up stack slots for GC due to
-		       ;; ext:*before-gc-hook*.
-		       (eval-stack-set-top frame-ptr)
-		       (return-from
-			internal-apply-loop 
-			(internal-apply ,lambda ,args ,calling-closure)))))))
-    `(cond ((c::node-tail-p node)
-	    ,tailp-call-form)
-	   (t
-	    (ecase (c::continuation-info cont)
-	      ((:multiple :return)
-	       (eval-stack-push (multiple-value-list ,call-form)))
-	      (:single
-	       (eval-stack-push ,call-form))
-	      (:unused ,call-form))))))
-
-;;; SET-BLOCK -- Internal.
-;;;
-;;; This sets the variable block in INTERNAL-APPLY-LOOP, and it announces this
-;;; by setting set-block-p for later loop iteration maintenance.
-;;;
-(defmacro set-block (exp)
-  `(progn
-     (setf block ,exp)
-     (setf set-block-p t)))
-
-;;; CHANGE-BLOCKS -- Internal.
-;;;
-;;; This sets all the iteration variables in INTERNAL-APPLY-LOOP to iterate
-;;; over a new block's nodes.  Block-exp is optional because sometimes we have
-;;; already set block, and we only need to bring the others into agreement.
-;;; If we already set block, then clear the variable that announces this,
-;;; set-block-p.
-;;;
-(defmacro change-blocks (&optional block-exp)
-  `(progn
-     ,(if block-exp
-	  `(setf block ,block-exp)
-	  `(setf set-block-p nil))
-     (setf node (c::continuation-next (c::block-start block)))
-     (setf last-cont (c::node-cont (c::block-last block)))))
-
-
-;;; This controls printing visited nodes in INTERNAL-APPLY-LOOP.  We use it
-;;; here, and INTERNAL-INVOKE uses it to print function call looking output
-;;; to further describe c::combination nodes.
-;;;
-(defvar *internal-apply-node-trace* nil)
-;;;
-(defun maybe-trace-funny-fun (node name &rest args)
-  (when *internal-apply-node-trace*
-    (format t "(~S ~{ ~S~})  c~S~%"
-	    name args (c::cont-num (c::node-cont node)))))
-
-
-;;; DO-FUNNY-FUNCTION -- Internal.
-;;;
-;;; This implements the intention of the virtual function name.  This is a
-;;; macro because some of these actions must occur without a function call.
-;;; For example, calling a dispatch function to implement special binding would
-;;; be a no-op because returning from that function would cause the system to
-;;; undo any special bindings it established.
-;;;
-;;; NOTE: update C:ANNOTATE-COMPONENT-FOR-EVAL and/or c::undefined-funny-funs
-;;; if you add or remove branches in this routine.
-;;;
-;;; This assumes the following variables are present: node, cont, frame-ptr,
-;;; args, closure, block, and last-cont.  It also assumes a block named
-;;; internal-apply-loop.
-;;;
-(defmacro do-funny-function (funny-fun-name)
-  (let ((name (gensym)))
-    `(let ((,name ,funny-fun-name))
-       (ecase ,name
-	 (c::%special-bind
-	  (let ((value (eval-stack-pop))
-		(global-var (eval-stack-pop)))
-	    (maybe-trace-funny-fun node ,name global-var value)
-	    (system:%primitive bind value (c::global-var-name global-var))))
-	 (c::%special-unbind
-	  ;; Throw away arg telling me which special, and tell the dynamic
-	  ;; binding mechanism to unbind one variable.
-	  (eval-stack-pop)
-	  (maybe-trace-funny-fun node ,name)
-	  (system:%primitive unbind 1))
-	 (c::%catch
-	  (let* ((tag (eval-stack-pop))
-		 (nlx-info (eval-stack-pop))
-		 (fell-through-p nil)
-		 ;; Ultimately THROW and CATCH will fix the interpreter's stack
-		 ;; since this is necessary for compiled CATCH's and those in
-		 ;; the initial top level function.
-		 (stack-top *eval-stack-top*)
-		 (values
-		  (multiple-value-list
-		   (catch tag
-		     (maybe-trace-funny-fun node ,name tag)
-		     (multiple-value-setq (block node cont last-cont)
-		       (internal-apply-loop (c::continuation-next cont)
-					    frame-ptr lambda args closure))
-		     (setf fell-through-p t)))))
-	    (cond (fell-through-p
-		   ;; We got here because we just saw the C::%CATCH-BREAKUP
-		   ;; funny function inside the above recursive call to
-		   ;; INTERNAL-APPLY-LOOP.  Therefore, we just received and
-		   ;; stored the current state of evaluation for falling
-		   ;; through.
-		   )
-		  (t
-		   ;; Fix up the interpreter's stack after having thrown here.
-		   ;; We won't need to do this in the final implementation.
-		   (eval-stack-set-top stack-top)
-		   ;; Take the values received in the list bound above, and
-		   ;; massage them into the form expected by the continuation
-		   ;; of the non-local-exit info.
-		   (ecase (c::continuation-info
-			   (c::nlx-info-continuation nlx-info))
-		     (:single
-		      (eval-stack-push (car values)))
-		     ((:multiple :return)
-		      (eval-stack-push values))
-		     (:unused))
-		   ;; We want to continue with the code after the CATCH body.
-		   ;; The non-local-exit info tells us where this is, but we
-		   ;; know that block only contains a call to the funny
-		   ;; function C::%NLX-ENTRY, which simply is a place holder
-		   ;; for the compiler IR1.  We want to skip the target block
-		   ;; entirely, so we say it is the block we're in now and say
-		   ;; the current cont is the last-cont.  This makes the COND
-		   ;; at the end of INTERNAL-APPLY-LOOP do the right thing.
-		   (setf block (c::nlx-info-target nlx-info))
-		   (setf cont last-cont)))))
-	 (c::%unwind-protect
-	  ;; Cleanup function not pushed due to special-case :UNUSED
-	  ;; annotation in ANNOTATE-COMPONENT-FOR-EVAL.
-	  (let* ((nlx-info (eval-stack-pop))
-		 (fell-through-p nil)
-		 (stack-top *eval-stack-top*))
-	    (unwind-protect
-		(progn
-		  (maybe-trace-funny-fun node ,name)
-		  (multiple-value-setq (block node cont last-cont)
-		    (internal-apply-loop (c::continuation-next cont)
-					 frame-ptr lambda args closure))
-		  (setf fell-through-p t))
-	      (cond (fell-through-p
-		     ;; We got here because we just saw the
-		     ;; C::%UNWIND-PROTECT-BREAKUP funny function inside the
-		     ;; above recursive call to INTERNAL-APPLY-LOOP.
-		     ;; Therefore, we just received and stored the current
-		     ;; state of evaluation for falling through.
-		     )
-		    (t
-		     ;; Fix up the interpreter's stack after having thrown here.
-		     ;; We won't need to do this in the final implementation.
-		     (eval-stack-set-top stack-top)
-		     ;;
-		     ;; Push some bogus values for exit context to keep the
-		     ;; MV-BIND in the UNWIND-PROTECT translation happy. 
-		     (eval-stack-push '(nil nil 0))
-		     (let ((node (c::continuation-next
-				  (c::block-start
-				   (car (c::block-succ
-					 (c::nlx-info-target nlx-info)))))))
-		       (internal-apply-loop node frame-ptr lambda args
-					    closure)))))))
-	 ((c::%catch-breakup c::%unwind-protect-breakup c::%continue-unwind)
-	  ;; This shows up when we locally exit a CATCH body -- fell through.
-	  ;; Return the current state of evaluation to the previous invocation
-	  ;; of INTERNAL-APPLY-LOOP which happens to be running in the
-	  ;; c::%catch branch of this code.
-	  (maybe-trace-funny-fun node ,name)
-	  (return-from internal-apply-loop
-		       (values block node cont last-cont)))
-	 (c::%nlx-entry
-	  (maybe-trace-funny-fun node ,name)
-	  ;; This just marks a spot in the code for CATCH, UNWIND-PROTECT, and
-	  ;; non-local lexical exits (GO or RETURN-FROM).
-	  ;; Do nothing since c::%catch does it all when it catches a THROW.
-	  ;; Do nothing since c::%unwind-protect does it all when
-	  ;; it catches a THROW.
-	  )
-	 (c::%more-arg-context
-	  (let* ((fixed-arg-count (1+ (eval-stack-pop)))
-		 ;; Add 1 to actual fixed count for extra arg expected by
-		 ;; external entry points (XEP) which some IR1 lambdas have.
-		 ;; The extra arg is the number of arguments for arg count
-		 ;; consistency checking.  C::%MORE-ARG-CONTEXT always runs
-		 ;; within an XEP, so the lambda has an extra arg.
-		 (more-args (nthcdr fixed-arg-count args)))
-	    (maybe-trace-funny-fun node ,name fixed-arg-count)
-	    (assert (eq (c::continuation-info cont) :multiple))
-	    (eval-stack-push (list more-args (length more-args)))))
-	 (c::%unknown-values
-	  (error "C::%UNKNOWN-VALUES should never be in interpreter's IR1."))
-	 (c::%lexical-exit-breakup
-	  ;; We see this whenever we locally exit the extent of a lexical
-	  ;; target.  That is, we are truly locally exiting an extent we could
-	  ;; have non-locally lexically exited.  Return the :fell-through flag
-	  ;; and the current state of evaluation to the previous invocation
-	  ;; of INTERNAL-APPLY-LOOP which happens to be running in the
-	  ;; c::entry branch of INTERNAL-APPLY-LOOP.
-	  (maybe-trace-funny-fun node ,name)
-	  (return-from internal-apply-loop
-		       (values :fell-through block node cont last-cont)))))))
-
-
-;;; COMBINATION-NODE -- Internal.
-;;;
-;;; This expands for the two types of combination nodes INTERNAL-APPLY-LOOP
-;;; sees.  Type is either :mv-call or :normal.  Node is the combination node,
-;;; and cont is its continuation.  Frame-ptr is the current frame pointer, and
-;;; closure is the current environment for closure variables.
-;;;
-;;; Most of the real work is done by DO-COMBINATION.  This first determines if
-;;; the combination node describes a :full call which DO-COMBINATION directly
-;;; handles.  If the call is :local, then we either invoke an IR1 lambda, or we
-;;; just bind some LET variables.  If the call is :local, and type is :mv-call,
-;;; then we can only be binding multiple values.  Otherwise, the combination
-;;; node describes a function known to the compiler, but this may be a funny
-;;; function that actually isn't ever defined.  We either take some action for
-;;; the funny function or do a :full call on the known true function, but the
-;;; interpreter doesn't do optimizing stuff for functions known to the
-;;; compiler.
-;;;
-;;; This assumes the following variables are present: node, cont, frame-ptr,
-;;; and closure.  It also assumes a block named internal-apply-loop.
-;;;
-(defmacro combination-node (type)
-  (let* ((kind (gensym))
-	 (fun (gensym))
-	 (lambda (gensym))
-	 (letp (gensym))
-	 (letp-bind (ecase type
-		      (:mv-call nil)
-		      (:normal
-		       `((,letp (eq (c::functional-kind ,lambda) :let))))))
-	 (local-branch
-	  (ecase type
-	    (:mv-call
-	     `(store-mv-let-vars ,lambda frame-ptr
-				 (length (c::mv-combination-args node))))
-	    (:normal
-	     `(if ,letp
-		  (store-let-vars ,lambda frame-ptr)
-		  (do-combination :local ,lambda ,type))))))
-    `(let ((,kind (c::basic-combination-kind node))
-	   (,fun (c::basic-combination-fun node)))
-       (cond ((eq ,kind :full)
-	      (do-combination :full nil ,type))
-	     ((eq ,kind :local)
-	      (let* ((,lambda (c::ref-leaf (c::continuation-use ,fun)))
-		     ,@letp-bind)
-		,local-branch))
-	     ((eq (c::continuation-info ,fun) :unused)
-	      (assert (typep ,kind 'c::function-info))
-	      (do-funny-function (c::continuation-function-name ,fun)))
-	     (t
-	      (assert (typep ,kind 'c::function-info))
-	      (do-combination :full nil ,type))))))
-
-
-(defun trace-eval (on)
-  (setf *eval-stack-trace* on)
-  (setf *internal-apply-node-trace* on))
-
-
-;;;; INTERNAL-EVAL:
-
-(proclaim '(special lisp::*already-evaled-this*))
-
-;;; INTERNAL-EVAL  --  Interface
-;;;
-;;;    Evaluate an arbitary form.  We convert the form, then call internal
-;;; apply on it.  If *ALREADY-EVALED-THIS* is true, then we bind it to NIL
-;;; around the apply to limit the inhibition to the lexical scope of the
-;;; EVAL-WHEN.
-;;;
-(defun internal-eval (form &optional quietly)
-  (let ((res (c:compile-for-eval form quietly)))
-    (if lisp::*already-evaled-this*
-	(let ((lisp::*already-evaled-this* nil))
-	  (internal-apply res nil nil))
-	(internal-apply res nil nil))))
-
-
-;;; MAKE-INDIRECT-VALUE-CELL -- Internal.
-;;;
-;;; Later this will probably be the same weird internal thing the compiler
-;;; makes to represent these things.
-;;;
-(defun make-indirect-value-cell (value)
-  (list value))
-;;;
-(defmacro indirect-value (value-cell)
-  `(car ,value-cell))
-
-
-;;; VALUE -- Internal.
-;;;
-;;; This passes on a node's value appropriately, possibly returning from
-;;; function to do so.  When we are tail-p, don't push the value, return it on
-;;; the system's actual call stack; when we blow out of function this way, we
-;;; must return the interpreter's stack to the its state before this call to
-;;; function.  When we're in a multiple value context or heading for a return
-;;; node, we push a list of the value for easier handling later.  Otherwise,
-;;; just push the value on the interpreter's stack.
-;;;
-(defmacro value (node info value frame-ptr function)
-  `(cond ((c::node-tail-p ,node)
-	  (eval-stack-set-top ,frame-ptr)
-	  (return-from ,function ,value))
-	 ((member ,info '(:multiple :return) :test #'eq)
-	  (eval-stack-push (list ,value)))
-	 (t (assert (eq ,info :single))
-	    (eval-stack-push ,value))))))
-
-
-(defun maybe-trace-nodes (node)
-  (when *internal-apply-node-trace*
-    (format t "<~A-node> c~S~%"
-	    (type-of node)
-	    (c::cont-num (c::node-cont node)))))
-
-;;; INTERNAL-APPLY -- Internal.
-;;;
-;;; This interprets lambda, a compiler IR1 data structure representing a
-;;; function, applying it to args.  Closure is the environment in which to run
-;;; lambda, the variables and such closed over to form lambda.  The call occurs
-;;; on the interpreter's stack, so save the current top and extend the stack
-;;; for this lambda's call frame.  Then store the args into locals on the
-;;; stack.
-;;;
-(defun internal-apply (lambda args closure)
-  (let ((frame-ptr *eval-stack-top*))
-    (eval-stack-extend (c:lambda-eval-info-frame-size (c::lambda-info lambda)))
-    (do ((vars (c::lambda-vars lambda) (cdr vars))
-	 (args args (cdr args)))
-	((null vars))
-      ;; Args may run out of values before vars runs out of variables, so
-      ;; just do CAR of nil and store nil.
-      (let ((var (car vars)))
-	(when (c::leaf-refs var)
-	  (setf (eval-stack-local frame-ptr (c::lambda-var-info var))
-		(if (c::lambda-var-indirect var)
-		    (make-indirect-value-cell (car args))
-		    (car args))))))
-    (internal-apply-loop (c::lambda-bind lambda) frame-ptr lambda args closure)))
-
-;;; INTERNAL-APPLY-LOOP -- Internal.
-;;;
-;;; This does the work of INTERNAL-APPLY.  This also calls itself recursively
-;;; for certain language features, such as CATCH.  First is the node at which
-;;; to start interpreting.  Frame-ptr is the current frame pointer for
-;;; accessing local variables.  Lambda is the IR1 lambda from which comes the
-;;; nodes a given call to this function processes, and closure is the
-;;; environment for interpreting lambda.  Args is the argument list for the
-;;; lambda given to INTERNAL-APPLY, and we have to carry it around with us
-;;; in case of more-arg or rest-arg processing which is represented explicitly
-;;; in the compiler's IR1.
-;;;
-;;; Due to having a truly tail recursive interpreter, some of the branches
-;;; handling a given node need to RETURN-FROM this routine.  Also, some calls
-;;; this makes to do work for it must occur in tail recursive positions.
-;;; Because of this required access to this function lexical environment and
-;;; calling positions, we often are unable to break off logical chunks of code
-;;; into functions.  We have written macros intended solely for use in this
-;;; routine, and due to all the local stuff they need to access and length
-;;; complex calls, we have written them to sleazily access locals from this
-;;; routine.  In addition to assuming a block named internal-apply-loop exists,
-;;; they set and reference the following variables: node, cont, frame-ptr,
-;;; closure, block, last-cont, and set-block-p.
-;;;
-(defun internal-apply-loop (first frame-ptr lambda args closure)
-  (let* ((block (c::node-block first))
-	 (last-cont (c::node-cont (c::block-last block)))
-	 (node first)
-	 (set-block-p nil))
-      (loop
-	(let ((cont (c::node-cont node)))
-	  (etypecase node
-	    (c::ref
-	     (maybe-trace-nodes node)
-	     (let ((info (c::continuation-info cont)))
-	       (unless (eq info :unused)
-		 (value node info (leaf-value node frame-ptr closure)
-			frame-ptr internal-apply-loop))))
-	    (c::combination
-	     (maybe-trace-nodes node)
-	     (combination-node :normal))
-	    (c::cif
-	     (maybe-trace-nodes node)
-	     ;; IF nodes always occur at the end of a block, so pick another.
-	     (set-block (if (eval-stack-pop)
-			    (c::if-consequent node)
-			    (c::if-alternative node))))
-	    (c::bind
-	     (maybe-trace-nodes node)
-	     ;; Ignore bind nodes since INTERNAL-APPLY extends the stack for
-	     ;; all of a lambda's locals, and the c::combination branch
-	     ;; handles LET binds (moving values off stack top into locals).
-	     )
-	    (c::cset
-	     (maybe-trace-nodes node)
-	     (let ((info (c::continuation-info cont))
-		   (res (set-leaf-value node frame-ptr closure
-					(eval-stack-pop))))
-	       (unless (eq info :unused)
-		 (value node info res frame-ptr internal-apply-loop))))
-	    (c::entry
-	     (maybe-trace-nodes node)
-	     (let ((info (cdr (assoc node (c:lambda-eval-info-entries
-					   (c::lambda-info lambda))))))
-	       ;; No info means no-op entry for CATCH or UNWIND-PROTECT.
-	       (when info
-		 ;; Store stack top for restoration in local exit situation
-		 ;; in c::exit branch.
-		 (setf (eval-stack-local frame-ptr
-					 (c:entry-node-info-st-top info))
-		       *eval-stack-top*)
-		 (let ((tag (c:entry-node-info-nlx-tag info)))
-		   (when tag
-		     ;; Non-local lexical exit (someone closed over a
-		     ;; GO tag or BLOCK name).
-		     (let ((unique-tag (cons nil nil))
-			   ;; Ultimately CATCH will handle the stack top
-			   ;; cleanup.
-			   (stack-top *eval-stack-top*)
-			   values)
-		       (setf (eval-stack-local frame-ptr tag) unique-tag)
-		       (if (eq cont last-cont)
-			   (change-blocks (car (c::block-succ block)))
-			   (setf node (c::continuation-next cont)))
-		       (loop
-			 (multiple-value-setq (values block node cont last-cont)
-			   (catch unique-tag
-			     (internal-apply-loop node frame-ptr
-						  lambda args closure)))
-			 (cond ((eq values :fell-through)
-				;; Interpreting state is set with MV-SETQ above.
-				;; Just get out of this branch and go on.
-				(return))
-			       ((eq values :non-local-go)
-				;; Ultimately do nothing here since CATCH would
-				;; have cleaned up the stack for us.
-				(eval-stack-set-top stack-top)
-				(setf node (c::continuation-next
-					    (car (c::block-succ block)))))
-			       (t
-				;; We know we're non-locally exiting from a
-				;; BLOCK with values (saw a RETURN-FROM).
-				;;
-				;; Ultimately do nothing here since CATCH would
-				;; have cleaned up the stack for us.
-				(eval-stack-set-top stack-top)
-				(ecase (c::continuation-info cont)
-				  (:single
-				   (eval-stack-push (car values)))
-				  ((:multiple :return)
-				   (eval-stack-push values))
-				  (:unused))
-				(setf cont last-cont)
-				(return))))))))))
-	    (c::exit
-	     (maybe-trace-nodes node)
-	     (let* ((incoming-values (c::exit-value node))
-		    (values (if incoming-values (eval-stack-pop))))
-	       (cond
-		((eq (c::lambda-environment lambda)
-		     (c::lambda-environment
-		      (c::block-lambda
-		       (c::continuation-block cont))))
-		 ;; Local exit.
-		 ;; Fixup stack top and massage values for destination.
-		 (eval-stack-set-top
-		  (eval-stack-local frame-ptr
-				    (c:entry-node-info-st-top
-				     (cdr (assoc (c::exit-entry node)
-						 (c:lambda-eval-info-entries
-						  (c::lambda-info lambda)))))))
-		 (ecase (c::continuation-info cont)
-		   (:single
-		    (assert incoming-values)
-		    (eval-stack-push (car values)))
-		   ((:multiple :return)
-		    (assert incoming-values)
-		    (eval-stack-push values))
-		   (:unused)))
-		(t
-		 (let ((info (c::find-nlx-info (c::exit-entry node) cont)))
-		   (throw
-		    (svref closure
-			   (position info
-				     (c::environment-closure
-				      (c::node-environment node))
-				     :test #'eq))
-		    (if incoming-values
-			(values values (c::nlx-info-target info) nil cont)
-			(values :non-local-go (c::nlx-info-target info)))))))))
-	    (c::creturn
-	     (maybe-trace-nodes node)
-	     (let ((values (eval-stack-pop)))
-	       (eval-stack-set-top frame-ptr)
-	       (return-from internal-apply-loop (values-list values))))
-	    (c::mv-combination
-	     (maybe-trace-nodes node)
-	     (combination-node :mv-call)))
-	  (cond ((not (eq cont last-cont))
-		 (setf node (c::continuation-next cont)))
-		;; Currently only the last node in a block causes this loop to
-		;; change blocks, so we never just go to the next node when
-		;; the current node's branch tried to change blocks.
-		(set-block-p
-		 (change-blocks))
-		(t
-		 ;; Cif nodes set the block for us, but other last nodes do not.
-		 (change-blocks (car (c::block-succ block)))))))
-    (eval-stack-set-top frame-ptr)))
-	
-
-;;; SET-LEAF-VALUE -- Internal.
-;;;
-;;; This sets a c::cset node's var to value, returning value.  When var is
-;;; local, we have to compare its home environment to the current one, node's
-;;; environment.  If they're the same, we check to see if the var is indirect,
-;;; and store the value on the stack or in the value cell as appropriate.
-;;; Otherwise, var is a closure variable, and since we're setting it, we know
-;;; it's location contains an indirect value object.
-;;;
-(defun set-leaf-value (node frame-ptr closure value)
-  (let ((var (c::set-var node)))
-    (typecase var
-      (c::global-var
-       (setf (symbol-value (c::global-var-name var)) value))
-      (c::lambda-var
-       (let ((env (c::node-environment node)))
-	 (cond
-	  ((not (eq (c::lambda-environment (c::lambda-var-home var))
-		    env))
-	   (setf (indirect-value
-		  (svref closure
-			 (position var (c::environment-closure env)
-				   :test #'eq)))
-		 value))
-	  ((c::lambda-var-indirect var)
-	   (setf (indirect-value
-		  (eval-stack-local frame-ptr (c::lambda-var-info var)))
-		 value))
-	  (t
-	   (setf (eval-stack-local frame-ptr (c::lambda-var-info var))
-		 value))))))))
-
-
-;;; LEAF-VALUE -- Internal.
-;;;
-;;; This figures out how to return a value for a ref node.  Leaf is the ref's
-;;; structure that tells us about the value, and it is one of the following
-;;; types:
-;;;    constant   -- It knows its own value.
-;;;    global-var -- It's either a value or function reference.  Get it right.
-;;;    local-var  -- This may on the stack or in the current closure, the
-;;; 		     environment for the lambda INTERNAL-APPLY is currently
-;;;		     executing.  If the leaf's home environment is the same
-;;;		     as the node's home environment, then the value is on the
-;;;		     stack, else it's in the closure since it came from another
-;;;		     environment.  Whether the var comes from the stack or the
-;;;		     closure, it could have come from a closure, and it could
-;;;		     have been closed over for setting.  When this happens, the
-;;;		     actual value is stored in an indirection object, so
-;;;		     indirect.  See COMPUTE-CLOSURE for the description of
-;;;		     the structure of the closure argument to this function.
-;;;    functional -- This is a reference to an interpreted function that may
-;;;		     be passed or called anywhere.  We return a real function
-;;;		     that calls INTERNAL-APPLY, closing over the leaf.  We also
-;;;		     have to compute a closure, running environment, for the
-;;;		     lambda in case it references stuff in the current
-;;;		     environment.  If the closure is empty and there is no
-;;;                  functional environment, then we use
-;;;                  MAKE-INTERPRETED-FUNCTION to make a cached translation.
-;;;                  Since it is too late to lazily convert, we set up the
-;;;                  EVAL-FUNCTION to be already converted. 
-;;;
-(defun leaf-value (node frame-ptr closure)
-  (let ((leaf (c::ref-leaf node)))
-    (typecase leaf
-      (c::constant
-       (c::constant-value leaf))
-      (c::global-var
-       (if (eq (c::global-var-kind leaf) :global-function)
-	   (let ((name (c::global-var-name leaf)))
-	     (if (symbolp name)
-		 (symbol-function name)
-		 (fdefinition name)))
-	   (symbol-value (c::global-var-name leaf))))
-      (c::lambda-var
-       (let* ((env (c::node-environment node))
-	      (temp
-	       (if (eq (c::lambda-environment (c::lambda-var-home leaf))
-		       env)
-		   (eval-stack-local frame-ptr (c::lambda-var-info leaf))
-		   (svref closure
-			  (position leaf (c::environment-closure env)
-				    :test #'eq)))))
-	 (if (c::lambda-var-indirect leaf)
-	     (indirect-value temp)
-	     temp)))
-      (c::functional
-       (let* ((calling-closure (compute-closure node leaf frame-ptr closure))
-	      (real-fun (c::functional-entry-function leaf))
-	      (arg-doc (c::functional-arg-documentation real-fun)))
-	 (cond ((c:lambda-eval-info-function (c::leaf-info leaf)))
-	       ((and (zerop (length calling-closure))
-		     (null (c::functional-fenv real-fun)))
-		(let* ((res (make-interpreted-function
-			     (c::functional-inline-expansion real-fun)))
-		       (eval-fun (get-eval-function res)))
-		  (push eval-fun *interpreted-function-cache*)
-		  (setf (eval-function-definition eval-fun) leaf)
-		  (setf (eval-function-converted-once eval-fun) t)
-		  (setf (eval-function-arglist eval-fun) arg-doc)
-		  (setf (eval-function-name eval-fun) (c::leaf-name real-fun))
-		  (setf (c:lambda-eval-info-function (c::leaf-info leaf)) res)
-		  res))
-	       (t
-		(let ((eval-fun (make-eval-function
-				 :definition leaf
-				 :name (c::leaf-name real-fun)
-				 :arglist arg-doc)))
-		  #'(lambda (&rest args)
-		      (declare (list args))
-		      (internal-apply (eval-function-definition eval-fun)
-				      (cons (length args) args)
-				      calling-closure))))))))))
-
-
-;;; COMPUTE-CLOSURE -- Internal.
-;;;
-;;; This computes a closure for a local call and for returned call'able closure
-;;; objects.  Sometimes the closure is a simple-vector of no elements.  Node
-;;; is either a reference node or a combination node.  Leaf is either the leaf
-;;; of the reference node or the lambda to internally apply for the combination
-;;; node.  Frame-ptr is the current frame pointer for fetching current values
-;;; to store in the closure.  Closure is the current closure, the currently
-;;; interpreting lambda's closed over environment.
-;;;
-;;; A computed closure is a vector corresponding to the list of closure
-;;; variables described in an environment.  The position of a lambda-var in
-;;; this closure list is the index into the closure vector of values.
-;;;
-;;; Functional-env is the environment description for leaf, the lambda for which
-;;; we're computing a closure.  This environment describes which of lambda's
-;;; vars we find in lambda's closure when it's running, versus finding them
-;;; on the stack.  For each lambda-var in the functional environment's closure
-;;; list, if the lambda-var's home environment is the current environment, then
-;;; get a value off the stack and store it in the closure we're computing.
-;;; Otherwise that lambda-var's value comes from somewhere else, but we have it
-;;; in our current closure, the environment we're running in as we compute this
-;;; new closure.  Find this value the same way we do in LEAF-VALUE, by finding
-;;; the lambda-var's position in the current environment's description of the
-;;; current closure.
-;;;
-(defun compute-closure (node leaf frame-ptr closure)
-  (let* ((current-env (c::node-environment node))
-	 (current-closure-vars (c::environment-closure current-env))
-	 (functional-env (c::lambda-environment leaf))
-	 (functional-closure-vars (c::environment-closure functional-env))
-	 (functional-closure (make-array (length functional-closure-vars))))
-    (do ((vars functional-closure-vars (cdr vars))
-	 (i 0 (1+ i)))
-	((null vars))
-      (let ((ele (car vars)))
-	(setf (svref functional-closure i)
-	      (etypecase ele
-		(c::lambda-var
-		 (if (eq (c::lambda-environment (c::lambda-var-home ele))
-			 current-env)
-		     (eval-stack-local frame-ptr (c::lambda-var-info ele))
-		     (svref closure
-			    (position ele current-closure-vars
-				      :test #'eq))))
-		(c::nlx-info
-		 (if (eq (c::lambda-environment
-			  (c::block-lambda (c::nlx-info-target ele)))
-			 current-env)
-		     (eval-stack-local
-		      frame-ptr
-		      (c:entry-node-info-nlx-tag
-		       (cdr (assoc ;; entry node for non-local extent
-			     (c::continuation-use
-			      (c::cleanup-start (c::nlx-info-cleanup ele)))
-			     (c::lambda-eval-info-entries
-			      (c::lambda-info
-			       ;; lambda INTERNAL-APPLY-LOOP tosses around.
-			       (c::environment-function
-				(c::node-environment node))))))))
-		     (svref closure
-			    (position ele current-closure-vars
-				      :test #'eq))))))))
-    functional-closure))
-
-;;; INTERNAL-INVOKE -- Internal.
-;;;
-;;; INTERNAL-APPLY uses this to invoke a function from the interpreter's stack
-;;; on some arguments also taken from the stack.  When tail-p is non-nil,
-;;; control does not return to INTERNAL-APPLY to further interpret the current
-;;; IR1 lambda, so INTERNAL-INVOKE must clean up the current interpreter's
-;;; stack frame.
-;;;
-(defun internal-invoke (arg-count &optional tailp)
-  (let ((args (eval-stack-args arg-count)) ;LET says this init form runs first.
-	(fun (eval-stack-pop)))
-    (when tailp (eval-stack-set-top tailp))
-    (when *internal-apply-node-trace*
-      (format t "(~S~{ ~S~})~%" fun args))
-    (apply fun args)))
-
-;;; MV-INTERNAL-INVOKE -- Internal.
-;;;
-;;; Almost just like INTERNAL-INVOKE.  We call MV-EVAL-STACK-ARGS, and our
-;;; function is in a list on the stack instead of simply on the stack.
-;;;
-(defun mv-internal-invoke (arg-count &optional tailp)
-  (let ((args (mv-eval-stack-args arg-count)) ;LET runs this init form first.
-	(fun (car (eval-stack-pop))))
-    (when tailp (eval-stack-set-top tailp))
-    (when *internal-apply-node-trace*
-      (format t "(~S~{ ~S~})~%" fun args))
-    (apply fun args)))
-
-
-;;; EVAL-STACK-ARGS -- Internal.
-;;;
-;;; This returns a list of the top arg-count elements on the interpreter's
-;;; stack.  This removes them from the stack.
-;;;
-(defun eval-stack-args (arg-count)
-  (let ((args nil))
-    (dotimes (i arg-count args)
-      (declare (ignore i))
-      (push (eval-stack-pop) args))))
-
-;;; MV-EVAL-STACK-ARGS -- Internal.
-;;;
-;;; This assumes the top count elements on interpreter's stack are lists.  This
-;;; returns a single list with all the elements from these lists.
-;;;
-(defun mv-eval-stack-args (count)
-  (if (= count 1)
-      (eval-stack-pop)
-      (let ((last (eval-stack-pop)))
-	(dotimes (i (1- count))
-	  (let ((next (eval-stack-pop)))
-	    (setf last
-		  (if next (nconc next last) last))))
-	last)))
-
-;;; STORE-LET-VARS -- Internal.
-;;;
-;;; This stores lambda's vars, stack locals, from values popped off the stack.
-;;; When a var has no references, the compiler computes IR1 such that the
-;;; continuation delivering the value for the unreference var appears unused.
-;;; Because of this, the interpreter drops the value on the floor instead of
-;;; saving it on the stack for binding, so we only pop a value when the var has
-;;; some reference.  INTERNAL-APPLY uses this for c::combination nodes
-;;; representing LET's.
-;;;
-;;; When storing the local, if it is indirect, then someone closes over it for
-;;; setting instead of just for referencing.  We then store an indirection cell
-;;; with the value, and the referencing code for locals knows how to get the
-;;; actual value.
-;;;
-(defun store-let-vars (lambda frame-ptr)
-  (let* ((vars (c::lambda-vars lambda))
-	 (args (eval-stack-args (count-if #'c::leaf-refs vars))))
-    (declare (list vars args))
-    (dolist (v vars)
-      (when (c::leaf-refs v)
-	(setf (eval-stack-local frame-ptr (c::lambda-var-info v))
-	      (if (c::lambda-var-indirect v)
-		  (make-indirect-value-cell (pop args))
-		  (pop args)))))))
-
-;;; STORE-MV-LET-VARS -- Internal.
-;;;
-;;; This is similar to STORE-LET-VARS, but the values for the locals appear on
-;;; the stack in a list due to forms that delivered multiple values to this
-;;; lambda/let.  Unlike STORE-LET-VARS, there is no control over the delivery
-;;; of a value for an unreferenced var, so we drop the corresponding value on
-;;; the floor when no one references it.  INTERNAL-APPLY uses this for
-;;; c::mv-combination nodes representing LET's.
-;;;
-(defun store-mv-let-vars (lambda frame-ptr count)
-  (assert (= count 1))
-  (let ((args (eval-stack-pop)))
-    (dolist (v (c::lambda-vars lambda))
-      (if (c::leaf-refs v)
-	  (setf (eval-stack-local frame-ptr (c::lambda-var-info v))
-		(if (c::lambda-var-indirect v)
-		    (make-indirect-value-cell (pop args))
-		    (pop args)))
-	  (pop args)))))
-
-#|
-;;; STORE-MV-LET-VARS -- Internal.
-;;;
-;;; This stores lambda's vars, stack locals, from multiple values stored on the
-;;; top of the stack in a list.  Since these values arrived multiply, there is
-;;; no control over the delivery of each value for an unreferenced var, so
-;;; unlike STORE-LET-VARS, we have values for variables never used.  We drop
-;;; the value corresponding to an unreferenced var on the floor.
-;;; INTERNAL-APPLY uses this for c::mv-combination nodes representing LET's.
-;;;
-;;; IR1 represents variables bound from multiple values in a list in the
-;;; opposite order of the values list.  We use STORE-MV-LET-VARS-AUX to recurse
-;;; down the vars list until we bottom out, storing values on the way back up
-;;; the recursion.  You must do this instead of NREVERSE'ing the args list, so
-;;; when we run out of values, we store nil's in the correct lambda-vars.
-;;;
-(defun store-mv-let-vars (lambda frame-ptr count)
-  (assert (= count 1))
-  (print  (c::lambda-vars lambda))
-  (store-mv-let-vars-aux frame-ptr (c::lambda-vars lambda) (eval-stack-pop)))
-;;;
-(defun store-mv-let-vars-aux (frame-ptr vars args)
-  (if vars
-      (let ((remaining-args (store-mv-let-vars-aux frame-ptr (cdr vars) args))
-	    (v (car vars)))
-	(when (c::leaf-refs v)
-	  (setf (eval-stack-local frame-ptr (c::lambda-var-info v))
-		(if (c::lambda-var-indirect v)
-		    (make-indirect-value-cell (car remaining-args))
-		    (car remaining-args))))
-	(cdr remaining-args))
-      args))
-|#
diff --git a/compiler/fndb.lisp b/compiler/fndb.lisp
deleted file mode 100644
index 4eca576073969d0c8aa6a9b9517acadabf7bb90a..0000000000000000000000000000000000000000
--- a/compiler/fndb.lisp
+++ /dev/null
@@ -1,1087 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    This file defines all the standard functions to be known functions.
-;;; Each function has type and side-effect information, and may also have IR1
-;;; optimizers.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-(in-package 'lisp)
-(import '(
-	  %aset
-	  %bitset
-	  %charset
-	  %primitive
-	  %put
-	  %rplaca
-	  %rplacd
-	  %sbitset
-	  %scharset
-	  %set-documentation
-	  %set-fdefinition
-	  %set-fill-pointer
-	  %setelt
-	  %setnth
-	  %sp-set-definition
-	  %sp-set-plist
-	  %standard-char-p
-	  %string-char-p
-	  %svset
-	  %typep
-	  %array-typep
-	  array-header-p
-	  double-float-p
-	  long-float-p
-	  short-float-p
-	  single-float-p
-	  string<*
-	  string>*
-	  string<=*
-	  string>=*
-	  string=*
-	  string/=*
-	  %sp-string-compare
-	  )
-	"C")
-
-(in-package 'c)
-
-#| Something to convert the old FNDEFS database into our format:
-
-(defun convert-defs (fin fout)
-  (with-open-file (sin fin)
-    (with-open-file (sout fout :direction :output :if-exists :new-version)
-      (loop
-       (do ((ch (read-char sin nil nil) (read-char sin nil nil)))
-	   ((or (not ch)
-		(not (or (char= ch #\tab) (char= ch #\newline) (char= ch #\space)
-			 (char= ch #\;))))
-	    (when ch
-	      (unread-char ch sin)))
-	 (when (char= ch #\;)
-	   (write-char ch sout)
-	   (write-line (read-line sin) sout)))
-       
-       (let ((form (read sin nil '*eof*)))
-	(when (eq form '*eof*) (return))
-	(if (atom form)
-	    (format t "Ignoring ~S~%" form)
-	    (case (car form)
-	      (built-in-sf)
-	      (built-in-fn
-	       (let* ((args (mapcar 'eval (rest form)))
-		      (name (first args))
-		      (nargs (second args))
-		      (flushable (third args))
-		      (result-type (fourth args))
-		      (result-fun (fifth args))
-		      (multiple (sixth args))
-		      (foldable (member 'clc::fold-transform
-					(get name 'clc::clc-transforms))))
-		 (unless (eq (symbol-package name) (symbol-package 'cons))
-		   (format t "~S not in Lisp package.~%" name))
-		 (format sout "(defknown ~S (" #|))|# name)
-		 (block punt
-		   (unless (fboundp name)
-		     (format t "~S not fbound.~%" name)
-		     (return-from punt))
-		   (let ((def (symbol-function name)))
-		     (unless (compiled-function-p def)
-		       (format t "~S not compiled." name)
-		       (return-from punt))
-		     (let ((arglist (read-from-string
-				     (%primitive header-ref def system:%function-arg-names-slot))))
-		       (multiple-value-bind (req opt restp ig1 keyp keys)
-					    (parse-lambda-list arglist)
-			 (declare (ignore ig1))
-			 (let* ((dmin (length req))
-				(dmax (if (or restp keyp) nil
-					  (+ dmin (length opt)))))
-			   (unless (eql dmin (if (listp nargs) (car nargs) nargs))
-			     (format t "~S: actual min-args ~D, defined ~S.~%"
-				     name dmin nargs))
-			   (unless (eql dmax (if (listp nargs) (cadr nargs) nargs))
-			     (format t "~S: actual max-args ~D, defined ~S.~%"
-				     name dmax nargs))
-			   (dotimes (i (length req))
-			     (format sout "t "))
-			   (when opt
-			     (format sout "&optional ")
-			     (dotimes (i (length opt))
-			       (format sout "t ")))
-			   (when restp
-			     (format sout "&rest t "))
-			   (when keyp
-			     (format sout "&key ")
-			     (dolist (key keys)
-			       (format sout "(~A t) "
-				       (cond ((symbolp key) key)
-					     ((symbolp (car key)) (car key))
-					     ((symbolp (caar key)) (caar key))
-					     (t
-					      (format t "Bizzare keyword spec: ~S~%" key)))))))))))
-		 (unless (eql nargs 0)
-		   (file-position sout (1- (file-position sout))))
-		 (format sout #|(|# ")" sout)
-
-		 (let ((rtype (if (eq result-type 'predicate)
-				  'boolean result-type)))
-		   (if multiple
-		       (format sout " (values ~S &rest t)" rtype)
-		       (format sout " ~S" rtype)))
-
-		 (cond
-		  (flushable
-		   (cond (foldable
-			  (write-string " (flushable foldable unsafe)" sout))
-			 (t
-			  (write-string " (flushable unsafe)" sout))))
-		  (t
-		   (when foldable
-		     (format t "Foldable but not flushable: ~S." name))))
-
-		 (when result-fun
-		   (format sout "~%  :derive-type '~S" result-fun))
-		 (format sout #|(|# ")~%")))
-	      (built-in-special)
-	      (t
-	       (format t "Ignoring ~S~%" form)))))))))
-
-|#
-
-
-;;;; Information for known functions:
-
-(defknown coerce (t type-specifier) t
-	  (movable foldable)			  ; Is defined to signal errors. 
-  :derive-type 'type-spec-arg2)
-
-(defknown type-of (t) t (foldable flushable))
-
-
-;;;; In the "Predicates" chapter:
-
-(defknown typep (t type-specifier) boolean (foldable flushable))
-(defknown subtypep (type-specifier type-specifier) (values boolean boolean)
-	  (foldable flushable))
-
-(defknown (null symbolp atom consp listp numberp integerp rationalp floatp
-		complexp characterp stringp bit-vector-p vectorp
-		simple-vector-p simple-string-p simple-bit-vector-p arrayp
-		packagep functionp compiled-function-p commonp not)
-  (t) boolean (movable foldable flushable))
-
-
-(defknown (eq eql) (t t) boolean (movable foldable flushable))
-(defknown (equal equalp) (t t) boolean (foldable flushable))
-
-
-;;;; In the "Control Structure" chapter:
-
-;;; Not flushable, since required to signal an error if unbound.
-(defknown (symbol-value symbol-function) (symbol) t ())
-
-(defknown boundp (symbol) boolean (flushable))
-(defknown fboundp ((or symbol cons)) boolean (flushable))
-(defknown special-form-p (symbol) t (movable foldable flushable)) ; They never change...
-(defknown set (symbol t) t (unsafe)
-  :derive-type 'result-type-arg2)
-(defknown fdefinition ((or symbol cons)) function)
-(defknown %set-fdefinition ((or symbol cons) function) function)
-(defknown makunbound (symbol) symbol)
-(defknown fmakunbound ((or symbol cons)) (or symbol cons))
-(defknown (get-setf-method get-setf-method-multiple-value)
-  ((or list symbol) &optional lexical-environment)
-  (values list list list form form)
-  (flushable))
-(defknown apply (callable t &rest t) *)		  ; ### Last arg must be List...
-(defknown funcall (callable &rest t) *)
-
-(defknown (mapcar maplist mapcan mapcon) (callable list &rest list) list (call))
-
-(defknown (mapc mapl) (callable list &rest list) list
-  (foldable call unsafe))				    ; Returns arg...
-
-(defknown values (&rest t) * (movable foldable flushable unsafe))
-(defknown values-list (list) * (movable foldable flushable unsafe))
-
-
-;;;; In the "Macros" chapter:
-
-(defknown macro-function (symbol) (or function null) (flushable))
-(defknown (macroexpand macroexpand-1)
-  (t &optional lexical-environment) (values form &optional boolean))
-
-
-;;;; In the "Declarations" chapter:
-
-(defknown proclaim (list) void)
-
-
-;;;; In the "Symbols" chapter:
-
-(defknown get (symbol t &optional t) t (flushable))
-(defknown remprop (symbol t) t)
-(defknown symbol-plist (symbol) list (flushable))
-(defknown getf (list t &optional t) t (foldable flushable))
-(defknown get-properties (list list) (values t t list) (foldable flushable))
-(defknown symbol-name (symbol) simple-string (movable foldable flushable))
-(defknown make-symbol (string) symbol (flushable))
-(defknown copy-symbol (symbol &optional t) symbol (flushable))
-(defknown gensym (&optional (or string unsigned-byte)) symbol ())
-(defknown gentemp (&optional string package) symbol)
-(defknown symbol-package (symbol) (or package null) (flushable))
-(defknown keywordp (t) boolean (flushable))	  ; If someone uninterns it...
-
-
-;;;; In the "Packages" chapter:
-
-(deftype packagelike () '(or stringlike package))
-(deftype symbols () '(or list symbol))
-(defknown make-package (stringlike &key (use list) (nicknames list)
-				   ;; ### Extensions...
-				   (internal-symbols index) (external-symbols index))
-	  package)
-(defknown in-package (stringlike &key (nicknames list) (use list)) void)
-(defknown find-package (stringlike) (or package null) (flushable))
-(defknown package-name (package) simple-string (flushable))
-(defknown package-nicknames (package) list (flushable))
-(defknown rename-package (package stringlike &optional list) void)
-(defknown package-use-list (package) list (flushable))
-(defknown package-used-by-list (package) list (flushable))
-(defknown package-shadowing-symbols (package) list (flushable))
-(defknown list-all-packages () list (flushable))
-(defknown intern (string &optional packagelike)
-  (values symbol (member :internal :external nil))
-  ())
-(defknown find-symbol (string &optional packagelike)
-	  (values symbol (member :internal :external nil))
-	  (flushable))
-(defknown (export import) (symbols &optional packagelike) truth)
-(defknown unintern (symbol &optional packagelike) boolean)
-(defknown unexport (symbols &optional packagelike) truth)
-(defknown (shadowing-import shadow) (symbols &optional packagelike) truth)
-(defknown (use-package unuse-package) ((or list packagelike) &optional packagelike) truth)
-(defknown find-all-symbols (stringlike) list (flushable))
-(defknown provide (stringlike) void)
-(defknown require (stringlike &optional filename) void)
-
-
-;;;; In the "Numbers" chapter:
-
-(defknown zerop (number) boolean (movable foldable flushable))
-(defknown (plusp minusp) (real) boolean (movable foldable flushable))
-(defknown (oddp evenp) (integer) boolean (movable foldable flushable))
-(defknown (= /=) (number &rest number) boolean (movable foldable flushable))
-(defknown (< > <= >=) (real &rest real) boolean (movable foldable flushable))
-(defknown (max min) (real &rest real) real (movable foldable flushable)
-  :derive-type 'numeric-result-type)
-(defknown + (&rest number) number (movable foldable flushable)
-  :derive-type 'numeric-result-type)
-(defknown - (number &rest number) number (movable foldable flushable)
-  :derive-type 'numeric-result-type)
-(defknown * (&rest number) number (movable foldable flushable)
-  :derive-type 'numeric-result-type)
-(defknown / (number &rest number) number (movable foldable flushable)
-  :derive-type '/-result-type)
-(defknown (1+ 1-) (number) number (movable foldable flushable))
-(defknown conjugate (number) number (movable foldable flushable))
-(defknown gcd (&rest integer) unsigned-byte (movable foldable flushable)
-  :derive-type 'boolean-result-type)
-(defknown lcm (&rest integer) unsigned-byte (movable foldable flushable))
-
-(defknown exp (number) irrational (movable foldable flushable))
-(defknown expt (number real) number (movable foldable flushable))
-(defknown log (number &optional real) irrational (movable foldable flushable))
-(defknown sqrt (number) irrational (movable foldable flushable))
-(defknown isqrt (unsigned-byte) unsigned-byte (movable foldable flushable))
-(defknown (abs phase signum) (number) number (movable foldable flushable))
-(defknown cis (real) (complex float) (movable foldable flushable))
-(defknown atan (number &optional real) irrational (movable foldable flushable))
-(defknown (sin cos tan asin acos sinh cosh tanh asinh acosh atanh)
-  (number) irrational (movable foldable flushable))
-(defknown float (real &optional float) float (movable foldable flushable)
-  :derive-type 'float-result-type)
-(defknown (rational rationalize) (real) rational (movable foldable flushable))
-(defknown (numerator denominator) (rational) integer (movable foldable flushable))
-(defknown (floor ceiling truncate round)
-  (real &optional real) (values integer real) (movable foldable flushable))
-(defknown (mod rem) (real real) real (movable foldable flushable))
-(defknown (ffloor fceiling fround ftruncate)
-  (real &optional real) (values float float) (movable foldable flushable))
-
-
-
-(defknown decode-float (float) (values float float-exponent float) (movable foldable flushable)
-;  :derive-type 'result-type-arg1   But not really...
-)
-(defknown scale-float (float float-exponent) float (movable foldable flushable)
-  :derive-type 'result-type-arg1)
-(defknown float-radix (float) float-radix (movable foldable flushable))
-(defknown float-sign (float &optional float) float (movable foldable flushable))
-(defknown (float-digits float-precision) (float) float-digits (movable foldable flushable))
-(defknown integer-decode-float (float)
-	  (values integer float-exponent (member -1 1))
-	  (movable foldable flushable))
-(defknown complex (real &optional real) number (movable foldable flushable))
-(defknown (realpart imagpart) (number) real (movable foldable flushable))
-
-(defknown (logior logxor logand logeqv lognand lognor logandc1 logandc2 logorc1
-		  logorc2)
-  (&rest integer) t
-  (movable foldable flushable))
-
-(defknown boole (t t boole-code) integer (movable foldable flushable))
-(defknown lognot (integer) t (movable foldable flushable)
-  :derive-type 'boolean-result-type)
-(defknown logtest (t integer) boolean (movable foldable flushable))
-(defknown logbitp (bit-index integer) boolean (movable foldable flushable))
-(defknown ash (integer ash-index) integer (movable foldable flushable))
-(defknown (logcount integer-length) (integer) bit-index
-  (movable foldable flushable))
-(defknown byte (bit-index bit-index) byte-specifier
-  (movable foldable flushable))
-(defknown (byte-size byte-position) (byte-specifier) bit-index
-  (movable foldable flushable)) 
-(defknown ldb (byte-specifier integer) integer (movable foldable flushable))
-(defknown ldb-test (byte-specifier integer) boolean
-  (movable foldable flushable))
-(defknown mask-field (byte-specifier integer) integer
-  (movable foldable flushable))
-(defknown dpb (integer byte-specifier integer) integer
-  (movable foldable flushable))
-(defknown deposit-field (integer byte-specifier integer) integer
-  (movable foldable flushable))
-(defknown random (real &optional random-state) real ())
-(defknown make-random-state (&optional (or (member nil t) random-state))
-  random-state (flushable))
-(defknown random-state-p (t) boolean (movable foldable flushable))
-
-;;; In "Characters" chapter:
-(defknown (standard-char-p graphic-char-p string-char-p alpha-char-p
-			   upper-case-p lower-case-p both-case-p alphanumericp)
-  (character) boolean (movable foldable flushable))
-
-(defknown digit-char-p (character &optional unsigned-byte)
-  (or (integer 0 35) null) (movable foldable flushable))
-
-(defknown (char= char/= char< char> char<= char>= char-equal char-not-equal
-		 char-lessp char-greaterp char-not-greaterp char-not-lessp)
-  (character &rest character) boolean (movable foldable flushable))
-
-(defknown character (t) character (movable foldable flushable))
-(defknown char-code (character) char-code (movable foldable flushable))
-(defknown char-bits (character) char-bits (movable foldable flushable))
-(defknown char-font (character) char-font (movable foldable flushable))
-(defknown code-char (char-code &optional char-bits char-font)
-  character (movable foldable flushable))
-(defknown make-char (character  &optional char-bits char-font)
-  character (movable foldable flushable))
-(defknown (char-upcase char-downcase) (character) character (movable foldable flushable))
-(defknown digit-char (integer &optional integer char-bits)
-  (or character null) (movable foldable flushable))
-(defknown char-int (character) char-int (movable foldable flushable))
-(defknown int-char (char-int) character (movable foldable flushable))
-(defknown char-name (character) (or simple-string null) (movable foldable flushable))
-(defknown name-char (stringable) (or character null) (movable foldable flushable))
-(defknown char-bit (character bit-names) boolean (movable foldable flushable))
-(defknown set-char-bit (character bit-names t) character (movable foldable flushable))
-
-
-;;;; In the "Sequences" chapter:
-
-(defknown elt (sequence index) t (foldable flushable))
-
-(defknown subseq (sequence index &optional sequence-end) consed-sequence
-  (foldable flushable) :derive-type 'result-type-arg1)
-
-(defknown copy-seq (sequence) consed-sequence (foldable flushable)
-  :derive-type 'result-type-arg1)
-
-(defknown length (sequence) index (foldable flushable))
-
-(defknown reverse (sequence) consed-sequence (foldable flushable)
-  :derive-type 'result-type-arg1)
-
-(defknown nreverse (sequence) sequence (unsafe)
-  :derive-type 'result-type-arg1)
-
-(defknown make-sequence (type-specifier index &key (initial-element t)) consed-sequence
-  (movable flushable unsafe) :derive-type 'type-spec-arg1)
-
-(defknown concatenate (type-specifier &rest sequence) consed-sequence
-  (foldable flushable) :derive-type 'type-spec-arg1)
-
-(defknown map (type-specifier callable sequence &rest sequence) consed-sequence
-  (flushable call)
-;  :derive-type 'type-spec-arg1  Nope... (map nil ...) returns null, not nil.
-  )
-
-;;; Returns predicate result... 
-(defknown some (callable sequence &rest sequence) t
-  (foldable flushable call))
-
-(defknown (every notany notevery) (callable sequence &rest sequence) boolean
-  (foldable flushable call))
-
-;;; Unsafe for :Initial-Value...
-(defknown reduce (callable sequence &key (from-end t) (start index)
-			   (end sequence-end) (initial-value t))
-  t
-  (foldable flushable call unsafe))
-
-(defknown fill (sequence t &key (start index) (end sequence-end)) sequence
-  (unsafe)
-  :derive-type 'result-type-arg1)
-
-(defknown replace (sequence sequence &key (start1 index) (end1 sequence-end)
-			    (start2 index) (end2 sequence-end))
-  consed-sequence (unsafe)
-  :derive-type 'result-type-arg1)
-
-(defknown remove
-  (t sequence &key (from-end t) (test callable)
-     (test-not callable) (start index) (end sequence-end)
-     (count sequence-end) (key callable))
-  consed-sequence
-  (flushable call)
-  :derive-type 'result-type-arg2)
-
-(defknown substitute
-  (t t sequence &key (from-end t) (test callable)
-     (test-not callable) (start index) (end sequence-end)
-     (count sequence-end) (key callable))
-  consed-sequence
-  (flushable call)
-  :derive-type 'result-type-arg2)
-
-(defknown (remove-if remove-if-not)
-  (callable sequence &key (from-end t) (start index) (end sequence-end)
-	    (count sequence-end) (key callable))
-  consed-sequence
-  (flushable call)
-  :derive-type 'result-type-arg2)
-
-(defknown (substitute-if substitute-if-not)
-  (t callable sequence &key (from-end t) (start index) (end sequence-end)
-     (count sequence-end) (key callable))
-  consed-sequence
-  (flushable call)
-  :derive-type 'result-type-arg2)
-
-(defknown delete
-  (t sequence &key (from-end t) (test callable)
-     (test-not callable) (start index) (end sequence-end)
-     (count sequence-end) (key callable))
-  sequence
-  (flushable call unsafe)
-  :derive-type 'result-type-arg2)
-
-(defknown nsubstitute
-  (t t sequence &key (from-end t) (test callable)
-     (test-not callable) (start index) (end sequence-end)
-     (count sequence-end) (key callable))
-  sequence
-  (flushable call unsafe)
-  :derive-type 'result-type-arg3)
-
-(defknown (delete-if delete-if-not)
-  (callable sequence &key (from-end t) (start index) (end sequence-end)
-	    (count sequence-end) (key callable))
-  sequence
-  (flushable call unsafe)
-  :derive-type 'result-type-arg2)
-
-(defknown (nsubstitute-if nsubstitute-if-not)
-  (t callable sequence &key (from-end t) (start index) (end sequence-end)
-     (count sequence-end) (key callable))
-  sequence
-  (flushable call unsafe)
-  :derive-type 'result-type-arg3)
-
-(defknown remove-duplicates
-  (sequence &key (test callable) (test-not callable) (start index) (from-end t)
-	    (end sequence-end) (key callable))
-  consed-sequence
-  (flushable call)
-  :derive-type 'result-type-arg1)
-
-(defknown delete-duplicates
-  (sequence &key (test callable) (test-not callable) (start index) (from-end t)
-	    (end sequence-end) (key callable))
-  sequence
-  (flushable call unsafe)
-  :derive-type 'result-type-arg1)
-
-(defknown find (t sequence &key (test callable) (test-not callable)
-		  (start index) (from-end t) (end sequence-end) (key callable))
-  t
-  (foldable flushable call))
-
-(defknown (find-if find-if-not)
-  (callable sequence &key (from-end t) (start index) (end sequence-end)
-	    (key callable))
-  t
-  (foldable flushable call))
-
-(defknown position (t sequence &key (test callable) (test-not callable)
-		      (start index) (from-end t) (end sequence-end)
-		      (key callable))
-  (or index null)
-  (foldable flushable call))
-
-(defknown (position-if position-if-not)
-  (callable sequence &key (from-end t) (start index) (end sequence-end)
-	    (key callable))
-  (or index null)
-  (foldable flushable call))
-
-(defknown count (t sequence &key (test callable) (test-not callable)
-		      (start index) (from-end t) (end sequence-end)
-		      (key callable))
-  index
-  (foldable flushable call))
-
-(defknown (count-if count-if-not)
-  (callable sequence &key (from-end t) (start index) (end sequence-end)
-	    (key callable))
-  index
-  (foldable flushable call))
-
-(defknown (mismatch search)
-  (sequence sequence &key (from-end t) (test callable) (test-not callable)
-	    (start1 index) (end1 sequence-end) (start2 index) (end2 sequence-end)
-	    (key callable))
-  (or index null)
-  (foldable flushable call))
-
-;;; Not flushable, since vector sort guaranteed in-place...
-(defknown (stable-sort sort) (sequence callable &key (key callable)) sequence
-  (call)
-  :derive-type 'result-type-arg1)
-
-(defknown merge (type-specifier sequence sequence callable
-				&key (key callable))
-  sequence
-  (flushable call)
-  :derive-type 'type-spec-arg1)
-
-
-;;;; In the "Manipulating List Structure" chapter:
-
-(defknown (car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr
-	       cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr caddar
-	       cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
-	       first second third fourth fifth sixth seventh eighth ninth tenth
-	       rest)
-  (list) t (foldable flushable))
-
-(defknown cons (t t) cons (flushable unsafe))
-
-(defknown tree-equal (t t &key (test callable) (test-not callable)) boolean
-  (foldable flushable call))
-(defknown endp (t) boolean (foldable flushable movable))
-(defknown list-length (list) (or index null) (foldable flushable))
-(defknown (nth nthcdr) (index list) t (foldable flushable unsafe))
-(defknown last (list) list (foldable flushable unsafe))
-(defknown list (&rest t) list (flushable unsafe))
-(defknown list* (t &rest t) t (flushable unsafe))
-(defknown make-list (index &key (initial-element t)) list (flushable unsafe))
-
-;;;
-;;; All but last must be list...
-(defknown append (&rest t) t (flushable))
-
-(defknown copy-list (list) list (flushable))
-(defknown copy-alist (list) list (flushable))
-(defknown copy-tree (t) t (flushable))
-(defknown revappend (list t) t (flushable unsafe))
-(defknown nconc (&rest list) list (unsafe))
-(defknown nreconc (list list) list (unsafe))
-(defknown butlast (list &optional index) list (flushable))
-(defknown nbutlast (list &optional index) list (unsafe))
-(defknown ldiff (list list) list (flushable))
-(defknown (rplaca rplacd) (cons t) list (unsafe))
-
-;;; ---------  clean pointer #########
-
-(defknown subst (t t t &key (key t) (test t) (test-not t)) list (flushable unsafe))
-(defknown subst-if (t t t &key (key t)) list (flushable unsafe))
-(defknown subst-if-not (t t t &key (key t)) list (flushable unsafe))
-(defknown nsubst (t t t &key (key t) (test t) (test-not t)) list)
-(defknown nsubst-if (t t t &key (key t)) list)
-(defknown nsubst-if-not (t t t &key (key t)) list)
-(defknown sublis (t t &key (key t) (test t) (test-not t)) list (flushable unsafe))
-(defknown nsublis (t t &key (key t) (test t) (test-not t)) list)
-(defknown member (t t &key (key t) (test t) (test-not t)) list (flushable unsafe))
-(defknown member-if (t t &key (key t)) list (flushable unsafe))
-(defknown member-if-not (t t &key (key t)) list (flushable unsafe))
-(defknown tailp (t t) boolean (flushable unsafe))
-(defknown adjoin (t t &key (key t) (test t) (test-not t)) list (flushable unsafe))
-(defknown union (t t &key (key t) (test t) (test-not t)) list (flushable unsafe))
-(defknown intersection (t t &key (key t) (test t) (test-not t)) list (flushable unsafe))
-(defknown set-difference (t t &key (key t) (test t) (test-not t)) list (flushable unsafe))
-(defknown set-exclusive-or (t t &key (key t) (test t) (test-not t)) list (flushable unsafe))
-(defknown nunion (t t &key (key t) (test t) (test-not t)) list)
-(defknown nintersection (t t &key (key t) (test t) (test-not t)) list)
-(defknown nset-difference (t t &key (key t) (test t) (test-not t)) list)
-(defknown nset-exclusive-or (t t &key (test t) (test-not t) (key t)) list)
-(defknown subsetp (t t &key (key t) (test t) (test-not t)) boolean (flushable unsafe))
-(defknown acons (t t t) list (flushable unsafe))
-(defknown pairlis (t t &optional t) list (flushable unsafe))
-(defknown assoc (t t &key (key t) (test t) (test-not t)) list (flushable unsafe))
-(defknown assoc-if (t t) list (flushable unsafe))
-(defknown assoc-if-not (t t) list (flushable unsafe))
-(defknown rassoc (t t &key (key t) (test t) (test-not t)) list (flushable unsafe))
-(defknown rassoc-if (t t) list (flushable unsafe))
-(defknown rassoc-if-not (t t) list (flushable unsafe))
-
-
-;;;; In the "Hash Tables" chapter:
-
-(defknown make-hash-table
-  (&key (test callable) (size index) (rehash-size (or (integer (0)) (float (1.0))))
-	(rehash-threshold (or (integer (0)) (float (0.0) (1.0)))))
-  hash-table
-  (flushable unsafe))
-(defknown hash-table-p (t) boolean (movable foldable flushable))
-(defknown gethash (t hash-table &optional t) (values t boolean)
-  (foldable flushable unsafe))
-(defknown remhash (t hash-table) boolean ())
-(defknown maphash (callable hash-table) null (foldable flushable call))
-(defknown clrhash (hash-table) hash-table ())
-(defknown hash-table-count (hash-table) fixnum (foldable flushable))
-
-(deftype non-negative-fixnum () `(integer 0 ,most-positive-fixnum))
-(defknown sxhash (t) non-negative-fixnum (foldable flushable))
-
-
-;;;; In the "Arrays" chapter:
-
-(defknown make-array ((or index list) &key (element-type type-specifier)
-		      (initial-element t) (initial-contents list) (adjustable t)
-		      (fill-pointer t) (displaced-to (or array null))
-		      (displaced-index-offset index))
-  array (flushable unsafe))
-
-(defknown vector (&rest t) simple-vector (flushable unsafe))
-
-(defknown aref (array &rest index) t (foldable flushable))
-
-(defknown array-element-type (array) type-specifier (foldable flushable))
-(defknown array-rank (array) array-rank (foldable flushable))
-(defknown array-dimension (array array-rank) index (foldable flushable))
-(defknown array-dimensions (array) list (foldable flushable))
-(defknown array-in-bounds-p (array &rest index) boolean (foldable flushable))
-(defknown array-row-major-index (array &rest index) array-total-size
-  (foldable flushable)) 
-(defknown array-total-size (array) array-total-size (foldable flushable))
-(defknown adjustable-array-p (array) boolean (movable foldable flushable))
-
-(defknown svref (simple-vector index) t (foldable flushable))
-(defknown bit ((array bit) &rest index) bit (foldable flushable))
-(defknown sbit ((simple-array bit) &rest index) bit (foldable flushable))
-
-(defknown (bit-and bit-ior bit-xor bit-eqv bit-nand bit-nor bit-andc1 bit-andc2
-		   bit-orc1 bit-orc2)
-  ((array bit) (array bit) &optional (or (array bit) (member t)))
-  (array bit)
-  (foldable)
-  :derive-type 'result-type-arg1)
-
-(defknown bit-not ((array bit) &optional (or (array bit) (member t)))
-  (array bit)
-  (foldable)
-  :derive-type 'result-type-arg1)
-
-(defknown array-has-fill-pointer-p (array) boolean (movable foldable flushable))
-(defknown fill-pointer (vector) index (foldable flushable))
-(defknown vector-push (t vector) (or index null) ())
-(defknown vector-push-extend (t vector &optional index) index ())
-(defknown vector-pop (vector) t ())
-
-(defknown adjust-array
-  (array (or index list) &key (element-type type-specifier)
-	 (initial-element t) (initial-contents list) (adjustable t)
-	 (fill-pointer t) (displaced-to (or array null))
-	 (displaced-index-offset index))
-  array (unsafe))
-;  :derive-type 'result-type-arg1) Not even close...
-
-
-;;;; In the "Strings" chapter:
-
-(defknown char (string index) string-char (foldable flushable))
-(defknown schar (simple-string index) string-char (foldable flushable))
-
-(defknown (string= string-equal)
-  (stringlike stringlike &key (start1 index) (end1 sequence-end)
-	      (start2 index) (end2 sequence-end))
-  boolean
-  (foldable flushable))
-
-(defknown (string< string> string<= string>= string/= string-lessp
-		   string-greaterp string-not-lessp string-not-greaterp
-		   string-not-equal)
-  (stringlike stringlike &key (start1 index) (end1 sequence-end)
-	      (start2 index) (end2 sequence-end))
-  (or index null)
-  (foldable flushable))
-
-(defknown make-string (index &key (initial-element string-char))
-  simple-string (flushable))
-
-(defknown (string-trim string-left-trim string-right-trim)
-  (sequence stringlike) simple-string (flushable))
-
-(defknown (string-upcase string-downcase string-capitalize)
-  (stringlike &key (start index) (end sequence-end))
-  simple-string (flushable))
-
-(defknown (nstring-upcase nstring-downcase nstring-capitalize)
-  (string &key (start index) (end sequence-end))
-  string (unsafe))
-
-(defknown string (t) string (flushable unsafe))
-
-
-;;; Internal non-keyword versions of string predicates:
-
-(defknown (string<* string>* string<=* string>=* string/=*)
-  (stringlike stringlike index sequence-end index sequence-end)
-  (or index null)
-  (foldable flushable))
-
-(defknown string=*
-  (stringlike stringlike index sequence-end index sequence-end)
-  boolean
-  (foldable flushable))
-
-
-;;;; In the "Eval" chapter:
-
-(defknown eval (t) *)
-(defknown evalhook (t callable callable &optional full-lexical-environment) *)
-(defknown applyhook (callable list callable callable &optional full-lexical-environment) *)
-(defknown constantp (t) boolean (foldable flushable))
-
-
-;;;; In the "Streams" chapter:
-
-(defknown make-synonym-stream (symbol) stream (flushable unsafe))
-(defknown make-broadcast-stream (&rest stream) stream (flushable unsafe))
-(defknown make-concatenated-stream (&rest stream) stream (flushable unsafe))
-(defknown make-two-way-stream (stream stream) stream (flushable unsafe))
-(defknown make-echo-stream (stream stream) stream (flushable unsafe))
-(defknown make-string-input-stream (string &optional index index) stream (flushable unsafe))
-(defknown make-string-output-stream () stream (flushable))
-(defknown get-output-stream-string (stream) simple-string ())
-(defknown streamp (t) boolean (movable foldable flushable))
-(defknown stream-element-type (stream) type-specifier (movable foldable flushable))
-(defknown (output-stream-p input-stream-p) (stream) boolean (movable foldable
-								     flushable))
-(defknown close (stream &key (abort t)) stream ())
-
-
-;;;; In the "Input/Output" chapter:
-
-;;; The I/O functions are currently given effects ANY under the theory that
-;;; code motion over I/O operations is particularly confusing and not very
-;;; important for efficency.
-
-(defknown copy-readtable (&optional (or readtable null) readtable) readtable (unsafe))
-(defknown readtablep (t) boolean (movable foldable flushable))
-
-(defknown set-syntax-from-char
-  (character character &optional (or readtable null) readtable) void
-  (unsafe))
-
-(defknown set-macro-character (character callable &optional t readtable) void (unsafe))
-(defknown get-macro-character (character &optional readtable)
-  (values callable boolean) (flushable))
-
-(defknown make-dispatch-macro-character (character &optional t readtable) void (unsafe))
-(defknown set-dispatch-macro-character
-  (character character callable &optional readtable) void
-  (unsafe))
-(defknown get-dispatch-macro-character
-  (character character &optional readtable) callable
-  (flushable))
-
-;;; May return any type due to eof-value...
-(defknown (read read-preserving-whitespace read-char read-char-no-hang)
-  (&optional streamlike t t t) t)
-
-(defknown read-delimited-list (character &optional streamlike t) t)
-(defknown read-line (&optional streamlike t t t) (values t boolean))
-(defknown unread-char (character &optional streamlike) t)
-(defknown peek-char (&optional (or character (member nil t)) streamlike t t t) t)
-(defknown listen (&optional streamlike) boolean (flushable))
-
-(defknown clear-input (&optional stream) null)
-
-(defknown read-from-string
-  (string &optional t t &key (start index) (end sequence-end)
-	  (preserve-whitespace t))
-  t)
-(defknown parse-integer
-  (string &key (start index) (end sequence-end) (radix (integer 2 36))
-	  (junk-allowed t)) 
-  (or integer null ()))
-
-(defknown read-byte (stream &optional t t) t)
-
-(defknown write
-  (t &key (stream streamlike) (escape t) (radix t) (base (integer 2 36))
-     (circle t) (pretty t) (level (or unsigned-byte null))
-     (length (or unsigned-byte null)) (case t) (array t) (gensym t)) t
-  (any)
-  :derive-type 'result-type-arg1)
-
-(defknown (prin1 print princ) (t &optional streamlike) t (any)
-  :derive-type 'result-type-arg1)
-
-;;; xxx-TO-STRING not foldable because they depend on the dynamic environment. 
-(defknown write-to-string
-  (t &key (stream streamlike) (escape t) (radix t) (base (integer 2 36))
-     (circle t) (pretty t) (level (or unsigned-byte null))
-     (length (or unsigned-byte null)) (case t) (array t) (gensym t))
-  simple-string
-  (foldable flushable))
-
-(defknown (prin1-to-string princ-to-string) (t) simple-string (flushable))
-
-(defknown write-char (character &optional streamlike) character)
-(defknown (write-string write-line)
-  (string &optional streamlike &key (start index) (end sequence-end))
-  string)
-
-(defknown (terpri finish-output force-output clear-output)
-  (&optional streamlike) null)
-
-(defknown fresh-line (&optional streamlike) boolean)
-
-(defknown write-byte (integer stream) integer)
-
-(defknown format ((or streamlike string) string &rest t) (or string null))
-
-(defknown (y-or-n-p yes-or-no-p) (&optional string &rest t) boolean)
-
-
-;;;; In the "File System Interface" chapter:
-
-(defknown pathname (pathnamelike) pathname (foldable flushable unsafe))
-(defknown truename (pathnamelike) pathname (unsafe))
-
-(defknown parse-namestring
-  (pathnamelike &optional (or string null) pathnamelike  &key (start index)
-		(end sequence-end) (junk-allowed t))
-  (values (or pathname null) index)
-  (unsafe))
-
-(defknown merge-pathnames (pathnamelike &optional pathnamelike) pathname
-  (foldable flushable))
-
-;;; Sooo many kindsof garbage can be specified, that I don't feel like figuring
-;;; out what legal args are...
-(defknown make-pathname
- (&key (defaults pathnamelike) (host t) (device t) (directory t) (name t)
-       (type t) (version t))
-  pathname (foldable flushable unsafe))
-
-(defknown pathnamep (t) boolean (movable foldable flushable))
-
-(defknown pathname-host (pathnamelike) pathname-host (foldable flushable))
-(defknown pathname-device (pathnamelike) pathname-device (foldable flushable))
-(defknown pathname-directory (pathnamelike) pathname-directory (foldable flushable))
-(defknown pathname-name (pathnamelike) pathname-name (foldable flushable))
-(defknown pathname-type (pathnamelike) pathname-type (foldable flushable))
-(defknown pathname-version (pathnamelike) pathname-version (foldable flushable))
-
-(defknown (namestring file-namestring directory-namestring host-namestring)
-  (pathnamelike) simple-string
-  (foldable flushable))
-
-(defknown enough-namestring (pathnamelike &optional pathnamelike)
-  simple-string
-  (foldable flushable))
-
-(defknown user-homedir-pathname (&optional t) pathname (flushable))
-
-(defknown open
-  (pathnamelike &key (direction (member :input :output :io :probe))
-		(element-type type-specifier)
-		(if-exists (member :error :new-version :rename
-				   :rename-and-delete :overwrite :append
-				   :supersede nil))
-		(if-does-not-exist (member :error :create nil)))
-  (or stream null))
-
-(defknown rename-file (pathnamelike filename) (values pathname pathname pathname))
-(defknown delete-file (pathnamelike) t)
-(defknown probe-file (pathnamelike) (or pathname null) (flushable))
-(defknown file-write-date (pathnamelike) (or unsigned-byte null) (flushable))
-(defknown file-author (pathnamelike) (or simple-string null) (flushable unsafe))
-
-(defknown file-position (stream &optional unsigned-byte)
-  (or unsigned-byte (member t nil)))
-(defknown file-length (stream) (or unsigned-byte null) (flushable))
-
-(defknown load
-  (filename &key (verbose t) (print t)
-	    (if-does-not-exist (member :error :create nil)))
-  t)
-
-(defknown directory (pathnamelike &key) list (flushable))
-
-
-;;;; In the "Errors" chapter:
-
-(defknown error (t &rest t) nil) ; Never returns...
-(defknown cerror (string t &rest t) null)
-(defknown warn (t &rest t) null)
-(defknown break (&optional t &rest t) null)
-
-
-;;;; In the "Miscellaneous" Chapter.
-
-;;; ### Compiler interface non-standard...
-(defknown compile (symbol &optional list t) (or function null))
-(defknown compile-file
-  (&optional filename &key (output-file filename) (error-file filename)
-	     (lap-file filename) (errors-to-terminal t) (load t))
-  void)
-(defknown disassemble (callable &optional stream) void)
-
-(defknown documentation (symbol (member variable function structure type setf))
-  (or string null)
-  (flushable))
-
-(defknown describe (t &optional stream) (values))
-(defknown inspect (t) (values))
-
-(defknown room (&optional (member t nil) t) void)
-(defknown ed (&optional filename) t)
-(defknown dribble (&optional filename &key (if-exists t)) t)
-
-(defknown apropos (stringlike &optional packagelike t) (values))
-(defknown apropos-list (stringlike &optional packagelike t) list (flushable))
-
-(defknown get-decoded-time ()
-  (values (integer 0 59) (integer 0 59) (integer 0 23) (integer 1 31)
-	  (integer 1 12) unsigned-byte (integer 0 6) boolean (rational 0 (24)))
-  (flushable))
-
-(defknown get-universal-time () unsigned-byte (flushable))
-
-(defknown decode-universal-time (unsigned-byte &optional (integer 0 23))
-  (values (integer 0 59) (integer 0 59) (integer 0 23) (integer 1 31)
-	  (integer 1 12) unsigned-byte (integer 0 6) boolean (rational 0 (24)))
-  (flushable))
-
-(defknown encode-universal-time
-  ((integer 0 59) (integer 0 59) (integer 0 23) (integer 1 31)
-   (integer 1 12) unsigned-byte &optional (rational 0 (24)))
-  unsigned-byte
-  (flushable))
-
-(defknown (get-internal-run-time get-internal-real-time)
-  () internal-time (flushable))
-
-(defknown sleep ((or (rational 0) (float 0.0))) null)
-
-(defknown (lisp-implementation-type
-	   lisp-implementation-version machine-type machine-version
-	   machine-instance software-type software-version short-site-name
-	   long-site-name)
-  () simple-string (flushable))
-
-(defknown identity (t) t (movable foldable flushable unsafe)
-  :derive-type 'result-type-arg1)
-
-
-;;;; Magical compiler frobs:
-
-(defknown (%typep %array-typep) (t type-specifier) boolean)
-(defknown %special-bind (t t) void)
-(defknown %special-unbind (t) void)
-(defknown %listify-rest-args (t t) list (flushable))
-(defknown %more-arg-context (t t) (values t fixnum) (flushable))
-(defknown %more-arg (t t) t)
-(defknown %verify-argument-count (t t) nil)
-(defknown %argument-count-error (t) nil)
-(defknown %unknown-values () *)
-(defknown %catch (t t) void)
-(defknown %unwind-protect (t t) void)
-(defknown (%catch-breakup %unwind-protect-breakup) () void)
-(defknown %lexical-exit-breakup (t) void)
-(defknown %continue-unwind (t t t) nil)
-(defknown %throw (t &rest t) nil); This is MV-called.
-(defknown %nlx-entry (t) *)
-(defknown %%primitive (t t &rest t) *)
-(defknown %pop-values (t) void)
-(defknown %type-check-error (t t) nil)
-(defknown %odd-keyword-arguments-error () nil)
-(defknown %unknown-keyword-argument-error (t) nil)
-(defknown (%ldb %mask-field) (bit-index bit-index integer) unsigned-byte
-  (movable foldable flushable))
-(defknown (%dpb %deposit-field) (integer bit-index bit-index integer) integer
-  (movable foldable flushable))
-(defknown %negate (number) number (movable foldable flushable))
-
-;;; Structure slot accessors or setters are magically "known" to be these
-;;; functions, although the var remains the Slot-Accessor describing the actual
-;;; function called.
-;;;
-(defknown %slot-accessor (t) t (foldable flushable unsafe))
-(defknown %slot-setter (t t) t (unsafe))
-
-
-;;;; Setf inverses:
-
-(defknown %aset (array &rest t) t (unsafe))
-(defknown %rplaca (cons t) t (unsafe))
-(defknown %rplacd (cons t) t (unsafe))
-(defknown %put (symbol t t) t (unsafe))
-(defknown %setelt (sequence index t) t (unsafe))
-(defknown %svset (simple-vector index t) t (unsafe))
-(defknown %bitset (bit-vector index bit) bit (unsafe))
-(defknown %sbitset (simple-bit-vector index bit) bit (unsafe))
-(defknown %charset (string index string-char) string-char (unsafe))
-(defknown %scharset (simple-string index string-char) string-char (unsafe))
-(defknown %sp-set-definition (symbol function) function (unsafe))
-(defknown %sp-set-plist (symbol t) t (unsafe))
-(defknown %set-documentation
-	  (symbol (member variable function structure type setf)
-		  (or string null))
-  (unsafe))
-(defknown %setnth (index list t) t (unsafe))
-(defknown %set-fill-pointer (vector index) (unsafe))
-
-
-;;;; Internal type predicates:
-;;;
-;;;    Simple typep uses that don't have any standard predicate are translated
-;;; into non-standard unary predicates.
-
-(defknown (fixnump bignump ratiop short-float-p single-float-p double-float-p
-		   long-float-p %string-char-p %standard-char-p structurep
-		   array-header-p)
-  (t) boolean (movable foldable flushable))
-
-
-;;;; Miscellaneous "sub-primitives":
-
-(defknown %sp-string-compare
-  (simple-string index index simple-string index index)
-  (or index null)
-  (foldable flushable))
diff --git a/compiler/generic/vm-tran.lisp b/compiler/generic/vm-tran.lisp
deleted file mode 100644
index 890b252554e3d959b805af83a2b3116f70f51980..0000000000000000000000000000000000000000
--- a/compiler/generic/vm-tran.lisp
+++ /dev/null
@@ -1,38 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    This file contains impelemtentation-dependent transforms.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-;;; We need to define these predicates, since the TYPEP source transform picks
-;;; whichever predicate was defined last when there are multiple predicates for
-;;; equivalent types.
-;;;
-(def-source-transform single-float-p (x) `(short-float-p ,x))
-(def-source-transform double-float-p (x) `(long-float-p ,x))
-
-(def-source-transform structurep (x)
-  (once-only ((n-x x))
-    `(and (simple-vector-p ,n-x)
-	  (eql (%primitive get-vector-subtype ,n-x)
-	       system:%g-vector-structure-subtype))))
-
-(def-source-transform compiled-function-p (x)
-  `(functionp ,x))
-
-(def-source-transform char-int (x)
-  `(truly-the char-int (%primitive make-fixnum ,x)))
-
-(def-source-transform abs (x)
-  (once-only ((n-x x))
-    `(if (< ,n-x 0) (- ,n-x) ,n-x)))
-
diff --git a/compiler/generic/vm-type.lisp b/compiler/generic/vm-type.lisp
deleted file mode 100644
index 608b34f2b8caaf3824b7bad5cddc5e08e632e9ab..0000000000000000000000000000000000000000
--- a/compiler/generic/vm-type.lisp
+++ /dev/null
@@ -1,137 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    This file contains implementation-dependent parts of the type support
-;;; code.  This is stuff which deals with the mapping from types defined in
-;;; Common Lisp to types actually supported by an implementation.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-;;;; Implementation dependent deftypes:
-
-;;; Make double-float a synonym for long-float, single-float for Short-Float.
-;;; This is be expanded before the translator gets a chance, so we will get
-;;; precedence.
-;;;
-(deftype double-float (&optional low high)
-  `(long-float ,low ,high))
-;;;
-(deftype single-float (&optional low high)
-  `(short-float ,low ,high))
-
-;;; Compiled-function is the same as function in this implementation.
-;;;
-(deftype compiled-function () 'function)
-
-;;;
-;;; An index into an integer.
-(deftype bit-index () `(integer 0 ,most-positive-fixnum))
-;;;
-;;; Offset argument to Ash (a signed bit index).
-(deftype ash-index () 'fixnum)
-;;;
-;;; A lexical environment for macroexpansion.
-(deftype lexical-environment () '(or list lisp::lexical-environment))
-;;;
-;;; A full lexical environment.
-(deftype full-lexical-environment () 'lisp::lexical-environment)
-;;;
-;;; Worst case values for float attributes.
-;;; ### long-float exponent range seems to be this, but I don't know why.
-;;; Perhaps IEEE double uses some of the negative exponents for NAN, etc?
-;;;
-(deftype float-exponent () '(integer -1021 1024))
-(deftype float-digits () '(unsigned-byte 6))
-(deftype float-radix () '(integer 2 2))
-;;;
-;;; A code for Boole.
-(deftype boole-code () '(unsigned-byte 4))
-;;;
-;;; A byte-specifier.
-(deftype byte-specifier () 'cons)
-;;;
-;;; Result of Char-Int...
-(deftype char-int () '(unsigned-byte 16))
-;;;
-;;; Legal character bit names:
-(deftype bit-names () '(member :control :meta :super :hyper))
-;;;
-;;; Pathname pieces, as returned by the PATHNAME-xxx functions.
-(deftype pathname-host () '(or simple-string null)); Host not really supported...
-(deftype pathname-device () '(or simple-string (member :absolute nil)))
-(deftype pathname-directory () '(or simple-vector null))
-(deftype pathname-name () '(or simple-string null))
-(deftype pathname-type () '(or simple-string null))
-(deftype pathname-version () '(or simple-string (member nil :newest)))
-;;;
-;;; Internal time format.  Not a fixnum (blag...)
-(deftype internal-time () 'unsigned-byte)
-
-
-;;;; Hooks into type system:
-
-;;; The kinds of specialised array that actually exist in this implementation.
-;;;
-(defparameter specialized-array-element-types
-  '(bit (unsigned-byte 2) (unsigned-byte 4) (unsigned-byte 8) (unsigned-byte 16)
-	(unsigned-byte 32) string-char))
-
-;;; Float-Format-Name  --  Internal
-;;;
-;;;    Return the symbol that describes the format of Float.
-;;;
-(proclaim '(function float-format-name (float) symbol))
-(defun float-format-name (x)
-  (etypecase x
-    (short-float 'short-float)
-    (long-float 'long-float)))
-
-;;; Specialize-Array-Type  --  Internal
-;;;
-;;;    This function is called when the type code wants to find out how an
-;;; array will actually be implemented.  We set the Specialized-Element-Type to
-;;; correspond to the actual specialization used in this implementation.
-;;;
-(proclaim '(function specialize-array-type (array-type) array-type))
-(defun specialize-array-type (type)
-  (let ((eltype (array-type-element-type type)))
-
-    (setf (array-type-specialized-element-type type)
-	  (if (eq eltype *wild-type*)
-	      *wild-type*
-	      (dolist (stype-name specialized-array-element-types
-				  (specifier-type 't))
-		(let ((stype (specifier-type stype-name)))
-		  (when (csubtypep eltype stype)
-		    (return stype))))))
-
-    type))
-
-
-;;; Hairy-Type-Check-Template  --  Interface
-;;;
-;;;    If Type has a CHECK-xxx template, but doesn't have a corresponding
-;;; primitive-type, then return the template's name.  Otherwise, return NIL.
-;;;
-(defun hairy-type-check-template (type)
-  (declare (type ctype type))
-  (typecase type
-    (named-type
-     (case (named-type-name type)
-       (cons 'check-cons)
-       (symbol 'check-symbol)
-       (t nil)))
-    (union-type
-     (if (type= type (specifier-type '(or function symbol)))
-	 'check-function-or-symbol
-	 nil))
-    (t
-     nil)))
diff --git a/compiler/globaldb.lisp b/compiler/globaldb.lisp
deleted file mode 100644
index 6c1f3bd89e8415ee2cf87e2c049d6ce0ab0e4b3c..0000000000000000000000000000000000000000
--- a/compiler/globaldb.lisp
+++ /dev/null
@@ -1,1062 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    This file provides a functional interface to global information about
-;;; named things in the system.  Information is considered to be global if it
-;;; must persist between invocations of the compiler.  The use of a functional
-;;; interface eliminates the need for the compiler to worry about the actual
-;;; representation.   This is important, since the information may well have
-;;; several representations.   This code also deals with the need for multiple
-;;; "global" environments, so that changing something in the compiler doesn't
-;;; trash the running Lisp environment.
-;;;
-;;;    The database contains arbitrary Lisp values, addressed by a combination
-;;; of Name, Class and Type.  The Name is a EQUAL-thing which is the name of
-;;; the thing we are recording information about.  Class is the kind of object
-;;; involved.  Typical classes are Function, Variable, Type, ...  A Type names
-;;; a particular piece of information within a given class.  Class and Type are
-;;; symbols, but are compared with STRING=.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package "C")
-(use-package "EXTENSIONS")
-(use-package "SYSTEM")
-
-(deftype index () `(integer 0 ,most-positive-fixnum))
-
-;;; Undefined-Value  --  Public
-;;;
-;;;    This is here until we figure out what to do with it.
-;;;
-(proclaim '(inline undefined-value))
-(defun undefined-value ()
-  '%undefined%)
-
-(in-package "EXTENSIONS")
-(export '(info clear-info define-info-class define-info-type
-	       make-info-environment do-info *info-environment*
-	       compact-info-environment))
-
-(in-package "C")
-
-;;; The defvar for this appears later.
-(proclaim '(special *universal-type*))
-(proclaim '(type list type-specifier-symbols))
-
-
-;;; PRIMIFY  --  Internal
-;;;
-;;;    Given any non-negative integer, return a prime number >= to it.
-;;;
-(defun primify (x)
-  (declare (type unsigned-byte x))
-  (do ((n (logior x 1) (+ n 2)))
-      ((system:primep n) n)))
-
-
-
-;;;; Defining info types:
-
-(eval-when (compile load eval)
-
-(defstruct (class-info
-	    (:constructor make-class-info (name))
-	    (:print-function
-	     (lambda (s stream d)
-	       (declare (ignore d))
-	       (format stream "#<Class-Info ~S>" (class-info-name s)))))
-  ;;
-  ;; String name of this class.
-  (name nil :type simple-string)
-  ;;
-  ;; List of Type-Info structures for each type in this class.
-  (types () :type list))
-
-
-;;; At run-time, we represent the type of info that we want by a small
-;;; non-negative integer.
-;;;
-(defconstant type-number-bits 6)
-(deftype type-number () `(unsigned-byte ,type-number-bits))
-;;;
-;;; Also initialized in GLOBALDB-INIT...
-(defvar *type-numbers*
-  (make-array (ash 1 type-number-bits)  :initial-element nil))
-
-
-(defstruct (type-info
-	    (:print-function
-	     (lambda (s stream d)
-	       (declare (ignore d))
-	       (format stream "#<Type-Info ~S ~S, Number = ~D>"
-		       (class-info-name (type-info-class s))
-		       (type-info-name s)
-		       (type-info-number s)))))
-			     
-  ;;
-  ;; String name of this type.
-  (name nil :type simple-string)
-  ;;
-  ;; This type's class.
-  (class nil :type class-info)
-  ;;
-  ;; A number that uniquely identifies this type (and implicitly its class.)
-  (number nil :type type-number)
-  ;;
-  ;; Type specifier which info of this type must satisfy.
-  (type nil :type t)
-  ;;
-  ;; Function called when there is no information of this type.  Null at
-  ;; meta-compile time.
-  (default nil :type (or function null)))
-
-
-;;; A hashtable from class names to Class-Info structures.  This data structure
-;;; exists at compile time as well as run time.  Also initialized in
-;;; GLOBALDB-INIT...
-;;;
-(defvar *info-classes* (make-hash-table :test #'equal))
-(proclaim '(hash-table *info-classes*))
-
-
-;;; FIND-TYPE-INFO  --  Internal
-;;;
-;;;    If Name is the name of a type in Class, then return the TYPE-INFO,
-;;; otherwise NIL.
-;;;
-(defun find-type-info (name class)
-  (declare (simple-string name) (type class-info class))
-  (dolist (type (class-info-types class) nil)
-    (when (string= (type-info-name type) name)
-      (return type))))
-
-
-;;; Class-Info-Or-Lose, Type-Info-Or-Lose --  Internal
-;;;
-;;;    Return the info structure for an info class or type, or die trying.
-;;;
-(proclaim '(function class-info-or-lose (string) class-info))
-(defun class-info-or-lose (class)
-  (or (gethash class *info-classes*)
-      (error "~S is not a defined info class." class)))
-;;;
-(proclaim '(function type-info-or-lose (string string) type-info))
-(defun type-info-or-lose (class type)
-  (or (find-type-info type (class-info-or-lose class))
-      (error "~S is not a defined info type." type)))
-
-
-;;; Define-Info-Class  --  Public
-;;;
-;;;    Set up the data structures to support an info class.  We make sure that
-;;; the class exists at compile time so that macros can use it, but don't
-;;; actually store the init function until load time so that we don't break the
-;;; running compiler.
-;;;
-(defmacro define-info-class (class)
-  "Define-Info-Class Class
-  Define a new class of global information."
-  `(progn
-     (eval-when (compile load eval)
-       (%define-info-class ',(symbol-name class)))
-     ',class))
-
-
-;;; %Define-Info-Class  --  Internal
-;;;
-;;;    If there is no info for the class, then create it, otherwise do nothing.
-;;;
-(proclaim '(function %define-info-class (string) void))
-(defun %define-info-class (class)
-  (unless (gethash class *info-classes*)
-    (setf (gethash class *info-classes*) (make-class-info class))))
-
-
-;;; FIND-UNUSED-TYPE-NUMBER  --  Internal
-;;;
-;;;    Find a type number not already in use by looking for a null entry in
-;;; *TYPE-NUMBERS*.
-;;;
-(defun find-unused-type-number ()
-  (or (position nil *type-numbers*)
-      (error "Out of INFO type numbers!")))
-
-
-;;; Define-Info-Type  --  Public
-;;;
-;;;    The main thing we do is determine the type's number.  We need to do this
-;;; at macroexpansion time, since both the COMPILE and LOAD time calls to
-;;; %DEFINE-INFO-TYPE must use the same type number.
-;;;
-(defmacro define-info-type (class type type-spec &optional default)
-  "Define-Info-Type Class Type default Type-Spec
-  Define a new type of global information for Class.  Type is the symbol name
-  of the type, Default is the value for that type when it hasn't been set, and
-  Type-Spec is a type-specifier which values of the type must satisfy.  The
-  default expression is evaluated each time the information is needed, with
-  Name bound to the name for which the information is being looked up.  If the
-  default evaluates to something with the second value true, then the second
-  value of Info will also be true."
-  (let* ((class (symbol-name class))
-	 (type (symbol-name type))
-	 (old (find-type-info type (class-info-or-lose class))))
-    `(progn
-       (eval-when (compile load eval)
-	 (%define-info-type ',class ',type ',type-spec
-			    ,(if old
-				 (type-info-number old)
-				 (find-unused-type-number))))
-       (eval-when (load eval)
-	 (setf (type-info-default (type-info-or-lose ',class ',type))
-	       #'(lambda (name) name ,default)))
-       ',type)))
-
-
-;;; %Define-Info-Type  --  Internal
-;;;
-;;;    If there is no such type, create it.  In any case, set the type
-;;; specifier for the value.  The class must exist.
-;;;
-(defun %define-info-type (class type type-spec number)
-  (declare (simple-string class type) (type type-number number))
-  (let* ((class-info (class-info-or-lose class))
-	 (old (find-type-info type class-info))
-	 (res (or old
-		  (make-type-info :name type
-				  :class class-info
-				  :number number
-				  :type type-spec)))
-	 (num-old (svref *type-numbers* number)))
-    (cond (old
-	   (setf (type-info-type res) type-spec)
-	   (unless (= (type-info-number res) number)
-	     (cerror "Redefine it." "Changing type number for ~A ~A."
-		     class type)
-	     (setf (type-info-number res) number)))
-	  (t
-	   (push res (class-info-types class-info))))
-
-    (unless (eq num-old res)
-      (when num-old
-	(cerror "Go for it." "Reusing type number for ~A ~A."
-		(class-info-name (type-info-class num-old))
-		(type-info-name num-old)))
-      (setf (svref *type-numbers* number) res)))
-
-  (undefined-value))
-
-); eval-when (compile load eval)
-
-
-;;;; Info environments:
-;;;
-;;;    We do info access relative to the current *info-environment*.  This is a
-;;; list of INFO-ENVIRONMENT structures we search.  The variable is actually
-;;; initialized in GLOBALDB-INIT.
-
-(defvar *info-environment*)
-(proclaim '(type list *info-environment*))
-
-
-(defun %print-info-environment (s stream d)
-  (declare (ignore d) (stream stream)) 
-  (format stream "#<~S ~S>" (type-of s) (info-env-name s)))
-
-
-;;; Note: the CACHE-NAME slot is deliberately not shared for bootstrapping
-;;; reasons.  If we access with accessors for the exact type, then the inline
-;;; type check will win.  If the inline check didn't win, we would try to use
-;;; the type system before it was properly initialized.
-;;;
-(defstruct (info-env (:print-function %print-info-environment))
-  ;;
-  ;; Some string describing what is in this environment, for printing purposes
-  ;; only.
-  (name nil :type string))
-
-
-;;; INFO-HASH  --  Internal
-;;;
-;;;    Semantically equivalent to SXHASH, but optimized for legal function
-;;; names.  Note: semantically equivalent does *not* mean that it always
-;;; returns the same value as SXHASH, just that it satisfies the formal
-;;; definition of SXHASH.
-;;;
-;;;    All we do for now is pick off the cases of a symbol and a list of two
-;;; symbols [e.g. (SETF FOO)].  The symbol case is the same as what SXHASH
-;;; does, but we get there more expeditiously.  With the two-list, we LOGXOR a
-;;; random constant with the hash of the second symbol.
-;;;
-(proclaim '(inline info-hash))
-(defun info-hash (x)
-  (cond
-   ((symbolp x)
-    #-new-compiler
-    (the fixnum (%primitive sxhash-simple-string (symbol-name x)))
-    #+new-compiler
-    (truly-the index (%primitive sxhash-simple-string (symbol-name x))))
-   ((and (listp x)
-	 (eq (car x) 'setf))
-    (let ((next (cdr x)))
-      (when (listp next)
-	(let ((name (car next)))
-	  (when (and (symbolp name) (null (cdr next)))
-	    (return-from info-hash
-			 (logxor #-new-compiler
-				 (the fixnum
-				      (%primitive sxhash-simple-string
-						  (symbol-name name)))
-				 #+new-compiler
-				 (truly-the index
-					    (%primitive sxhash-simple-string
-							(symbol-name name)))
-				 110680597))))))
-    (sxhash x))
-   (t
-    (sxhash x))))
-
-
-;;;; Generic interfaces:
-
-;;; Info  --  Public
-;;;
-;;;    This is a macro so that we can resolve the Class and Type to a type
-;;; number at compile time.  When we check the new-value's type directly in the
-;;; SETF expansion, since the check can be done much more efficiently when the
-;;; type is constant.
-;;;
-(defmacro info (class type name)
-  "Return the information of the specified Type and Class for Name.
-  The second value is true if there is any such information recorded.  If there
-  is no information, the first value is the default and the second value is NIL."
-  ;;
-  ;; ### Should be a values type, but interpreter can't hack that now.
-  (let* ((class (symbol-name class))
-	 (type (symbol-name type))
-	 (info (type-info-or-lose class type)))
-    `(#+new-compiler truly-the #-new-compiler the
-		     ,(type-info-type info)
-		     (get-info-value ,name ,(type-info-number info)))))
-;;;
-(define-setf-method info (class type name)
-  "Set the global information for Name."
-  (let* ((n-name (gensym))
-	 (n-value (gensym))
-	 (class-str (symbol-name class))
-	 (type-str (symbol-name type))
-	 (info (type-info-or-lose class-str type-str)))
-    (values
-     `(,n-name)
-     `(,name)
-     `(,n-value)
-     `(progn
-	(check-type ,n-value ,(type-info-type info))
-	(set-info-value ,n-name ,(type-info-number info) ,n-value))
-     `(info ,class ,type ,n-name))))
-
-
-;;; DO-INFO  --  Public
-;;;
-(defmacro do-info ((env &key (name (gensym)) (class (gensym)) (type (gensym))
-			(type-number (gensym)) (value (gensym)))
-		   &body body)
-  "DO-INFO (Env &Key Name Class Type Value) Form*
-  Iterate over all the values stored in the Info-Env Env.  Name is bound to
-  the entry's name, Class and Type are bound to the class and type
-  (represented as strings), and Value is bound to the entry's value."
-  (once-only ((n-env env))
-    `(if (typep ,n-env 'volatile-info-env)
-	 ,(do-volatile-info name class type type-number value n-env body)
-	 ,(do-compact-info name class type type-number value n-env body))))
-
-
-(eval-when (compile load eval)
-
-;;; DO-COMPACT-INFO  --  Internal
-;;;
-;;;    Return code to iterate over a compact info environment.
-;;;
-(defun do-compact-info (name-var class-var type-var type-number-var value-var
-				 n-env body)
-  (let ((n-index (gensym)) (n-type (gensym)) (punt (gensym)))
-    (once-only ((n-table `(compact-info-env-table ,n-env))
-		(n-entries-index `(compact-info-env-index ,n-env))
-		(n-entries `(compact-info-env-entries ,n-env))
-		(n-entries-info `(compact-info-env-entries-info ,n-env))
-		(n-type-numbers '*type-numbers*))
-      `(dotimes (,n-index (length ,n-table))
-	 (declare (type index ,n-index))
-	 (block ,PUNT
-	   (let ((,name-var (svref ,n-table ,n-index)))
-	     (unless (eql ,name-var 0)
-	       (do-anonymous ((,n-type (aref ,n-entries-index ,n-index)
-				       (1+ ,n-type)))
-			     (nil)
-		 (declare (type index ,n-type))
-		 ,(once-only ((n-info `(aref ,n-entries-info ,n-type)))
-		    `(let ((,type-number-var
-			    (logand ,n-info compact-info-entry-type-mask)))
-		       ,(once-only ((n-type-info
-				     `(svref ,n-type-numbers
-					     ,type-number-var)))
-			  `(let ((,type-var (type-info-name ,n-type-info))
-				 (,class-var (class-info-name
-					      (type-info-class ,n-type-info)))
-				 (,value-var (svref ,n-entries ,n-type)))
-			     #+new-compiler
-			     (declare (ignorable ,type-var ,class-var
-						 ,value-var))
-			     ,@body
-			     (unless (zerop (logand ,n-info compact-info-entry-last))
-			       (return-from ,PUNT))))))))))))))
-
-;;; DO-VOLATILE-INFO  --  Internal
-;;;
-;;;    Return code to iterate over a volatile info environment.
-;;;
-(defun do-volatile-info (name-var class-var type-var type-number-var value-var
-				  n-env body)
-  (let ((n-index (gensym)) (n-names (gensym)) (n-types (gensym)))
-    (once-only ((n-table `(volatile-info-env-table ,n-env))
-		(n-type-numbers '*type-numbers*))
-      `(dotimes (,n-index (length ,n-table))
-	 (do-anonymous ((,n-names (svref ,n-table ,n-index)
-				  (cdr ,n-names)))
-		       ((null ,n-names))
-	   (let ((,name-var (caar ,n-names)))
-	     #+new-compiler
-	     (declare (ignorable ,name-var))
-	     (do-anonymous ((,n-types (cdar ,n-names) (cdr ,n-types)))
-			   ((null ,n-types))
-	       (let ((,type-number-var (caar ,n-types)))
-		 ,(once-only ((n-type `(svref ,n-type-numbers
-					      ,type-number-var)))
-		    `(let ((,type-var (type-info-name ,n-type))
-			   (,class-var (class-info-name
-					(type-info-class ,n-type)))
-			   (,value-var (cdar ,n-types)))
-		       #+new-compiler
-		       (declare (ignorable ,type-var ,class-var ,value-var))
-		       ,@body))))))))))
-
-
-); Eval-When (Compile Load Eval)
-
-
-;;;; Compact environments:
-
-;;; The upper limit on the size of the ENTRIES vector in a COMPACT-INFO-ENV.
-;;;
-(defconstant compact-info-env-entries-bits 16)
-(deftype compact-info-entries-index () `(unsigned-byte ,compact-info-env-entries-bits))
-
-
-;;; Type of the values in COMPACT-INFO-ENTRIES-INFO.
-;;;
-(deftype compact-info-entry () `(unsigned-byte ,(1+ type-number-bits)))
-
-
-;;; This is an open hashtable with rehashing.  Since modification is not
-;;; allowed, we don't have to worry about deleted entries.  We indirect through
-;;; a parallel vector to find the index in the ENTRIES at which the entries for
-;;; a given name starts.
-;;;
-(defstruct (compact-info-env
-	    (:include info-env)
-	    (:print-function %print-info-environment))
-  ;;
-  ;; If this value is EQ to the name we want to look up, then the cache hit
-  ;; function can be called instead of the lookup function.
-  (cache-name 0)
-  ;;
-  ;; The index in ENTRIES for the CACHE-NAME, or NIL if that name has no
-  ;; entries.
-  (cache-index nil :type (or compact-info-entries-index null))
-  ;;
-  ;; Hashtable of the names in this environment.  If a bucket is unused, it is
-  ;; 0.
-  (table nil :type simple-vector)
-  ;;
-  ;; Indirection vector parallel to TABLE, translating indices in TABLE to the
-  ;; start of the ENTRIES for that name.  Unused entries are undefined.
-  (index nil :type (simple-array compact-info-entries-index (*)))
-  ;;
-  ;; Vector contining in contiguous ranges the values of for all the types of
-  ;; info for each name.
-  (entries nil :type simple-vector)
-  ;;
-  ;; Vector parallel to ENTRIES, indicating the type number for the value
-  ;; stored in that location and whether this location is the last type of info
-  ;; stored for this name.  The type number is in the low TYPE-NUMBER-BITS
-  ;; bits, and the next bit is set if this is the last entry.
-  (entries-info nil :type (simple-array compact-info-entry (*))))
-
-
-(defconstant compact-info-entry-type-mask (ldb (byte type-number-bits 0) -1))
-(defconstant compact-info-entry-last (ash 1 type-number-bits))
-
-
-;;; COMPACT-INFO-CACHE-HIT  --  Internal
-;;;
-;;;    Return the value of the type corresponding to Number for the currently
-;;; cached name in Env.
-;;;
-(proclaim '(inline compact-info-cache-hit))
-(defun compact-info-cache-hit (env number)
-  (declare (type compact-info-env env) (type type-number number))
-  (let ((entries-info (compact-info-env-entries-info env))
-	(index (compact-info-env-cache-index env)))
-    (if index
-	(do ((index index (1+ index)))
-	    (nil)
-	  (declare (type index index))
-	  (let ((info (aref entries-info index)))
-	    (when (= (logand info compact-info-entry-type-mask) number)
-	      (return (values (svref (compact-info-env-entries env) index)
-			      t)))
-	    (unless (zerop (logand compact-info-entry-last info))
-	      (return (values nil nil)))))
-	(values nil nil))))
-
-
-;;; COMPACT-INFO-LOOKUP  --  Internal
-;;;
-;;;    Encache Name in the compact environment Env.  Hash is the INFO-HASH of
-;;; Name.
-;;;
-(defun compact-info-lookup (env name hash)
-  (declare (type compact-info-env env) (type index hash))
-  (let* ((table (compact-info-env-table env))
-	 (len (length table))
-	 (len-2 (- len 2))
-	 (hash2 (- len-2 (rem hash len-2))))
-    (macrolet ((lookup (test)
-		 `(do ((probe (rem hash len)
-			      (rem (+ probe hash2) len)))
-		      (nil)
-		    (let ((entry (svref table probe)))
-		      (when (eql entry 0)
-			(return nil))
-		      (when (,test entry name)
-			(return (aref (compact-info-env-index env)
-				      probe)))))))
-      (setf (compact-info-env-cache-index env)
-	    (if (symbolp name)
-		(lookup eq)
-		(lookup equal)))
-      (setf (compact-info-env-cache-name env) name)))
-
-  (undefined-value))
-
-
-;;; Exact density (modulo rounding) of the hashtable in a compact info
-;;; environment in names/bucket.
-;;;
-(defconstant compact-info-environment-density 0.65)
-
-
-;;; COMPACT-INFO-ENVIRONMENT  --  Public
-;;;
-;;;    Iterate over the environment once to find out how many names and entries
-;;; it has, then build the result.  This code assumes that all the entries for
-;;; a name well be iterated over contiguously, which holds true for the
-;;; implementation of iteration over both kinds of environments.
-;;; 
-(defun compact-info-environment (env &key (name (info-env-name env)))
-  "Return a new compact info environment that holds the same information as
-  Env."
-  (let ((name-count 0)
-	(prev-name 0)
-	(entry-count 0))
-    (do-info (env :name name)
-      (unless (eq name prev-name)
-	(incf name-count)
-	(setq prev-name name))
-      (incf entry-count))
-    
-    (let* ((table-size
-	    (primify
-	     (+
-	      (truncate
-	       (/ name-count compact-info-environment-density))
-	      3)))
-	   (table (make-array table-size :initial-element 0))
-	   (index (make-array table-size
-			      :element-type 'compact-info-entries-index))
-	   (entries (make-array entry-count))
-	   (entries-info (make-array entry-count
-				     :element-type 'compact-info-entry)))
-
-      (let ((prev-name 0)
-	    (entries-idx 0))
-	(do-info (env :name name :type-number num :value value)
-	  (unless (eq prev-name name)
-	    (setq prev-name name)
-	    (let* ((hash (info-hash name))
-		   (len-2 (- table-size 2))
-		   (hash2 (- len-2 (rem hash len-2))))
-	      (do ((probe (rem hash table-size)
-			  (rem (+ probe hash2) table-size)))
-		  (nil)
-		(let ((entry (svref table probe)))
-		  (when (eql entry 0)
-		    (setf (svref table probe) name)
-		    (setf (aref index probe) entries-idx)
-		    (return))
-		  (assert (not (equal entry name))))))
-	    
-	    (unless (zerop entries-idx)
-	      (setf (aref entries-info (1- entries-idx)) 
-		    (logior (aref entries-info (1- entries-idx))
-			    compact-info-entry-last))))
-	  
-	  (setf (aref entries-info entries-idx) num)
-	  (setf (aref entries entries-idx) value)
-	  (incf entries-idx)))
-
-      (unless (zerop entry-count)
-	(setf (aref entries-info (1- entry-count)) 
-	      (logior (aref entries-info (1- entry-count))
-		      compact-info-entry-last)))
-      
-      (make-compact-info-env :name name
-			     :table table
-			     :index index
-			     :entries entries
-			     :entries-info entries-info))))
-      
-      
-
-;;;; Volatile environments:
-
-;;; This is a closed hashtable, with the bucket being computed by taking the
-;;; INFO-HASH of the Name mod the table size.
-;;;
-(defstruct (volatile-info-env
-	    (:include info-env)
-	    (:print-function %print-info-environment))
-
-  ;;
-  ;; If this value is EQ to the name we want to look up, then the cache hit
-  ;; function can be called instead of the lookup function.
-  (cache-name 0)
-  ;;
-  ;; The alist translating type numbers to values for the currently cached
-  ;; name.
-  (cache-types nil :type list)
-  ;;
-  ;; Vector of alists of alists of the form:
-  ;;    ((Name . ((Type-Number . Value) ...) ...)
-  ;;
-  (table nil :type simple-vector)
-  ;;
-  ;; The number of distinct names currently in this table (each name may have
-  ;; multiple entries, since there can be many types of info.
-  (count 0 :type index)
-  ;;
-  ;; The number of names at which we should grow the table and rehash.
-  (threshold nil :type index))
-
-
-;;; VOLATILE-INFO-CACHE-HIT  --  Internal
-;;;
-;;;    Just like COMPACT-INFO-CACHE-HIT, only do it on a volatile environment.
-;;;
-(proclaim '(inline volatile-info-cache-hit))
-(defun volatile-info-cache-hit (env number)
-  (declare (type volatile-info-env env) (type type-number number))
-  (dolist (type (volatile-info-env-cache-types env) (values nil nil))
-    (when (eql (car type) number)
-      (return (values (cdr type) t)))))  
-
-
-;;; VOLATILE-INFO-LOOKUP  --  Internal
-;;;
-;;;    Just like COMPACT-INFO-LOOKUP, only do it on a volatile environment.
-;;;
-(defun volatile-info-lookup (env name hash)
-  (declare (type volatile-info-env env) (type index hash))
-  (let ((table (volatile-info-env-table env)))
-    (macrolet ((lookup (test)
-		 `(dolist (entry (svref table (mod hash (length table))) ())
-		    (when (,test (car entry) name)
-		      (return (cdr entry))))))
-      (setf (volatile-info-env-cache-types env)
-	    (if (symbolp name)
-		(lookup eq)
-		(lookup equal)))
-      (setf (volatile-info-env-cache-name env) name)))
-
-  (undefined-value))
-
-
-;;; WITH-INFO-BUCKET  --  Internal
-;;;
-;;;    Given a volatile environment Env, bind Table-Var the environment's table
-;;; and Index-Var to the index of Name's bucket in the table.  We also flush
-;;; the cache so that things will be consistent if body modifies something.
-;;;
-(eval-when (compile eval)
-  (defmacro with-info-bucket ((table-var index-var name env) &body body)
-    (once-only ((n-name name)
-		(n-env env))
-      `(progn
-	 (setf (volatile-info-env-cache-name ,n-env) 0)
-	 (let* ((,table-var (volatile-info-env-table ,n-env))
-		(,index-var (mod (info-hash ,n-name) (length ,table-var))))
-	   ,@body)))))
-
-
-;;; GET-WRITE-INFO-ENV  --  Internal
-;;;
-;;;    Get the info environment that we use for write/modification operations.
-;;; This is always the first environment in the list, and must be a
-;;; VOLATILE-INFO-ENV.
-;;;
-(proclaim '(inline get-write-info-env))
-(defun get-write-info-env ()
-  (let ((env (car *info-environment*)))
-    (unless env
-      (error "No info environment?"))
-    (unless (typep env 'volatile-info-env)
-      (error "Cannot modify this environment: ~S." env))
-    (the volatile-info-env env)))
-
-
-;;; SET-INFO-VALUE  --  Internal
-;;;
-;;;    If Name is already present in the table, then just create or modify the
-;;; specified type.  Otherwise, add the new name and type, checking for
-;;; rehashing.
-;;;
-;;;    We rehash by making a new larger environment, copying all of the entries
-;;; into it, then clobbering the old environment with the new environment's
-;;; table.  We clear the old table to prevent it from holding onto garbage if
-;;; it is statically allocated.
-;;;
-(defun set-info-value (name type new-value &optional
-			    (env (get-write-info-env)))
-  (declare (type type-number type) (type volatile-info-env env)
-	   (inline assoc))
-  (when (eql name 0)
-    (error "0 is not a legal INFO name."))
-  (with-info-bucket (table index name env)
-    (let ((types (if (symbolp name)
-		     (assoc name (svref table index) :test #'eq)
-		     (assoc name (svref table index) :test #'equal))))
-      (cond
-       (types
-	(let ((value (assoc type (cdr types))))
-	  (if value
-	      (setf (cdr value) new-value)
-	      (push (cons type new-value) (cdr types)))))
-       (t
-	(push (cons name (list (cons type new-value)))
-	      (svref table index))
-
-	(let ((count (incf (volatile-info-env-count env))))
-	  (when (>= count (volatile-info-env-threshold env))
-	    (let ((new (make-info-environment :size (* count 2))))
-	      (do-info (env :name entry-name :type-number entry-num
-			    :value entry-val)
-		(set-info-value entry-name entry-num entry-val new))
-	      (fill (volatile-info-env-table env) nil)
-	      (setf (volatile-info-env-table env)
-		    (volatile-info-env-table new))
-	      (setf (volatile-info-env-threshold env)
-		    (volatile-info-env-threshold new)))))))))
-	  
-  new-value)
-
-
-;;; The maximum density of the hashtable in a volatile env (in names/bucket).
-;;;
-(defconstant volatile-info-environment-density 0.5)
-
-
-;;; MAKE-INFO-ENVIRONMENT  --  Public
-;;;
-;;;    Make a new volatile environment of the specified size.
-;;;
-(defun make-info-environment (&key (size 42) (name "Unknown"))
-  (declare (type (integer 1) size))
-  (let ((table-size
-	 (primify
-	  (truncate
-	   (/ size volatile-info-environment-density)))))
-    (make-volatile-info-env
-     :name name
-     :table (make-array table-size :initial-element nil)
-     :threshold size)))
-
-
-;;; CLEAR-INFO  --  Public
-;;;
-(defmacro clear-info (class type name)
-  "Clear the information of the the specified Type and Class for Name in the
-  current environment, allowing any inherited info to become visible.  We
-  return true if there was any info."
-  (let* ((class (symbol-name class))
-	 (type (symbol-name type))
-	 (info (type-info-or-lose class type)))
-    `(clear-info-value ,name ,(type-info-number info))))
-;;;
-(defun clear-info-value (name type)
-  (declare (type type-number type) (inline assoc))
-  (with-info-bucket (table index name (get-write-info-env))
-    (let ((types (assoc name (svref table index) :test #'equal)))
-      (when (and types
-		 (assoc type (cdr types)))
-	(setf (cdr types)
-	      (delete type (cdr types) :key #'car))
-	t))))
-
-
-;;; GET-INFO-VALUE  --  Internal
-;;;
-;;;    Return the value from the first environment which has it defined, or
-;;; return the default if none does.  We have a cache for the last name looked
-;;; up in each environment.  We don't compute the hash until the first time the
-;;; cache misses.  When the cache does miss, we invalidate it before calling
-;;; the lookup routine to eliminate the possiblity of the cache being
-;;; partially updated if the lookup is interrupted.
-;;;
-(defun get-info-value (name type)
-  (declare (type type-number type))
-  (let ((hash nil))
-    (dolist (env *info-environment*
-		 (multiple-value-bind
-		     (val winp)
-		     (funcall (type-info-default (svref *type-numbers* type))
-			       name)
-		   (values val winp)))
-      (macrolet ((frob (lookup cache slot)
-		   `(progn
-		      (unless (eq name (,slot env))
-			(unless hash
-			  (setq hash (info-hash name)))
-			(setf (,slot env) 0)
-			(,lookup env name hash))
-		      (multiple-value-bind
-			  (value winp)
-			  (,cache env type)
-			(when winp (return (values value t)))))))
-      (if (typep env 'volatile-info-env)
-	  (frob volatile-info-lookup volatile-info-cache-hit
-	        volatile-info-env-cache-name)
-	  (frob compact-info-lookup compact-info-cache-hit
-	        compact-info-env-cache-name))))))
-
-
-;;;; Initialization:
-
-;;; GLOBALDB-INIT  --  Interface
-;;;
-;;;    Since the global enviornment database is used by top-level forms in this
-;;; file, we must initialize the database before processing any top-level
-;;; forms.  This requires a special initialization function that is called from
-;;; %INITIAL-FUNCTION.  We replicate the init forms of the variables that
-;;; maintain the class/type namespace.
-;;;
-(defun globaldb-init ()
-  (setq *info-environment*
-	(list (make-info-environment :name "Initial Global")))
-  (unless (boundp '*info-classes*)
-    (setq *info-classes* (make-hash-table :test #'equal))
-    (setq *type-numbers*
-	  (make-array (ash 1 type-number-bits)  :initial-element nil)))
-  (function-info-init)
-  (other-info-init))
-
-
-;;;; Definitions for function information.
-
-(defun function-info-init ()
-
-(define-info-class function)
-
-;;; The kind of functional object being described.  If null, Name isn't a known
-;;; functional object.
-(define-info-type function kind (member nil :function :macro :special-form)
-  #+new-compiler
-  (if (fboundp name) :function nil)
-  #-new-compiler
-  nil)
-
-;;; The type specifier for this function.
-(define-info-type function type ctype
-  #+new-compiler
-  (if (fboundp name)
-      (let ((def (fdefinition name)))
-	(let ((entry (if (eql (%primitive get-vector-subtype def)
-			      %function-closure-subtype)
-			 (%primitive header-ref def %function-name-slot)
-			 def)))
-	  (specifier-type
-	   (%primitive header-ref entry %function-entry-type-slot))))
-      (specifier-type 'function))
-  #-new-compiler
-  (specifier-type 'function))
-
-;;; The Assumed-Type for this function, if we have to infer the type due to not
-;;; having a declaration or definition.
-(define-info-type function assumed-type (or approximate-function-type null))
-
-;;; Where this information came from:
-;;;  :declared, from a declaration.
-;;;  :assumed, from uses of the object.
-;;;  :defined, from examination of the definition.
-(define-info-type function where-from (member :declared :assumed :defined)
-  #+new-compiler
-  (if (fboundp name) :defined :assumed)
-  #-new-compiler
-  :assumed)
-
-;;; Lambda used for inline expansion of this function.
-(define-info-type function inline-expansion list)
-
-;;; Specifies whether this function may be expanded inline.  If null, we
-;;; don't care.
-(define-info-type function inlinep inlinep nil)
-
-;;; A macro-like function which transforms a call to this function into some
-;;; other Lisp form.  This expansion is inhibited if inline expansion is
-;;; inhibited.
-(define-info-type function source-transform (or function null
-						#-new-compiler list))
-
-;;; The macroexpansion function for this macro.
-(define-info-type function macro-function (or function null
-					      #-new-compiler list)
-  nil)
-
-;;; A function which converts this special form into IR1.
-(define-info-type function ir1-convert (or function null
-					   #-new-compiler list))
-
-;;; A function which gets a chance to do stuff to the IR1 for any call to this
-;;; function.
-(define-info-type function ir1-transform (or function null
-					     #-new-compiler list))
-
-;;; If a function is an alien-operator, then this is the Alien-Info.
-(define-info-type function alien-operator (or lisp::alien-info null) nil)
-
-;;; If a function is a defstruct slot accessor or setter, then this is the
-;;; defstruct-definition for the structure that it belongs to.
-(define-info-type function accessor-for (or defstruct-description null)
-  nil)
-
-;;; If a function is "known" to the compiler, then this is FUNCTION-INFO
-;;; structure containing the info used to special-case compilation.
-(define-info-type function info (or function-info null) nil)
-
-(define-info-type function documentation (or string null) nil)
-
-); defun function-info-init
-
-#|
-  Other:
-    Documentation?
-|#
-
-;;;; Definitions for other random information.
-
-(defun other-info-init ()
-
-(define-info-class variable)
-
-;;; The kind of variable-like thing described.
-(define-info-type variable kind (member :special :constant :global)
-  #+new-compiler
-  (if (or (eq (symbol-package name) (symbol-package :end))
-	  (member name '(t nil)))
-      :constant
-      :global)
-  #-new-compiler
-  (if (constantp name)
-      :constant
-      :global))
-
-;;; The declared type for this variable.
-(define-info-type variable type ctype *universal-type*)
-
-;;; Where this type and kind information came from.
-(define-info-type variable where-from (member :declared :assumed :defined)
-  :assumed)
-
-;;; The the lisp object which is the value of this constant, if known.
-(define-info-type variable constant-value t
-  #+new-compiler
-  (if (boundp name)
-      (values (symbol-value name) t)
-      (values nil nil))
-  #-new-compiler
-  (if (constantp name)
-      (values (symbol-value name) t)
-      (values nil nil)))
-
-(define-info-type variable alien-value (or lisp::ct-a-val null) nil)
-
-(define-info-type variable documentation (or string null) nil)
-
-(define-info-class type)
-
-;;; The kind of type described.  We return :Structure for standard types that
-;;; are implemented as structures.
-;;;
-(define-info-type type kind (member :primitive :defined :structure nil)
-  (if (member name type-specifier-symbols)
-      :primitive
-      nil))
-
-;;; Expander function for a defined type.
-(define-info-type type expander (or function null
-				    #-new-compiler list) nil)
-
-;;; Print function for a type.
-(define-info-type type printer (or function symbol null
-				   #-new-compiler list) nil)
-
-;;; Defstruct description information for a structure type.  DEFINED is the
-;;; current global definition, and is not shadowed by compilation of
-;;; structure definitions.
-;;;
-(define-info-type type structure-info (or defstruct-description null) nil)
-(define-info-type type defined-structure-info (or defstruct-description null)
-  nil)
-
-(define-info-type type documentation (or string null))
-
-(define-info-class declaration)
-(define-info-type declaration recognized boolean)
-
-(define-info-class alien-stack)
-(define-info-type alien-stack info (or lisp::stack-info null) nil)
-
-(define-info-class enumeration)
-(define-info-type enumeration info (or lisp::enumeration-info null) nil)
-
-(define-info-class setf)
-
-(define-info-type setf inverse (or symbol null) nil)
-
-(define-info-type setf documentation (or string null) nil)
-
-(define-info-type setf expander (or function null 
-				    #-new-compiler list) nil)
-
-;;; Used for storing random documentation types.  The stuff is an alist
-;;; translating documentation kinds to values.
-;;;
-(define-info-class random-documentation)
-(define-info-type random-documentation stuff list ())
-
-); defun other-info-init
diff --git a/compiler/globals.lisp b/compiler/globals.lisp
deleted file mode 100644
index 7ddafee38d9b17efb5a0ce6268cee2edbff25c54..0000000000000000000000000000000000000000
--- a/compiler/globals.lisp
+++ /dev/null
@@ -1,14 +0,0 @@
-
-(in-package "C")
-(proclaim '(special
-	    *defprint-pretty* *event-info* *event-note-threshold*
-	    *instruction-formats* *instructions* *current-fixup* *first-fixup*
-	    *next-location* *code-vector* *labels* *current-label*
-	    *last-label-created* *assembler-nodes* *current-assembler-node*
-	    *last-assembler-node-created* *other-code-vector*
-	    *other-next-location* *fixup-offset* *fixup-offset-map*
-	    *fixup-last-shortening* *result-fixups* *source-path-tree*
-	    *sc-numbers* *sb-list* *template-names* *sc-names* *sb-names*
-	    *meta-sc-numbers* *primitive-type-names* *move-costs* *save-scs*
-	    *save-costs* *restore-costs* *parsed-vops*
-	    *compiler-error-context*))
diff --git a/compiler/gtn.lisp b/compiler/gtn.lisp
deleted file mode 100644
index 3a69161fd2a7e709eda1c3e23cc4e682784a03c0..0000000000000000000000000000000000000000
--- a/compiler/gtn.lisp
+++ /dev/null
@@ -1,225 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    This file contains the GTN pass in the compiler.  GTN allocates the TNs
-;;; that hold the values of lexical variables and determines the calling
-;;; conventions and passing locations used in function calls.
-;;;
-;;; ### For now, restrict all passing locations to T so that the special move
-;;; operations for call/return don't have to worry about doing representation
-;;; conversions.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-
-;;; GTN-Analyze  --  Interface
-;;;
-;;;    We make a pass over the component's environments, assigning argument
-;;; passing locations and return conventions and TNs for local variables.
-;;;
-(defun gtn-analyze (component)
-  (setf (component-info component) (make-ir2-component))
-  (let ((funs (component-lambdas component)))
-    (dolist (fun funs)
-      (assign-ir2-environment fun)
-      (assign-return-locations fun)
-      (assign-ir2-nlx-info fun)
-      (assign-lambda-var-tns fun nil)
-      (dolist (let (lambda-lets fun))
-	(assign-lambda-var-tns let t))))
-
-  (undefined-value))
-
-
-;;; Assign-Lambda-Var-TNs  --  Internal
-;;;
-;;;    We have to allocate the home TNs for variables before we can call
-;;; Assign-IR2-Environment so that we can close over TNs that haven't had their
-;;; home environment assigned yet.  Let-P indicates whether this variable is
-;;; for a let or a "real argument".  In the latter case, we allocate the TNs
-;;; environment-live unless SPEED is 3 so that the values are always available
-;;; in the debugger.
-;;;
-(defun assign-lambda-var-tns (fun let-p)
-  (declare (type clambda fun))
-  (dolist (var (lambda-vars fun))
-    (when (leaf-refs var)
-      (let* ((type (if (lambda-var-indirect var)
-		       *any-primitive-type*
-		       (primitive-type (leaf-type var))))
-	     (res (if (or let-p
-			  (policy (lambda-bind fun) (= speed 3)))
-		      (make-normal-tn type)
-		      (make-environment-tn type (lambda-environment fun)))))
-	(setf (tn-leaf res) var)
-	(setf (leaf-info var) res))))
-  (undefined-value))
-
-
-;;; Assign-IR2-Environment  --  Internal
-;;;
-;;;    Give an IR2-Environment structure to Fun.  We allocate TNs for argument
-;;; passing locations at this point.  XEPs differ in that the argument passing
-;;; locations are wired and there are no implicit environment arguments.
-;;;
-(defun assign-ir2-environment (fun)
-  (declare (type clambda fun))
-  (let ((env (lambda-environment fun))
-	(xep-p (external-entry-point-p fun)))
-    (collect ((args)
-	      (env))
-      
-      (do ((vars (lambda-vars fun) (rest vars))
-	   (i -1 (1+ i)))
-	  ((null vars))
-	(let ((var (first vars)))
-	  (when (leaf-refs var)
-	    (args (if xep-p
-		      (if (minusp i)
-			  (make-argument-count-location)
-			  (standard-argument-location i))
-		      (make-normal-tn #|(primitive-type (leaf-type var))||#
-				      *any-primitive-type*))))))
-      
-      (dolist (thing (environment-closure env))
-	(let ((ptype (etypecase thing
-		       (lambda-var (primitive-type (leaf-type thing)))
-		       (nlx-info *any-primitive-type*))))
-	  (unless xep-p 
-	    (args (make-normal-tn ptype)))
-	  (env (cons thing (make-normal-tn ptype)))))
-
-      (let ((res 
-	     (make-ir2-environment
-	      :arg-locs (args)  :environment (env)
-	      :old-cont-pass (make-old-cont-passing-location xep-p)
-	      :return-pc-pass (make-return-pc-passing-location xep-p)
-	      :argument-pointer (make-argument-pointer-location xep-p))))
-	(setf (environment-info env) res)
-	(setf (ir2-environment-old-cont res)
-	      (make-old-cont-save-location env))
-	(setf (ir2-environment-return-pc res)
-	      (make-return-pc-save-location env)))))
-  
-  (undefined-value))
-
-
-;;; Has-Full-Call-Use  --  Internal
-;;;
-;;;    Return true if Fun's result continuation is used in a TR full call.  We
-;;; only consider explicit :Full calls.  It is assumed that known calls are
-;;; never part of a tail-recursive loop, so we don't need to enforce
-;;; tail-recursion.  In any case, we don't know which known calls will
-;;; actually be full calls until after LTN.
-;;;
-(defun has-full-call-use (fun)
-  (declare (type clambda fun))
-  (do-uses (use (return-result (lambda-return fun)) nil)
-    (when (and (node-tail-p use)
-	       (basic-combination-p use)
-	       (eq (basic-combination-kind use) :full))
-      (return t))))
-
-
-;;; Use-Standard-Returns  --  Internal
-;;;
-;;;    Return true if we should use the standard (unknown) return convention
-;;; for a tail-set.  We use the standard return convention when:
-;;; -- We must use the standard convention to preserve tail-recursion, since
-;;;    the tail-set contains both an XEP and a TR full call.
-;;; -- It appears to be more efficient to use the standard convention, since
-;;;    there are no non-TR local calls that could benefit from a non-standard
-;;;    convention.
-;;;
-(defun use-standard-returns (tails)
-  (declare (type tail-set tails))
-  (let ((funs (tail-set-functions tails)))
-    (or (and (find-if #'external-entry-point-p funs)
-	     (find-if #'has-full-call-use funs))
-	(block punt
-	  (dolist (fun funs t)
-	    (dolist (ref (leaf-refs fun))
-	      (let* ((cont (node-cont ref))
-		     (dest (continuation-dest cont)))
-		(when (and (not (node-tail-p dest))
-			   (basic-combination-p dest)
-			   (eq (basic-combination-fun dest) cont)
-			   (eq (basic-combination-kind dest) :local))
-		  (return-from punt nil)))))))))
-
-
-;;; Return-Info-For-Set  --  Internal
-;;;
-;;;    Return a Return-Info structure describing how we should return from
-;;; functions in the specified tail set.  We use the unknown values convention
-;;; if the number of values is unknown, or if it is a good idea for some other
-;;; reason.  Otherwise we allocate passing locations for a fixed number of
-;;; values.
-;;;
-(defun return-info-for-set (tails)
-  (declare (type tail-set tails))
-  (multiple-value-bind (types count)
-		       (values-types (tail-set-type tails))
-    (let ((ptypes #|(mapcar #'primitive-type types)|#
-		  (make-list (length types)
-			     :initial-element *any-primitive-type*)))
-      (if (or (eq count :unknown)
-	      (use-standard-returns tails))
-	  (make-return-info :kind :unknown  :count count  :types ptypes)
-	  (make-return-info
-	   :kind :fixed
-	   :count count
-	   :types ptypes
-	   :locations (mapcar #'make-normal-tn ptypes))))))
-
-
-;;; Assign-Return-Locations  --  Internal
-;;;
-;;;    If Env has a Tail-Set, and the Tail-Set doesn't have any Info, then make
-;;; a Return-Info for it.  If we choose a return convention other than
-;;; :Unknown, and this environment is for an XEP, then break tail recursion on
-;;; the XEP calls, since we must always use unknown values when returining from
-;;; an XEP.
-;;;
-(defun assign-return-locations (fun)
-  (declare (type clambda fun))
-  (let ((tails (lambda-tail-set fun)))
-    (when tails
-      (let ((returns (or (tail-set-info tails)
-			 (setf (tail-set-info tails)
-			       (return-info-for-set tails)))))
-	(when (and (not (eq (return-info-kind returns) :unknown))
-		   (external-entry-point-p fun))
-	  (do-uses (use (return-result (lambda-return fun)))
-	    (setf (node-tail-p use) nil))))))
-  (undefined-value))
-
-
-;;; Assign-IR2-NLX-Info  --  Internal
-;;;
-;;;   Make an IR2-NLX-Info structure for each NLX entry point recorded.  We
-;;; make the Save-SP an environment TN and force it to stack so that it can be
-;;; referenced on NLX entry.  The NLX-Entry VOP's :Force-To-Stack Save-P value
-;;; doesn't do this, since the SP is an argument to the VOP, and thus isn't
-;;; live afterwards.
-;;; 
-(defun assign-ir2-nlx-info (fun)
-  (declare (type clambda fun))
-  (let ((env (lambda-environment fun)))
-    (dolist (nlx (environment-nlx-info env))
-      (let ((sp (make-environment-tn *any-primitive-type* env)))
-	(force-tn-to-stack sp)
-	(setf (nlx-info-info nlx)
-	      (make-ir2-nlx-info
-	       :home (when (eq (cleanup-kind (nlx-info-cleanup nlx)) :entry)
-		       (make-normal-tn *any-primitive-type*))
-	       :save-sp sp)))))
-  (undefined-value))
diff --git a/compiler/ir1final.lisp b/compiler/ir1final.lisp
deleted file mode 100644
index df343047601ffd907c2d29ff0449228913a123a2..0000000000000000000000000000000000000000
--- a/compiler/ir1final.lisp
+++ /dev/null
@@ -1,100 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    This file implements the IR1 finalize phase, which checks for various
-;;; semantic errors.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-
-;;; IR1-Finalize  --  Interface
-;;;
-;;; We do a number of things:
-;;;  2] Find any unknown free functions.
-;;;  3] Accumulate approximate function type info for unknown functions.
-;;;  4] Update the global type for functions newly defined.
-;;;  5] Emit any delayed notes about failed optimizations.
-;;;
-(proclaim '(function ir1-finalize () void))
-(defun ir1-finalize ()
-  (maphash #'check-free-function *free-functions*)
-  (maphash #'note-failed-optimization *failed-optimizations*))
-
-
-;;; Note-Failed-Optimization  --  Internal
-;;;
-;;;    Give the user grief about optimizations that we weren't able to do.  It
-;;; is assumed that they want to hear, or there wouldn't be any entries in the
-;;; table.  If the node has been deleted or is no longer a known call, then do
-;;; nothing; some other optimization must have gotten to it.
-;;;
-(proclaim '(function note-failed-optimization (combination (or list ctype))
-		     void))
-(defun note-failed-optimization (node what)
-  (unless (or (node-deleted node)
-	      (not (function-info-p (combination-kind node))))
-    (let ((*compiler-error-context* node))
-      (cond ((listp what)
-	     (compiler-note "Unable to optimize because:~%~6T~?"
-			    (first what) (rest what)))
-	    (t
-	     (collect ((messages))
-	       (flet ((frob (string &rest stuff)
-			(messages string)
-			(messages stuff)))
-		 (valid-function-use node what
-				     :warning-function #'frob
-				     :error-function #'frob))
-	       
-	       (compiler-note "Unable to optimize due to type uncertainty:~@
-	                       ~{~6T~?~^~&~}"
-			      (messages))))))))
-
-	  
-;;; Check-Free-Function  --  Internal
-;;;
-;;;    If the entry is a functional, then we update the global environment
-;;; according to the new definition, checking for inconsistency.  If the entry
-;;; is an unknown global function, then we add the uses into the function's
-;;; approximate type.
-;;;
-(proclaim '(function check-free-function (t leaf) void))
-(defun check-free-function (name leaf)
-  (etypecase leaf
-    (functional
-     (let* ((where (info function where-from name))
-;	    (type (info function type name))
-	    (dtype (definition-type leaf))
-	    (node (lambda-bind (main-entry leaf)))
-	    (*compiler-error-context* node))
-       (setq *unknown-functions*
-	     (delete name *unknown-functions*
-		     :test #'equal
-		     :key #'unknown-function-name))
-
-       (ecase where
-	 (:assumed
-	  (let ((approx-type (info function assumed-type name)))
-	    (when approx-type
-	      (valid-approximate-type approx-type dtype))))
-	 ((:declared :defined)
-;	  ...
-	  ))
-
-       (when (and (eq (function-type-returns dtype) *empty-type*)
-		  (policy node (>= safety brevity)))
-	 (compiler-note "Function does not return."))
-
-       (setf (info function kind name) :function)
-       (setf (info function where-from name) :defined)
-       (setf (info function type name) dtype)
-       (clear-info function assumed-type name)))
-    (global-var)))
diff --git a/compiler/ir1opt.lisp b/compiler/ir1opt.lisp
deleted file mode 100644
index 88b8572f8734636f01029fcce97fc9741f9008b3..0000000000000000000000000000000000000000
--- a/compiler/ir1opt.lisp
+++ /dev/null
@@ -1,1106 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    This file implements the IR1 optimization phase of the compiler.  IR1
-;;; optimization is a grab-bag of optimizations that don't make major changes
-;;; to the block-level control flow and don't use flow analysis.  These
-;;; optimizations can mostly be classified as "meta-evaluation", but there is a
-;;; sizable top-down component as well.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-;;;
-;;;    A hashtable from combination nodes to things describing how an
-;;; optimization of the node failed.  If the thing is a list, then it is format
-;;; arguments.  If it is a type, then the type is a type that the call failed
-;;; to match.
-;;;
-(defvar *failed-optimizations* (make-hash-table :test #'eq))
-
-
-;;;; Interface for obtaining results of constant folding:
-
-;;; Constant-Continuation-P  --  Interface
-;;;
-;;;    Return true if the sole use of Cont is a reference to a constant leaf.
-;;;
-(proclaim '(function constant-continuation-p (continuation) boolean))
-(defun constant-continuation-p (cont)
-  (let ((use (continuation-use cont)))
-    (and (ref-p use)
-	 (constant-p (ref-leaf use)))))
-
-
-;;; Continuation-Value  --  Interface
-;;;
-;;;    Return the constant value for a continuation whose only use is a
-;;; constant node.
-;;;
-(proclaim '(function continuation-value (continuation) t))
-(defun continuation-value (cont)
-  (constant-value (ref-leaf (continuation-use cont))))
-
-
-;;;; Interface for obtaining results of type inference:
-
-;;; CONTINUATION-PROVEN-TYPE  --  Interface
-;;;
-;;;    Return a (possibly values) type that describes what we have proven about
-;;; the type of Cont without taking any type assertions into consideration.
-;;; This is just the union of the NODE-DERIVED-TYPE of all the uses.  Most
-;;; often people use CONTINUATION-DERIVED-TYPE or CONTINUATION-TYPE instead of
-;;; using this function directly.
-;;;
-(defun continuation-proven-type (cont)
-  (declare (type continuation cont))
-  (ecase (continuation-kind cont)
-    ((:block-start :deleted-block-start)
-     (let ((uses (block-start-uses (continuation-block cont))))
-       (if uses
-	   (do ((res (node-derived-type (first uses))
-		     (values-type-union (node-derived-type (first current))
-					res))
-		(current (rest uses) (rest current)))
-	       ((null current) res))
-	   *empty-type*)))
-    (:inside-block
-     (node-derived-type (continuation-use cont)))))
-
-
-;;; Continuation-Derived-Type  --  Interface
-;;;
-;;;    Our best guess for the type of this continuation's value.  Note that
-;;; this may be Values or Function type, which cannot be passed as an argument
-;;; to the normal type operations.  See Continuation-Type.  This may be called
-;;; on deleted continuations, always returning *.
-;;;
-;;;    What we do is call CONTINUATION-PROVEN-TYPE and check whether the result
-;;; is a subtype of the assertion.  If so, return the proven type and set
-;;; TYPE-CHECK to nil.  Otherwise, return the intersection of the asserted and
-;;; proven types, and set TYPE-CHECK T.  If TYPE-CHECK already has a non-null
-;;; value, then preserve it.  Only in the somewhat unusual circumstance of
-;;; a newly discovered assertion will we change TYPE-CHECK from NIL to T.
-;;;
-;;;    The result value is cached in the Continuation-%Derived-Type.  If the
-;;; slot is true, just return that value, otherwise recompute and stash the
-;;; value there.
-;;;
-(proclaim '(inline continuation-derived-type))
-(defun continuation-derived-type (cont)
-  (declare (type continuation cont))
-  (or (continuation-%derived-type cont)
-      (%continuation-derived-type cont)))
-;;;
-(defun %continuation-derived-type (cont)
-  (declare (type continuation cont))
-  (let ((proven (continuation-proven-type cont))
-	(asserted (continuation-asserted-type cont)))
-    (cond ((values-subtypep proven asserted)
-	   (setf (continuation-%type-check cont) nil)
-	   (setf (continuation-%derived-type cont) proven))
-	  (t
-	   (unless (or (continuation-%type-check cont)
-		       (not (continuation-dest cont))
-		       (eq asserted *universal-type*))
-	     (setf (continuation-%type-check cont) t))
-
-	   (setf (continuation-%derived-type cont)
-		 (values-type-intersection asserted proven))))))
-
-
-;;; CONTINUATION-TYPE-CHECK  --  Interface
-;;;
-;;;    Call CONTINUATION-DERIVED-TYPE to make sure the slot is up to date, then
-;;; return it.
-;;;
-(proclaim '(inline continuation-type-check))
-(defun continuation-type-check (cont)
-  (declare (type continuation cont))
-  (continuation-derived-type cont)
-  (continuation-%type-check cont))
-
-
-;;; Continuation-Type  --  Interface
-;;;
-;;;    Return the derived type for Cont's first value.  This is guaranteed not
-;;; to be a Values or Function type.
-;;;
-(proclaim '(function continuation-type (continuation) type))
-(defun continuation-type (cont)
-  (single-value-type (continuation-derived-type cont)))
-
-
-;;;; Interface routines used by optimizers:
-
-;;; Reoptimize-Continuation  --  Interface
-;;;
-;;;    This function is called by optimizers to indicate that something
-;;; interesting has happened to the value of Cont.  Optimizers must make sure
-;;; that they don't call for reoptimization when nothing has happened, since
-;;; optimization will fail to terminate.
-;;;
-;;;    We clear any cached type for the continuation and set the reoptimize
-;;; flags on everything in sight, unless the continuation is deleted (in which
-;;; case we do nothing.)
-;;;
-;;;    Since this can get called curing IR1 conversion, we have to be careful
-;;; not to fly into space when the Dest's Prev is missing. 
-;;;
-(defun reoptimize-continuation (cont)
-  (declare (type continuation cont))
-  (unless (eq (continuation-kind cont) :deleted)
-    (setf (continuation-%derived-type cont) nil)
-    (let ((dest (continuation-dest cont)))
-      (when dest
-	(setf (continuation-reoptimize cont) t)
-	(setf (node-reoptimize dest) t)
-	(let ((prev (node-prev dest)))
-	  (when prev
-	    (let* ((block (continuation-block prev))
-		   (component (block-component block)))
-	      (setf (block-reoptimize block) t)
-	      (setf (component-reoptimize component) t))))))
-    (do-uses (node cont)
-      (setf (block-type-check (node-block node)) t)))
-  (undefined-value))
-
-
-;;; Derive-Node-Type  --  Interface
-;;;
-;;;    Annotate Node to indicate that its result has been proven to be typep to
-;;; RType.  After IR1 conversion has happened, this is the only correct way to
-;;; supply information discovered about a node's type.  If you fuck with the
-;;; Node-Derived-Type directly, then information may be lost and reoptimization
-;;; may not happen. 
-;;;
-;;;    What we do is intersect Rtype with Node's Derived-Type.  If the
-;;; intersection is different from the old type, then we do a
-;;; Reoptimize-Continuation on the Node-Cont.
-;;;
-(defun derive-node-type (node rtype)
-  (declare (type node node) (type ctype rtype))
-  (let ((node-type (node-derived-type node)))
-    (unless (eq node-type rtype)
-      (let ((int (values-type-intersection node-type rtype)))
-	(when (type/= node-type int)
-	  (setf (node-derived-type node) int)
-	  (reoptimize-continuation (node-cont node))))))
-  (undefined-value))
-
-
-;;; Assert-Continuation-Type  --  Interface
-;;;
-;;;    Similar to Derive-Node-Type, but asserts that it is an error for Cont's
-;;; value not to be typep to Type.  If we improve the assertion, we set
-;;; BLOCK-TYPE-CHECK to guarantee that the new assertion will be checked.
-;;;
-(defun assert-continuation-type (cont type)
-  (declare (type continuation cont) (type ctype type))
-  (let ((cont-type (continuation-asserted-type cont)))
-    (unless (eq cont-type type)
-      (let ((int (values-type-intersection cont-type type)))
-	(when (type/= cont-type int)
-	  (setf (continuation-asserted-type cont) int)
-	  (do-uses (node cont)
-	    (let ((block (node-block node)))
-	      (setf (block-type-check block) t)
-	      (setf (block-type-asserted block) t)))
-	  (reoptimize-continuation cont)))))
-  (undefined-value))
-
-
-;;; Assert-Call-Type  --  Interface
-;;;
-;;;    Assert that Call is to a function of the specified Type.  It is assumed
-;;; that the call is legal and has only constants in the keyword positions.
-;;;
-(defun assert-call-type (call type)
-  (declare (type combination call) (type function-type type))
-  (derive-node-type call (function-type-returns type))
-  (let ((args (combination-args call)))
-    (dolist (req (function-type-required type))
-      (when (null args) (return-from assert-call-type))
-      (let ((arg (pop args)))
-	(assert-continuation-type arg req)))
-    (dolist (opt (function-type-optional type))
-      (when (null args) (return-from assert-call-type))
-      (let ((arg (pop args)))
-	(assert-continuation-type arg opt)))
-
-    (let ((rest (function-type-rest type)))
-      (when rest
-	(dolist (arg args)
-	  (assert-continuation-type arg rest))))
-
-    (dolist (key (function-type-keywords type))
-      (let ((name (key-info-name key)))
-	(do ((arg args (cddr arg)))
-	    ((null arg))
-	  (when (eq (continuation-value (first arg)) name)
-	    (assert-continuation-type
-	     (second arg) (key-info-type key)))))))
-  (undefined-value))
-
-
-;;; IR1-Optimize  --  Interface
-;;;
-;;;    Do one forward pass over Component, deleting unreachable blocks and
-;;; doing IR1 optimizations.  We can ignore all blocks that don't have
-;;; Block-Reoptimize set.  If Component-Reoptimize is true when we are done,
-;;; then another iteration would be beneficial.
-;;;
-;;;    We delete blocks when there is either no predecessor or the block is in
-;;; a lambda that has been deleted.  These blocks would eventually be deleted
-;;; by DFO recomputation, but doing it here immediately makes the effect
-;;; avaliable to IR1 optimization.
-;;;
-(defun ir1-optimize (component)
-  (declare (type component component))
-  (setf (component-reoptimize component) nil)
-  (do-blocks (block component)
-    (cond
-     ((or (block-delete-p block)
-	  (null (block-pred block))
-	  (eq (functional-kind (block-lambda block)) :deleted))
-      (delete-block block))
-     (t
-      (loop
-	(let ((succ (block-succ block)))
-	  (unless (and succ (null (rest succ)))
-	    (return)))
-	
-	(let ((last (block-last block)))
-	  (typecase last
-	    (cif
-	     (flush-dest (if-test last))
-	     (when (unlink-node last) (return)))
-	    (exit
-	     (when (maybe-delete-exit last) (return)))))
-	
-	(unless (join-successor-if-possible block)
-	  (return)))
-
-      (when (and (block-reoptimize block)
-		 (block-component block))
-	(assert (not (block-delete-p block)))
-	(ir1-optimize-block block))
-
-      (when (and (block-flush-p block)
-		 (block-component block))
-	(assert (not (block-delete-p block)))
-	(flush-dead-code block)))))
-
-  (undefined-value))
-
-
-;;; IR1-Optimize-Block  --  Internal
-;;;
-;;;    Loop over the nodes in Block, looking for stuff that needs to be
-;;; optimized.  We dispatch off of the type of each node with its reoptimize
-;;; flag set:
-;;; -- With a combination, we call Propagate-Function-Change whenever the
-;;;    function changes, and call IR1-Optimize-Combination if any argument
-;;;    changes.
-;;; -- With an Exit, we derive the node's type from the Value's type.  We don't
-;;;    propagate Cont's assertion to the Value, since if we did, this would
-;;;    move the checking of Cont's assertion to the exit.  This wouldn't work
-;;;    with Catch and UWP, where the Exit node is just a placeholder for the
-;;;    actual unknown exit.
-;;;
-;;; Note that we clear the node & block reoptimize flags *before* doing the
-;;; optimization.  This ensures that the node or block will be reoptimized if
-;;; necessary.  We leave the NODE-OPTIMIZE flag set doing into
-;;; IR1-OPTIMIZE-RETURN, since it wants to clear the flag itself.
-;;;
-(defun ir1-optimize-block (block)
-  (declare (type cblock block))
-  (setf (block-reoptimize block) nil)
-  (do-nodes (node cont block)
-    (when (node-reoptimize node)
-      (setf (node-reoptimize node) nil)
-      (typecase node
-	(ref)
-	(combination
-	 (when (continuation-reoptimize (basic-combination-fun node))
-	   (propagate-function-change node))
-	 (when (dolist (arg (basic-combination-args node) nil)
-		 (when (and arg (continuation-reoptimize arg))
-		   (return t)))
-	   (ir1-optimize-combination node)))
-	(cif 
-	 (ir1-optimize-if node))
-	(creturn
-	 (setf (node-reoptimize node) t)
-	 (ir1-optimize-return node))
-	(exit
-	 (let ((value (exit-value node)))
-	   (when value
-	     (derive-node-type node (continuation-derived-type value)))))
-	(cset
-	 (ir1-optimize-set node)))))
-  (undefined-value))
-
-
-;;; Join-Successor-If-Possible  --  Internal
-;;;
-;;;    We cannot combine with a successor block if:
-;;;  1] The successor has more than one predecessor.
-;;;  2] The last node's Cont is also used somewhere else.
-;;;  3] The successor is the current block (infinite loop). 
-;;;  4] The next block has a different cleanup, and thus we may want to insert
-;;;     cleanup code between the two blocks at some point.
-;;;  5] The next block has a different home lambda, and thus the control
-;;;     transfer is a non-local exit.
-;;;
-;;; If we succeed, we return true, otherwise false.
-;;;
-;;;    Joining is easy when the successor's Start continuation is the same from
-;;; our Last's Cont.  If they differ, then we can still join when the last
-;;; continuation has no next and the next continuation has no uses.  In this
-;;; case, we replace the next continuation with the last before joining the
-;;; blocks.
-;;;
-(defun join-successor-if-possible (block)
-  (declare (type cblock block))
-  (let ((next (first (block-succ block))))
-    (when (block-lambda next)
-      (let* ((last (block-last block))
-	     (last-cont (node-cont last))
-	     (next-cont (block-start next))
-	     (cleanup (block-end-cleanup block))
-	     (next-cleanup (block-start-cleanup next))
-	     (lambda (block-lambda block))
-	     (next-lambda (block-lambda next)))
-	(cond ((or (rest (block-pred next))
-		   (not (eq (continuation-use last-cont) last))
-		   (eq next block)
-		   (not (eq (lambda-home lambda) (lambda-home next-lambda)))
-		   (not (eq (find-enclosing-cleanup cleanup)
-			    (find-enclosing-cleanup next-cleanup))))
-	       nil)
-	      ((eq last-cont next-cont)
-	       (join-blocks block next)
-	       t)
-	      ((and (null (block-start-uses next))
-		    (eq (continuation-kind last-cont) :inside-block))
-	       (let ((next-node (continuation-next next-cont)))
-		 (assert (not (continuation-dest next-cont)))
-		 (delete-continuation next-cont)
-		 (setf (node-prev next-node) last-cont)
-		 (setf (continuation-next last-cont) next-node)
-		 (setf (block-start next) last-cont)
-		 (join-blocks block next))
-	       t)
-	      (t
-	       nil))))))
-
-
-;;; Join-Blocks  --  Internal
-;;;
-;;;    Join together two blocks which have the same ending/starting
-;;; continuation.  The code in Block2 is moved into Block1 and Block2 is
-;;; deleted from the DFO.  The End-Cleanup for Block1 is set to that for
-;;; Block2 so that we don't lose cleanup info.  We combine the optimize flags
-;;; for the two blocks so that any indicated optimization gets done.
-;;;
-(defun join-blocks (block1 block2)
-  (declare (type cblock block1 block2))
-  (let* ((last (block-last block2))
-	 (last-cont (node-cont last))
-	 (succ (block-succ block2))
-	 (start2 (block-start block2)))
-    (do ((cont start2 (node-cont (continuation-next cont))))
-	((eq cont last-cont)
-	 (when (eq (continuation-kind last-cont) :inside-block)
-	   (setf (continuation-block last-cont) block1)))
-      (setf (continuation-block cont) block1))
-
-    (unlink-blocks block1 block2)
-    (dolist (block succ)
-      (unlink-blocks block2 block)
-      (link-blocks block1 block))
-
-    (setf (block-last block1) last)
-    (setf (continuation-kind start2) :inside-block))
-
-  (setf (block-end-cleanup block1) (block-end-cleanup block2))
-
-  (setf (block-reoptimize block1)
-	(or (block-reoptimize block1) (block-reoptimize block2)))
-  (setf (block-type-asserted block1) t)
-  (setf (block-test-modified block1) t)
-  
-  (let ((next (block-next block2))
-	(prev (block-prev block2)))
-    (setf (block-next prev) next)
-    (setf (block-prev next) prev))
-
-  (undefined-value))
-
-
-;;;; Local call return type propagation:
-
-;;; Find-Result-Type  --  Internal
-;;;
-;;;    This function is called on RETURN nodes that have their REOPTIMIZE flag
-;;; set.  It iterates over the uses of the RESULT, looking for interesting
-;;; stuff to update the TAIL-SET:
-;;;  -- If a use is a local call, then we check that the called function has
-;;;     the tail set Tails.  If we encounter any different tail set, we return
-;;;     the second value true.
-;;;  -- If a use isn't a local call, then we union its type together with the
-;;;     types of other such uses.  We assign to the RETURN-RESULT-TYPE the
-;;;     intersection of this type with the RESULT's asserted type.  We can make
-;;;     this intersection now (potentially before type checking) because this
-;;;     assertion on the result will eventually be checked (if appropriate.)
-;;;
-(defun find-result-type (node tails)
-  (declare (type creturn node))
-  (let ((result (return-result node))
-	(retry nil))
-    (collect ((use-union *empty-type* values-type-union))
-      (do-uses (use result)
-	(if (and (basic-combination-p use)
-		 (eq (basic-combination-kind use) :local))
-	    (when (merge-tail-sets use tails)
-	      (setq retry t))
-	    (use-union (node-derived-type use))))
-      (let ((int (values-type-intersection
-		  (continuation-asserted-type result)
-		  (use-union))))
-	(setf (return-result-type node) int)))
-    retry))
-
-
-;;; Merge-Tail-Sets  --  Internal
-;;;
-;;;    This function handles merging the tail sets if Call is a call to a
-;;; function with a different TAIL-SET than Ret-Set.  We return true if we do
-;;; anything.
-;;;
-;;;     It is assumed that Call sends its value to a RETURN node.  We
-;;; destructively modify the set for the returning function to represent both,
-;;; and then change all the functions in callee's set to reference the first.
-;;;
-;;;    If the called function has no tail set, then do nothing; if it doesn't
-;;; return, then it can't affect the callers value.
-;;;
-(defun merge-tail-sets (call ret-set)
-  (declare (type basic-combination call) (type tail-set ret-set))
-  (let ((fun-set (lambda-tail-set (combination-lambda call))))
-    (when (and fun-set (not (eq ret-set fun-set)))
-      (let ((funs (tail-set-functions fun-set)))
-	(dolist (fun funs)
-	  (setf (lambda-tail-set fun) ret-set))
-	(setf (tail-set-functions ret-set)
-	      (nconc (tail-set-functions ret-set) funs)))
-      t)))
-
-
-;;; IR1-Optimize-Return  --  Internal
-;;;
-;;;    Do stuff to realize that something has changed about the value delivered
-;;; to a return node.  Since we consider the return values of all functions in
-;;; the tail set to be equivalent, this amounts to bringing the entire tail set
-;;; up to date.  We iterate over the returns for all the functions in the tail
-;;; set, reanalyzing them all (not treating Node specially.)
-;;;
-;;;    During this iteration, we may discover new functions that should be
-;;; added to the tail set.  If this happens, we restart the iteration over the
-;;; TAIL-SET-FUNCTIONS.  Note that this really doesn't duplicate much work, as
-;;; we clear the NODE-REOPTIMIZE flags in the return nodes as we go, thus we
-;;; don't call FIND-RESULT-TYPE on any given return more than once.
-;;;
-;;;    Restarting the iteration doesn't disturb the computation of the result
-;;; type RES, since we will just be adding more types to the union.  (or when
-;;; we iterate over a return multiple times, unioning in the same type more
-;;; than once.)
-;;;
-;;;    When we are done, we check if the new type is different from the old
-;;; TAIL-SET-TYPE.  If so, we set the type and also reoptimize all the
-;;; continuations for references to functions in the tail set.  This will
-;;; cause IR1-OPTIMIZE-COMBINATION to derive the new type as the results of the
-;;; calls.
-;;;
-(defun ir1-optimize-return (node)
-  (declare (type creturn node))
-  (let ((tails (lambda-tail-set (return-lambda node))))
-    (collect ((res *empty-type* values-type-union))
-      (loop
-	(block RETRY
-	  (let ((funs (tail-set-functions tails)))
-	    (dolist (fun funs)
-	      (let ((return (lambda-return fun)))
-		(when (node-reoptimize return)
-		  (setf (node-reoptimize node) nil)
-		  (when (find-result-type return tails) (return-from RETRY)))
-		(res (return-result-type return)))))
-	  (return)))
-      
-      (when (type/= (res) (tail-set-type tails))
-	(setf (tail-set-type tails) (res))
-	(dolist (fun (tail-set-functions tails))
-	  (dolist (ref (leaf-refs fun))
-	    (reoptimize-continuation (node-cont ref)))))))
-
-  (undefined-value))
-
-
-;;; IR1-Optimize-If  --  Internal
-;;;
-;;;    If the test has multiple uses, replicate the node when possible.  Also
-;;; check if the predicate is known to be true or false, deleting the IF node
-;;; in favor of the appropriate branch when this is the case.
-;;;
-(defun ir1-optimize-if (node)
-  (declare (type cif node))
-  (let ((test (if-test node))
-	(block (node-block node)))
-    
-    (when (and (eq (block-start block) test)
-	       (eq (continuation-next test) node)
-	       (rest (block-start-uses block)))
-      (do-uses (use test)
-	(when (immediately-used-p test use)
-	  (convert-if-if use node)
-	  (when (continuation-use test) (return)))))
-
-    (let* ((type (continuation-type test))
-	   (victim
-	    (cond ((constant-continuation-p test)
-		   (if (continuation-value test)
-		       (if-alternative node)
-		       (if-consequent node)))
-		  ((not (types-intersect type *null-type*))
-		   (if-alternative node))
-		  ((type= type *null-type*)
-		   (if-consequent node)))))
-      (when victim
-	(flush-dest test)
-	(when (rest (block-succ block))
-	  (unlink-blocks block victim))
-	(setf (component-reanalyze (block-component (node-block node))) t)
-	(unlink-node node))))
-  (undefined-value))
-
-
-;;; Convert-If-If  --  Internal
-;;;
-;;;    Create a new copy of an IF Node that tests the value of the node Use.
-;;; The test must have >1 use, and must be immediately used by Use.  Node must
-;;; be the only node in its block (implying that block-start = if-test).
-;;;
-;;;    This optimization has an effect semantically similar to the
-;;; source-to-source transformation:
-;;;    (IF (IF A B C) D E) ==>
-;;;    (IF A (IF B D E) (IF C D E))
-;;;
-(defun convert-if-if (use node)
-  (declare (type node use) (type cif node))
-  (with-ir1-environment node
-    (let* ((block (node-block node))
-	   (test (if-test node))
-	   (cblock (if-consequent node))
-	   (ablock (if-alternative node))
-	   (use-block (node-block use))
-	   (dummy-cont (make-continuation))
-	   (new-cont (make-continuation))
-	   (new-node (make-if :test new-cont  :source (node-source node)
-			      :consequent cblock  :alternative ablock))
-	   (new-block (continuation-starts-block new-cont)))
-      (prev-link new-node new-cont)
-      (setf (continuation-dest new-cont) new-node)
-      (add-continuation-use new-node dummy-cont)
-      (setf (block-last new-block) new-node)
-
-      (unlink-blocks use-block block)
-      (delete-continuation-use use)
-      (add-continuation-use use new-cont)
-      (link-blocks use-block new-block)
-      
-      (link-blocks new-block cblock)
-      (link-blocks new-block ablock)
-
-      (reoptimize-continuation test)
-      (reoptimize-continuation new-cont)
-      (setf (component-reanalyze *current-component*) t)))
-  (undefined-value))
-
-
-;;;; Exit IR1 optimization:
-
-;;; Maybe-Delete-Exit  --  Interface
-;;;
-;;; This function attempts to delete an exit node, returning true if it
-;;; deletes the block as a consequence:
-;;; -- If the exit is degenerate (has no Entry), then we don't do anything,
-;;;    since there is nothing to be done.
-;;; -- If the exit node and its Entry have the same home lambda then we know
-;;;    the exit is local, and can delete the exit.  We change uses of the
-;;;    Exit-Value to be uses of the original continuation, then unlink the
-;;;    node.
-;;; -- If there is no value (as in a GO), then we skip the value semantics.
-;;;
-;;; This function is also called by environment analysis, since it wants all
-;;; exits to be optimized even if normal optimization was omitted.
-;;;
-(defun maybe-delete-exit (node)
-  (declare (type exit node))
-  (let ((value (exit-value node))
-	(entry (exit-entry node))
-	(cont (node-cont node)))
-    (when (and entry
-	       (eq (lambda-home (block-lambda (node-block node)))
-		   (lambda-home (block-lambda (node-block entry)))))
-      (prog1
-	  (unlink-node node)
-	(when value
-	  (substitute-continuation-uses cont value))))))
-
-
-;;;; Combination IR1 optimization:
-
-;;; Ir1-Optimize-Combination  --  Internal
-;;;
-;;;    Do IR1 optimizations on a Combination node.
-;;;
-(proclaim '(function ir1-optimize-combination (combination) void))
-(defun ir1-optimize-combination (node)
-  (let ((args (basic-combination-args node))
-	(kind (basic-combination-kind node)))
-    (case kind
-      (:local
-       (let ((fun (combination-lambda node)))
-	 (if (eq (functional-kind fun) :let)
-	     (propagate-let-args node fun)
-	     (propagate-local-call-args node fun))))
-      (:full
-       (dolist (arg args)
-	 (when arg
-	   (setf (continuation-reoptimize arg) nil))))
-      (t
-       (dolist (arg args)
-	 (when arg
-	   (setf (continuation-reoptimize arg) nil)))
-
-       (let ((attr (function-info-attributes kind)))
-	 (when (and (ir1-attributep attr foldable)
-		    (not (ir1-attributep attr call))
-		    (every #'constant-continuation-p args)
-		    (continuation-dest (node-cont node)))
-	   (constant-fold-call node)
-	   (return-from ir1-optimize-combination)))
-       
-       (let ((fun (function-info-derive-type kind)))
-	 (when fun
-	   (let ((res (funcall fun node)))
-	     (when res
-	       (derive-node-type node res)))))
-       
-       (let ((fun (function-info-optimizer kind)))
-	 (unless (and fun (funcall fun node))
-	   (dolist (x (function-info-transforms kind))
-	     (ir1-transform node (car x) (cdr x))))))))
-
-  (undefined-value))
-
-
-;;; Recognize-Known-Call  --  Interface
-;;;
-;;;    If Call is a call to a known function, mark it as such by setting the
-;;; Kind.  In addition to a direct check for the function name in the table, we
-;;; also must check for slot accessors.  If the function is a slot accessor,
-;;; then we set the combination kind to the function info of %Slot-Setter or
-;;; %Slot-Accessor, as appropriate.
-;;;
-(defun recognize-known-call (call)
-  (declare (type combination call))
-  (let* ((fun (basic-combination-fun call))
-	 (name (continuation-function-name fun)))
-    (when name
-      (let ((info (info function info name)))
-	(cond (info
-	       (setf (basic-combination-kind call) info))
-	      ((slot-accessor-p (ref-leaf (continuation-use fun)))
-	       (setf (basic-combination-kind call)
-		     (info function info
-			   (if (consp name)
-			       '%slot-setter
-			       '%slot-accessor))))))))
-  (undefined-value))
-
-
-;;; Propagate-Function-Change  --  Internal
-;;;
-;;;    Called by Ir1-Optimize when the function for a call has changed.
-;;; If the call is to a functional, then we attempt to convert it to a local
-;;; call, otherwise we check the call for legality with respect to the new
-;;; type; if it is illegal, we mark the Ref as :Notline and punt.
-;;;
-;;; If we do have a good type for the call, we propagate type information from
-;;; the type to the arg and result continuations.  If we discover that the call
-;;; is to a known global function, then we mark the combination as known.
-;;;
-(defun propagate-function-change (call)
-  (declare (type combination call))
-  (let* ((fun (combination-fun call))
-	 (use (continuation-use fun))
-	 (type (continuation-derived-type fun))
-	 (*compiler-error-context* call))
-    (setf (continuation-reoptimize fun) nil)
-    (cond ((or (not (ref-p use))
-	       (eq (ref-inlinep use) :notinline)))
-	  ((functional-p (ref-leaf use))
-	   (let ((leaf (ref-leaf use)))
-	     (cond ((eq (combination-kind call) :local)
-		    (let ((tail-set (lambda-tail-set leaf)))
-		      (when tail-set
-			(derive-node-type
-			 call (tail-set-type tail-set)))))
-		   ((not (eq (ref-inlinep use) :notinline))
-		    (convert-call-if-possible use call)
-		    (maybe-let-convert leaf)))))
-	  ((not (function-type-p type)))
-	  ((valid-function-use call type
-			       :argument-test #'always-subtypep
-			       :result-test #'always-subtypep
-			       :error-function #'compiler-warning
-			       :warning-function #'compiler-note)
-	   (assert-call-type call type)
-	   (recognize-known-call call))
-	  (t
-	   (setf (ref-inlinep use) :notinline))))
-
-  (undefined-value))
-
-
-;;;; Known function optimization:
-
-;;; IR1-Transform  --  Internal
-;;;
-;;;    Attempt to transform Node using Function, subject to the call type
-;;; constraint Type.  If we are inhibited from doing the transform for some
-;;; reason and Flame is true, then we make a note of the message in 
-;;; *failed-optimizations* for IR1 finalize to pick up.
-;;;
-(proclaim '(function ir1-transform (node type function) void))
-(defun ir1-transform (node type fun)
-  (let ((constrained (function-type-p type))
-	(flame (policy node (> speed brevity)))
-	(*compiler-error-context* node))
-    (cond ((or (not constrained)
-	       (valid-function-use node type))
-	   (multiple-value-bind
-	       (severity args)
-	       (catch 'give-up
-		 (transform-call node (funcall fun node))
-		 (remhash node *failed-optimizations*)
-		 (values :none nil))
-	     (ecase severity
-	       (:none)
-	       (:aborted
-		(setf (combination-kind node) :full)
-		(setf (ref-inlinep (continuation-use (combination-fun node)))
-		      :notinline)
-		(when args
-		  (apply #'compiler-warning args)))
-	       (:failure 
-		(when (and flame args)
-		  (setf (gethash node *failed-optimizations*) args))))))
-	  ((and flame
-		(valid-function-use node type
-				    :argument-test #'types-intersect
-				    :result-test #'values-types-intersect))
-	   (setf (gethash node *failed-optimizations*) type)))))
-
-
-;;; GIVE-UP, ABORT-TRANSFORM  --  Interface
-;;;
-;;;    Just throw the severity and args...
-;;;
-(proclaim '(function give-up (&rest t) nil))
-(defun give-up (&rest args)
-  "This function is used to throw out of an IR1 transform, aborting this
-  attempt to transform the call, but admitting the possibility that this or
-  some other transform will later suceed.  If arguments are supplied, they are
-  format arguments for an efficiency note."
-  (throw 'give-up (values :failure args)))
-;;;
-(defun abort-transform (&rest args)
-  "This function is used to throw out of an IR1 transform and force a normal
-  call to the function at run time.  No further optimizations will be
-  attempted."
-  (throw 'give-up (values :aborted args)))
-
-
-;;; Transform-Call  --  Internal
-;;;
-;;;    Take the lambda-expression Res, IR1 convert it in the proper
-;;; environment, and then install it as the function for the call Node.  We do
-;;; local call analysis so that the new function is integrated into the control
-;;; flow.  We set the Reanalyze flag in the component to cause the DFO to be
-;;; recomputed at soonest convenience.
-;;;
-(defun transform-call (node res)
-  (declare (type combination node) (list res))
-  (with-ir1-environment node
-    (let ((new-fun (ir1-convert-lambda res (node-source node)))
-	  (ref (continuation-use (combination-fun node))))
-      (change-ref-leaf ref new-fun)
-      (setf (combination-kind node) :full)
-      (local-call-analyze *current-component*)))
-  (undefined-value))
-
-
-;;; Constant-Fold-Call  --  Internal
-;;;
-;;;    Replace a call to a foldable function of constant arguments with the
-;;; result of evaluating the form.  We insert the resulting constant node after
-;;; the call, stealing the call's continuation.  We give the call a
-;;; continuation with no Dest, which should cause it and its arguments to go
-;;; away.  If there is an error during the evaluation, we give a warning and
-;;; leave the call alone, making the call a full call and marking it as
-;;; :notinline to make sure that it stays that way.
-;;;
-;;;    For now, if the result is other than one value, we don't fold it.
-;;;
-(defun constant-fold-call (call)
-  (declare (type combination call))
-  (let* ((args (mapcar #'continuation-value (combination-args call)))
-	 (ref (continuation-use (combination-fun call)))
-	 (fun (leaf-name (ref-leaf ref))))
-    
-    (multiple-value-bind (values win)
-			 (careful-call fun args call "constant folding")
-      (cond
-       ((not win)
-	(setf (ref-inlinep ref) :notinline)
-	(setf (combination-kind call) :full))
-       ((= (length values) 1)
-	(with-ir1-environment call
-	  (let* ((leaf (find-constant (first values)))
-		 (node (make-ref (leaf-type leaf)
-				 (node-source call)
-				 leaf
-				 nil))
-		 (dummy (make-continuation))
-		 (cont (node-cont call))
-		 (block (node-block call))
-		 (next (continuation-next cont)))
-	    (push node (leaf-refs leaf))
-	    (setf (leaf-ever-used leaf) t)
-	    
-	    (delete-continuation-use call)
-	    (add-continuation-use call dummy)
-	    (prev-link node dummy)
-	    (add-continuation-use node cont)
-	    (setf (continuation-next cont) next)
-	    (when (eq call (block-last block))
-	      (setf (block-last block) node))
-	    (reoptimize-continuation cont)))))))
-  
-  (undefined-value))
-
-
-;;;; Local call optimization:
-
-;;; Propagate-To-Refs  --  Internal
-;;;
-;;;    Propagate Type to Leaf and its Refs, marking things changed.  If the
-;;; leaf type is a function type, then just leave it alone, since TYPE is never
-;;; going to be more specific than that (and TYPE-INTERSECTION would choke.)
-;;;
-(defun propagate-to-refs (leaf type)
-  (declare (type leaf leaf) (type ctype type))
-  (let ((var-type (leaf-type leaf)))
-    (unless (function-type-p var-type)
-      (let ((int (type-intersection var-type type)))
-	(when (type/= int var-type)
-	  (setf (leaf-type leaf) int)
-	  (dolist (ref (leaf-refs leaf))
-	    (derive-node-type ref int))))
-      (undefined-value))))
-
-
-;;; PROPAGATE-FROM-SETS  --  Internal
-;;;
-;;;    Figure out the type of a LET variable that has sets.  We compute the
-;;; union of the initial value Type and the types of all the set values and to
-;;; a PROPAGATE-TO-REFS with this type.
-;;;
-(defun propagate-from-sets (var type)
-  (collect ((res *empty-type* type-union))
-    (res type)
-    (dolist (set (basic-var-sets var))
-      (res (continuation-type (set-value set)))
-      (setf (node-reoptimize set) nil))
-    (propagate-to-refs var (res)))
-  (undefined-value))
-
-
-;;; IR1-OPTIMIZE-SET  --  Internal
-;;;
-;;;    If a let variable, find the initial value's type and do
-;;; PROPAGATE-FROM-SETS.  We also derive the VALUE's type as the node's type. 
-;;;
-(defun ir1-optimize-set (node)
-  (declare (type cset node))
-  (let ((var (set-var node)))
-    (when (and (lambda-var-p var) (leaf-refs var))
-      (let ((home (lambda-var-home var)))
-	(when (eq (functional-kind home) :let)
-	  (let ((iv (let-var-initial-value var)))
-	    (setf (continuation-reoptimize iv) nil)
-	    (propagate-from-sets var (continuation-type iv)))))))
-  
-  (derive-node-type node (continuation-type (set-value node)))
-  (undefined-value))
-
-
-;;; Propagate-Let-Args  --  Internal
-;;;
-;;;    This function is called when one of the arguments to a LET changes.  We
-;;; look at each changed argument.  If the corresponding variable is set, then
-;;; we call PROPAGATE-FROM-SETS.  Otherwise, we consider substituting for the
-;;; variable, and also propagate derived-type information for the arg to all
-;;; the Var's refs.
-;;;
-;;;    Substitution is inhibited when the Ref's derived type isn't a subtype of
-;;; the argument's asserted type.  This prevents type checking from being
-;;; defeated, and also ensures that the best representation for the variable
-;;; can be used.
-;;;
-;;;    Note that we are responsible for clearing the Continuation-Reoptimize
-;;; flags.
-;;;
-(defun propagate-let-args (call fun)
-  (declare (type combination call) (type clambda fun))
-  (mapc #'(lambda (arg var)
-	    (when (and arg
-		       (continuation-reoptimize arg))
-	      (setf (continuation-reoptimize arg) nil)
-	      (cond
-	       ((lambda-var-sets var)
-		(propagate-from-sets var (continuation-type arg)))
-	       (t
-		(let ((use (continuation-use arg)))
-		  (when (ref-p use)
-		    (let ((leaf (ref-leaf use)))
-		      (when (and (or (constant-p leaf)
-				     (functional-p leaf)
-				     (and (lambda-var-p leaf)
-					  (null (lambda-var-sets leaf))))
-				 (values-subtypep
-				  (node-derived-type use)
-				  (continuation-asserted-type arg)))
-			(substitute-leaf leaf var)))))
-		(propagate-to-refs var (continuation-type arg))))))
-	(basic-combination-args call)
-	(lambda-vars fun))
-  (undefined-value))
-
-
-;;; Propagate-Local-Call-Args  --  Internal
-;;;
-;;;    This function is called when one of the args to a non-let local call
-;;; changes.  For each changed argument corresponding to an unset variable, we
-;;; compute the union of the types across all calls and propagate this type
-;;; information to the var's refs.
-;;;
-;;;    If the function has an XEP, then we don't do anything, since we won't
-;;; discover anything.
-;;;
-;;;    We can clear the Continuation-Reoptimize flags for arguments in all calls
-;;; corresponding to changed arguments in Call, since the only use in IR1
-;;; optimization of the Reoptimize flag for local call args is right here.
-;;;
-(defun propagate-local-call-args (call fun)
-  (declare (type combination call) (type clambda fun))
-
-  (unless (functional-entry-function fun)
-    (let* ((vars (lambda-vars fun))
-	   (union (mapcar #'(lambda (arg var)
-			      (when (and arg
-					 (continuation-reoptimize arg)
-					 (null (basic-var-sets var)))
-				(continuation-type arg)))
-			  (basic-combination-args call)
-			  vars))
-	   (this-ref (continuation-use (basic-combination-fun call))))
-      
-      (dolist (arg (basic-combination-args call))
-	(when arg
-	  (setf (continuation-reoptimize arg) nil)))
-      
-      (dolist (ref (leaf-refs fun))
-	(unless (eq ref this-ref)
-	  (setq union
-		(mapcar #'(lambda (this-arg old)
-			    (when old
-			      (setf (continuation-reoptimize this-arg) nil)
-			      (type-union (continuation-type this-arg) old)))
-			(basic-combination-args
-			 (continuation-dest (node-cont ref)))
-			union))))
-      
-      (mapc #'(lambda (var type)
-		(when type
-		  (propagate-to-refs var type)))
-	    vars union)))
-  
-  (undefined-value))
-
-
-;;; Flush-Dead-Code  --  Internal
-;;;
-;;;    Delete any nodes in Block whose value is unused and have no
-;;; side-effects.  We can delete sets of lexical variables when the set
-;;; variable has no references.
-;;;
-;;; [### For now, don't delete potentially flushable calls when they have the
-;;; Call attribute.  Someday we should look at the funcitonal args to determine
-;;; if they have any side-effects.] 
-;;;
-(defun flush-dead-code (block)
-  (declare (type cblock block))
-  (do-nodes-backwards (node cont block)
-    (unless (continuation-dest cont)
-      (typecase node
-	(ref
-	 (delete-ref node)
-	 (unlink-node node))
-	(combination
-	 (let ((info (combination-kind node)))
-	   (when (function-info-p info)	     
-	     (let ((attr (function-info-attributes info)))
-	       (when (and (ir1-attributep attr flushable)
-			  (not (ir1-attributep attr call)))
-		 (flush-dest (combination-fun node))
-		 (dolist (arg (combination-args node))
-		   (flush-dest arg))
-		 (unlink-node node))))))
-	(exit
-	 (let ((value (exit-value node)))
-	   (when value
-	     (flush-dest value)
-	     (setf (exit-value node) nil))))
-	(cset
-	 (let ((var (set-var node)))
-	   (when (and (lambda-var-p var)
-		      (null (leaf-refs var)))
-	     (flush-dest (set-value node))
-	     (setf (basic-var-sets var)
-		   (delete node (basic-var-sets var)))
-	     (unlink-node node)))))))
-
-  (setf (block-flush-p block) nil)
-  (undefined-value))
-
diff --git a/compiler/ir1tran.lisp b/compiler/ir1tran.lisp
deleted file mode 100644
index 7f7f203a15b7750379ddeec40bd5da89736bd51a..0000000000000000000000000000000000000000
--- a/compiler/ir1tran.lisp
+++ /dev/null
@@ -1,2946 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    This file contains code which does the translation from Lisp code to the
-;;; first intermediate representation (IR1).
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-(export '(*compile-time-define-macros* *compiling-for-interpreter*))
-
-(in-package 'ext)
-(export '(ignorable truly-the maybe-inline))
-
-(in-package 'c)
-
-
-(proclaim '(special *compiler-error-bailout* *template-names*))
-
-;;; The *fenv* is used to keep track of the meaning of the names of functional
-;;; objects during IR1 translation.  It is an alist with the car of each entry
-;;; being the name of the function.  If the cdr is a Leaf structure, then the
-;;; name is bound to the function it represents.  If the cdr is 
-;;; (macro . (lambda ...)) then the lambda is the macroexpansion function for a
-;;; local macro.
-;;;
-(defvar *fenv*)
-
-;;; *inlines* is used to keep track of which functions may and may not be coded
-;;; as inline functions.  It is an alist (Leaf . Flag), where Leaf is the
-;;; structure that represents the function and Flag is either :Inline or
-;;; :Notinline, indicating the sense of the declaration.
-;;;
-(defvar *inlines*)
-
-;;; *type-restrictions* is an alist (Leaf . CType) which is used to keep track
-;;; of "pervasive" type declarations.  A pervasive type declaration is a type
-;;; declaration that pertains to the type in a syntactic extent which does not
-;;; correspond to a binding of the affected name.  Currently Common Lisp only
-;;; allows pervasive type declarations on variables in the function namespace.
-;;;
-(defvar *type-restrictions*)
-
-;;; *venv* translates from variable names to Leaf structures.  A special
-;;; binding is indicated by a :Special Global-Var leaf.  Each special binding
-;;; within the code gets a distinct var structure, as does the current "global"
-;;; value on entry to the code compiled.  (locally (special ...)) is handled by
-;;; adding the most recent special binding to the front of the list.
-;;;
-(defvar *venv*)
-
-;;; *benv* and *tenv* are alists from block and go-tag names to 2-lists of the
-;;; form (<entry> <continuation>), where <continuation> is the continuation to
-;;; exit to, and <entry> is the corresponding Entry node.
-;;;
-(defvar *benv*)
-(defvar *tenv*)
-(proclaim '(list *fenv* *inlines* *type-restrictions* *venv* *benv* *tenv*))
-
-;;; *free-variables* translates from the names of variables referenced globally
-;;; to the Leaf structures for them.  *free-functions* is like
-;;; *free-variables*, only it deals with function names.
-;;;
-;;; We must preserve the property that a proclamation for a global thing
-;;; only affects the code after it.  This takes some work, since a proclamation
-;;; may appear in the middle of a block being compiled.  If there are
-;;; references before the proclaim, then we copy the current entry before
-;;; modifying it.  Code converted before the proclaim sees the old Leaf, while
-;;; code after it sees the new Leaf.
-;;;
-(defvar *free-variables*)
-(defvar *free-functions*)
-(proclaim '(hash-table *free-variables* *free-functions*))
-
-;;; We use the same Constant structure to represent all equal anonymous
-;;; constants.  This hashtable translates from constants to the Leafs that
-;;; represent them.
-;;;
-(defvar *constants*)
-(proclaim '(hash-table *constants*))
-
-;;; *Current-Cookie* represents locally bound state information; declaration
-;;; processing binds it.
-;;;
-(proclaim '(type cookie *current-cookie*))
-(defvar *current-cookie*)
-
-;;; *source-paths* is a hashtable from source code forms to the path taken
-;;; through the source to reach the form.  This provides a way to keep track of
-;;; the location of original source forms, even when macroexpansions and other
-;;; arbitary permutations of the code happen.  This table is initialized by
-;;; calling Find-Source-Paths on the original source.
-;;;
-(proclaim '(hash-table *source-paths*))
-(defvar *source-paths*)
-
-;;; *current-lambda* is used to keep track of the function currently being
-;;; translated.  Blocks point to the current lambda so that we can find the
-;;; environment that they run in.
-;;;
-(proclaim '(type (or clambda null) *current-lambda*))
-(defvar *current-lambda*)
-
-;;; *Current-Component* is the Component structure which we link blocks into as
-;;; we generate them.  This just serves to glue the emitted blocks together
-;;; until local call analysis and flow graph canonicalization figure out what
-;;; is really going on.  We need to keep track of all the blocks generated so
-;;; that we can delete them if they turn out to be unreachable.
-;;;
-(proclaim '(type (or component null) *current-component*))
-(defvar *current-component*)
-
-;;; *Current-Cleanup* is similar to *Current-Lambda*, but used to keep track
-;;; of the enclosing Cleanup.  If there is no cleanup, then this is the same as
-;;; *Current-Lambda*.
-;;;
-(proclaim '(type (or cleanup clambda null) *current-cleanup*))
-(defvar *current-cleanup*)
-
-;;; *Current-Path* is the source path of the form we are currently translating.
-;;; If the path for the form is unknown, then this is the path for the
-;;; innermost enclosing form for which the path is known.
-;;;
-(proclaim '(list *current-path*))
-(defvar *current-path* nil)
-
-;;; *Current-Form* is the form that is currently being converted into IR1.
-;;; This is used to provide context for errors found during IR1 conversion.
-;;;
-(defvar *current-form* nil)
-
-;;; A list of UNKNOWN-FUNCTION structures representing the calls to unknown
-;;; functions.  This is bound by WITH-COMPILATION-UNIT.
-;;;
-(defvar *unknown-functions*)
-(proclaim '(list *unknown-functions*))
-
-;;; *Converting-For-Interpreter* is true when we are creating IR1 to be
-;;; interpreted rather than compiled.  This inhibits source tranformations and
-;;; stuff.
-;;;
-(defvar *converting-for-interpreter* nil)
-
-;;; *Compile-Time-Define-Macros* is true when we want DEFMACRO definitions to
-;;; be installed in the compilation environment as interpreted functions.  We
-;;; set this to false when compiling some parts of the system.
-;;;
-(defvar *compile-time-define-macros* t)
-
-
-;;; IR1-Error-Bailout  --  Internal
-;;;
-;;;    Bind *compiler-error-bailout* to a function throws out of the body and
-;;; converts a proxy form instead.
-;;;
-(defmacro ir1-error-bailout ((start cont form) &body body)
-  `(catch 'ir1-error-abort 
-     (let ((*bailout-start* ,start)
-	   (*bailout-cont* ,cont)
-	   (*bailout-form* ,form)
-	   (*compiler-error-bailout*
-	    #'(lambda ()
-		(ir1-convert
-		 *bailout-start* *bailout-cont*
-		 `(error "Execution of a form compiled with errors:~% ~S"
-			 ',*bailout-form*))
-		(throw 'ir1-error-abort nil))))
-       (declare (special *bailout-start* *bailout-cont* *bailout-form*))
-       ,@body
-       nil)))
-
-			
-;;; IR1-Convert  --  Interface
-;;;
-;;;    Translate Form into IR1.  The code is inserted as the Next of the
-;;; continuation Start.  Cont is the continuation which receives the value of
-;;; the Form to be translated.  The translators call this function recursively
-;;; to translate their subnodes.
-;;;
-;;;    As a special hack to make life easier in the compiler, a Leaf
-;;; IR1-converts into a reference to that leaf structure.  This allows the
-;;; creation using backquote of forms that contain leaf references, without
-;;; having to introduce dummy names into the namespace.
-;;;
-(proclaim '(function ir1-convert (continuation continuation t) void))
-(defun ir1-convert (start cont form)
-  (ir1-error-bailout (start cont form)
-    (if (atom form)
-	(cond ((and (symbolp form) (not (keywordp form)))
-	       (ir1-convert-variable start cont form))
-	      ((leaf-p form)
-	       (reference-leaf start cont form nil))
-	      ((constantp form)
-	       (reference-constant start cont form form))
-	      (t
-	       (compiler-error "Cannot evaluate this object: ~S" form)))
-	(let ((fun (car form))
-	      (*current-form* form)
-	      (*current-path* (or (gethash form *source-paths*)
-				  *current-path*)))
-	  (cond
-	   ((symbolp fun)
-	    (let ((lexical-def (cdr (assoc fun *fenv*))))
-	      (cond
-	       ((not lexical-def)
-		(ir1-convert-global-functoid start cont form))
-	       ((leaf-p lexical-def)
-		(ir1-convert-local-function start cont form lexical-def))
-	       ((and (consp lexical-def) (eq (car lexical-def) 'macro))
-		(ir1-convert-macro start cont (cdr lexical-def) form))
-	       (t
-		(error "Malformed *fenv* entry: ~S." lexical-def)))))
-	   ((or (atom fun) (not (eq (car fun) 'lambda)))
-	    (compiler-error "Illegal function call."))
-	   (t
-	    (ir1-convert-combination start cont form
-				     (ir1-convert-lambda fun))))))))
-
-;;; IR1-Convert-Global-Functoid  --  Internal
-;;;
-;;;    Convert anything that looks like a special-form, global function or
-;;; macro call.  If the thing has a ir1-convert method, but we are at top level
-;;; and the method can't be used there, then convert the form in the initial
-;;; component.
-;;;
-(defun ir1-convert-global-functoid (start cont form)
-  (declare (type continuation start cont)
-	   (list form))
-  (let* ((fun (first form))
-	 (translator (info function ir1-convert fun)))
-    (if translator
-	(funcall translator start cont form)
-	(ecase (info function kind fun)
-	  (:macro
-	   (let ((expander (info function macro-function fun)))
-	     (assert expander (expander)
-		     "No macro-function for global macro ~S." fun)
-	     (ir1-convert-macro start cont expander form)))
-	  ((nil :function)
-	   (ir1-convert-global-function start cont form)))))
-  (undefined-value))
-
-
-;;; IR1-Convert-Macro  --  Internal
-;;;
-;;;    Trap errors during the macroexpansion.
-;;;
-(defun ir1-convert-macro (start cont fun form)
-  (declare (type continuation start cont))
-  (ir1-convert start cont
-	       (handler-case (funcall fun form *fenv*)
-		 (error (condition)
-		   (compiler-error "(during macroexpansion)~%~A"
-				   condition)))))
-
-
-;;; Leaf-Inlinep  --  Internal
-;;;
-;;;    Return the current Inlinep value for references to Leaf.
-;;;
-(defun leaf-inlinep (leaf)
-  (declare (type leaf leaf))
-  (let ((found (assoc leaf *inlines*)))
-    (if found
-	(cdr found)
-	(etypecase leaf
-	  (functional nil)
-	  (global-var
-	   (assert (eq (global-var-kind leaf) :global-function))
-	   (info function inlinep (leaf-name leaf)))))))
-
-
-;;; IR1-Convert-Local-Function  --  Internal
-;;;
-;;;    Convert a call to a local function.  If speed is important, we a have an
-;;; inline expansion and the function is :inline, then convert the inline
-;;; expansion instead of a reference to the existing function.
-;;;
-(proclaim '(function ir1-convert-local-function 
-		     (continuation continuation t leaf) void))
-(defun ir1-convert-local-function (start cont form var)
-  (let ((inlinep (leaf-inlinep var))
-	(expansion (if (functional-p var)
-		       (functional-inline-expansion var))))
-    (if (and expansion (eq inlinep :inline)
-	     (policy nil (>= speed space) (>= speed cspeed)))
-	(ir1-convert-combination start cont form 
-				 (let ((*fenv* (functional-fenv var))
-				       (*venv* (functional-venv var))
-				       (*tenv* (functional-tenv var))
-				       (*benv* (functional-benv var)))
-				   (ir1-convert-lambda expansion form))
-				 :inline)
-	(ir1-convert-combination start cont form var inlinep))))
-
-
-;;; IR1-Convert-Combination  --  Internal
-;;;
-;;;    Convert a function call where the function is a Leaf.  Inlinep is the
-;;; value of Inlinep for the Ref.  We return the Combination node so that we
-;;; can poke at it if we want to.
-;;;
-(proclaim '(function ir1-convert-combination
-		     (continuation continuation list leaf &optional inlinep)
-		     combination))
-(defun ir1-convert-combination (start cont form fun &optional (inlinep nil))
-  (let ((fun-cont (make-continuation)))
-    (reference-leaf start fun-cont fun inlinep)
-    (ir1-convert-combination-args fun-cont cont form)))
-
-
-;;; IR1-Convert-Combination-Args  --  Internal
-;;;
-;;;    Convert the arguments to a call and make the Combination node.  Fun-Cont
-;;; is the continuation which yields the function to call.  Form is the source 
-;;; for the call.  Source is the source for the call.  Args is the list of
-;;; arguments for the call, which defaults to the cdr of source.  We return the
-;;; Combination node.
-;;;
-(proclaim '(function ir1-convert-combination-args
-		     (continuation continuation list &optional list)
-		     combination))
-(defun ir1-convert-combination-args (fun-cont cont source &optional (args (cdr source)))
-  (let ((node (make-combination source fun-cont)))
-    (setf (continuation-dest fun-cont) node)
-    (assert-continuation-type fun-cont
-			      (specifier-type '(or function symbol)))
-    (collect ((arg-conts))
-      (let ((this-start fun-cont))
-	(dolist (arg args)
-	  (let ((this-cont (make-continuation node)))
-	    (ir1-convert this-start this-cont arg)
-	    (setq this-start this-cont)
-	    (arg-conts this-cont)))
-	(prev-link node this-start)
-	(use-continuation node cont)
-	(setf (combination-args node) (arg-conts))))
-    node))
-
-
-;;; IR1-Convert-Progn-Body  --  Internal
-;;;
-;;;    Convert a bunch of forms, discarding all the values except the last.
-;;; If there aren't any forms, then translate a NIL.
-;;;
-(proclaim '(function ir1-convert-progn-body (continuation continuation list) void))
-(defun ir1-convert-progn-body (start cont body)
-  (if (endp body)
-      (reference-constant start cont nil nil)
-      (let ((this-start start)
-	    (forms body))
-	(loop
-	  (let ((form (car forms)))
-	    (when (endp (cdr forms))
-	      (ir1-convert this-start cont form)
-	      (return))
-	    (let ((this-cont (make-continuation)))
-	      (ir1-convert this-start this-cont form)
-	      (setq this-start this-cont  forms (cdr forms))))))))
-
-
-;;; IR1-Convert-Global-Function  --  Internal
-;;;
-;;;    Convert a call to a global function.  If the function has a
-;;; source-transform and inline expansion is enabled then we convert its
-;;; expansion.  If the source transform returns a non-null second value, then
-;;; we act as though there was no source transformation, and directly convert
-;;; the call.
-;;;
-(proclaim '(function ir1-convert-global-function (continuation continuation list) void))
-(defun ir1-convert-global-function (start cont form)
-  (let ((name (car form)))
-    (multiple-value-bind (var inlinep)
-			 (find-free-function name "in a reasonable place")
-      (cond
-       ((eq inlinep :notinline)
-	(ir1-convert-combination start cont form var inlinep))
-       (*converting-for-interpreter*
-	(ir1-convert-ok-combination-fer-sher start cont form var))
-       (t
-	(let ((transform (info function source-transform name))
-	      (expansion (info function inline-expansion name)))
-	  (cond
-	   (transform
-	    (multiple-value-bind (result pass)
-				 (funcall transform form)
-	      (if pass
-		  (ir1-convert-ok-combination start cont form var)
-		  (ir1-convert start cont result))))
-	   (expansion
-	    (ir1-convert-global-inline start cont form var inlinep expansion))
-	   (t
-	    (when (and (eq inlinep :inline) (policy nil (> speed brevity)))
-	      (compiler-note "~S is declared globally inline, but has no expansion."
-			     name))
-	    (ir1-convert-ok-combination start cont form var)))))))))
-
-
-;;; IR1-Convert-Ok-Combination  --  Internal
-;;;
-;;;    Convert a global function call that we are allowed to early bind.  We
-;;; find any Function-Info for Var.  Although Var is not necessarily a
-;;; Global-Var, it is in the global namespace, so we can assume that we know
-;;; about it if we recognize the name.
-;;;
-;;;    If the function has the Predicate attribute, and the CONT's DEST isn't
-;;; an IF, then we convert (IF <form> T NIL), ensuring that a predicate always
-;;; appears in a conditional context.
-;;;
-;;;    If the function isn't a predicate, then we call
-;;; IR1-Convert-OK-Combination-Fer-Sher.
-;;;
-(defun ir1-convert-ok-combination (start cont form var)
-  (declare (type continuation start cont) (list form) (type leaf var))
-  (let ((info (info function info (leaf-name var))))
-    (if (and info
-	     (ir1-attributep (function-info-attributes info) predicate)
-	     (not (if-p (continuation-dest cont))))
-	(ir1-convert start cont `(if ,form t nil))
-	(ir1-convert-ok-combination-fer-sher start cont form var))))
-
-
-(defvar *unknown-function-warning-limit* 3
-  "If non-null, then an upper limit on the number of unknown function warnings
-  that the compiler will print for any given function in a single compilation.
-  This prevents excessive amounts of output when there are commonly called
-  unknown functions.")
-
-
-;;; IR1-Convert-OK-Combination-Fer-Sher  --  Internal
-;;;
-;;;    Actually really convert a global function call that we are allowed to
-;;; early-bind.
-;;;
-;;; If we know the function type of the function, then we check the call for
-;;; syntactic legality with respect to the declared function type.  If it is
-;;; impossible to determine whether the call is correct due to non-constant
-;;; keywords, then we give up, marking the Ref as :Notinline to inhibit further
-;;; error messages.  We return true when the call is legal.
-;;;
-;;; If the call is legal, we also propagate type assertions from the function
-;;; type to the arg and result continuations.  We do this now so that IR1
-;;; optimize doesn't have to redundantly do the check later so that it can do
-;;; the type propagation.
-;;;
-;;; If the function is unknown, then we note the name and error context so that
-;;; we can give a warning if the function is never defined.
-;;;
-(defun ir1-convert-ok-combination-fer-sher (start cont form var)
-  (declare (type continuation start cont) (list form) (type leaf var))
-  (let ((fun-cont (make-continuation)))
-    (reference-leaf start fun-cont var nil)
-    (let ((type (leaf-type var))
-	  (node (ir1-convert-combination-args fun-cont cont form)))
-      (cond
-       ((eq (leaf-where-from var) :assumed)
-	(let* ((name (leaf-name var))
-	       (found (find name *unknown-functions*
-			    :test #'equal
-			    :key #'unknown-function-name))
-	       (res (or found
-			(make-unknown-function :name name))))
-	  (when (and (eq (info function where-from name) :assumed)
-		     (eq (info function kind name) :function))
-	    (unless found (push res *unknown-functions*))
-	    (when (or (not *unknown-function-warning-limit*)
-		      (< (unknown-function-count res)
-			 *unknown-function-warning-limit*))
-	      (let ((*compiler-error-context* node))
-		(push (find-error-context)
-		      (unknown-function-warnings res))))
-	    (incf (unknown-function-count res))
-	    
-	    (setf (info function assumed-type name)
-		  (note-function-use node
-				     (info function assumed-type name)))))
-	nil)
-       ((not (function-type-p type)) nil)
-       ((valid-function-use node type
-			    :argument-test #'always-subtypep
-			    :result-test #'always-subtypep
-			    :error-function #'compiler-warning
-			    :warning-function #'compiler-note)
-	(recognize-known-call node)
-	(assert-call-type node type)
-	(setf (continuation-%derived-type fun-cont) type)
-	(setf (continuation-reoptimize fun-cont) nil)
-	(setf (continuation-%type-check fun-cont) nil)
-	t)
-       (t
-	(setf (ref-inlinep (continuation-use fun-cont)) :notinline)
-	nil)))))
-
-
-;;; In-Null-Environment  --  Internal
-;;;
-;;;    Return true if the lexical environment is null.  If Macros-OK is true,
-;;; then it is ok for there there to be local macros and other compile-time
-;;; stuff in the environment.
-;;;
-(defun in-null-environment (&optional macros-ok)
-  (and (if macros-ok
-	   (every #'(lambda (x)
-		      (let ((val (cdr x)))
-			(and (consp val)
-			     (eq (car val) 'macro))))
-		  *fenv*)
-	   (null *fenv*))
-       (null *benv*) (null *venv*) (null *tenv*)))
-
-
-;;; IR1-Convert-Global-Lambda  --  Internal
-;;;
-;;;    Like IR1-Convert-Lambda except that we null out the environment
-;;; variables around the conversion.
-;;;
-(proclaim '(function ir1-convert-global-lambda (t t) functional))
-(defun ir1-convert-global-lambda (fun source)
-  (let ((*fenv* ())
-	(*benv* ())
-	(*venv* ())
-	(*tenv* ()))
-    (ir1-convert-lambda fun source)))
-
-
-;;; IR1-Convert-Global-Inline  --  Internal
-;;;
-;;;    Convert a call to a global function which has an inline expansion.  We
-;;; make a number of speed v.s. space policy decisions using information from
-;;; our extended inline declaration.  If space is more important than speed,
-;;; then we never do anything funny unless the function is :Always-Inline, in
-;;; which case we do a standard inline substitution.  Otherwise, we do a
-;;; standard inline expansion if it is :Inline or a semi-inline call if it is
-;;; :Semi-Inline.
-;;;
-(proclaim '(function ir1-convert-global-inline
-		     (continuation continuation t leaf inlinep list)
-		     void))
-(defun ir1-convert-global-inline (start cont form var inlinep expansion)
-  (if (and (policy nil
-		   (>= speed cspeed)
-		   (or (> speed space)
-		       (and (= speed space) (eq inlinep :inline))))
-	   (not (functional-p var)))
-      (let* ((name (leaf-name var))
-	     (dummy (make-functional :name name)))
-	(setf (gethash name *free-functions*) dummy)
-	(let ((fun (ir1-convert-global-lambda expansion form)))
-	  (setf (leaf-name fun) name)
-	  (substitute-leaf fun dummy)
-	  (setf (gethash name *free-functions*)
-		(if (or (eq inlinep :inline)
-			(policy nil (= space 0)))
-		    var
-		    fun))
-	  (ir1-convert-combination start cont form fun)))
-      (ir1-convert-ok-combination start cont form var)))
-
-
-;;;; Lambda hackery:  
-
-;;; Varify-Lambda-Arg  --  Internal
-;;;
-;;;    Verify that a thing is a legal name for a variable and return a Var
-;;; structure for it, filling in info if it is globally special.  If it is
-;;; losing, we punt with a Compiler-Error.  Names-So-Far is an alist of names
-;;; which have previously been bound.  If the name is in this list, then we
-;;; error out.
-;;;
-(proclaim '(function varify-lambda-arg (t list) var))
-(defun varify-lambda-arg (name names-so-far)
-  (unless (symbolp name)
-    (compiler-error "Lambda-variable is not a symbol: ~S." name))
-  (when (member name names-so-far)
-    (compiler-error "Repeated variable in lambda-list: ~S." name))
-  (let ((kind (info variable kind name)))
-    (when (or (keywordp name) (eq kind :constant))
-      (compiler-error "Name of lambda-variable is a constant: ~S." name))
-    (if (eq kind :special)
-	(let ((specvar (find-free-variable name)))
-	  (make-lambda-var :name name
-			   :type (leaf-type specvar)
-			   :where-from (leaf-where-from specvar)
-			   :specvar specvar))
-	(make-lambda-var :name name))))
-
-
-;;; Make-Keyword  --  Internal
-;;;
-;;;    Make the keyword for a keyword arg, checking that the keyword isn't
-;;; already used by one of the Vars.  We also check that the keyword isn't the
-;;; magical :allow-other-keys.
-;;;
-(proclaim '(function make-keyword (symbol list) keyword))
-(defun make-keyword (symbol vars)
-  (let ((key (if (keywordp symbol) symbol
-		 (intern (symbol-name symbol) "KEYWORD"))))
-    (when (eq key :allow-other-keys)
-      (compiler-error "You can't have a keyword arg called :allow-other-keys."))
-    (dolist (var vars)
-      (let ((info (lambda-var-arg-info var)))
-	(when (and info
-		   (eq (arg-info-kind info) :keyword)
-		   (eq (arg-info-keyword info) key))
-	  (compiler-error "Multiple uses of keyword ~S in lambda-list." key))))
-    key))
-
-
-;;; Find-Lambda-Vars  --  Internal
-;;;
-;;;    Parse a lambda-list into a list of Var structures, stripping off any aux
-;;; bindings.  Each arg name is checked for legality, and duplicate names are
-;;; checked for.  If an arg is globally special, the var is marked as :special
-;;; instead of :lexical.  Keyword, optional and rest args are annotated with an
-;;; arg-info structure which contains the extra information.  If we hit
-;;; something losing, we bug out with Compiler-Error.  These values are
-;;; returned:
-;;;  1] A list of the var structures for each top-level argument.
-;;;  2] A flag indicating whether &key was specified.
-;;;  3] A flag indicating whether other keyword args are allowed.
-;;;  4] A list of the &aux variables.
-;;;  5] A list of the &aux values.
-;;;
-(proclaim '(function find-lambda-vars (list) (values list boolean list list)))
-(defun find-lambda-vars (list)
-  (multiple-value-bind (required optional restp rest keyp keys allowp aux)
-		       (parse-lambda-list list)
-    (collect ((vars)
-	      (names-so-far)
-	      (aux-vars)
-	      (aux-vals))
-      ;;
-      ;; Parse-Default deals with defaults and supplied-p args for optionals
-      ;; and keywords args.
-      (flet ((parse-default (spec info)
-	       (when (consp (cdr spec))
-		 (setf (arg-info-default info) (second spec))
-		 (when (consp (cddr spec))
-		   (let* ((supplied-p (third spec))
-			  (supplied-var (varify-lambda-arg supplied-p (names-so-far))))
-		     (setf (arg-info-supplied-p info) supplied-var)
-		     (names-so-far supplied-p)
-		     (when (> (length spec) 3)
-		       (compiler-error "Arg specifier is too long: ~S." spec)))))))
-	
-	(dolist (name required)
-	  (let ((var (varify-lambda-arg name (names-so-far))))
-	    (vars var)
-	    (names-so-far name)))
-	
-	(dolist (spec optional)
-	  (if (atom spec)
-	      (let ((var (varify-lambda-arg spec (names-so-far))))
-		(setf (lambda-var-arg-info var) (make-arg-info :kind :optional))
-		(vars var)
-		(names-so-far spec))
-	      (let* ((name (first spec))
-		     (var (varify-lambda-arg name (names-so-far)))
-		     (info (make-arg-info :kind :optional)))
-		(setf (lambda-var-arg-info var) info)
-		(vars var)
-		(names-so-far name)
-		(parse-default spec info))))
-	
-	(when restp
-	  (let ((var (varify-lambda-arg rest (names-so-far))))
-	    (setf (lambda-var-arg-info var) (make-arg-info :kind :rest))
-	    (vars var)
-	    (names-so-far rest)))
-	
-	(dolist (spec keys)
-	  (cond ((atom spec)
-		 (let ((var (varify-lambda-arg spec (names-so-far))))
-		   (setf (lambda-var-arg-info var)
-			 (make-arg-info :kind :keyword
-					:keyword (make-keyword spec (vars))))
-		   (vars var)
-		   (names-so-far spec)))
-		((atom (first spec))
-		 (let* ((name (first spec))
-			(var (varify-lambda-arg name (names-so-far)))
-			(info (make-arg-info :kind :keyword
-					     :keyword (make-keyword name (vars)))))
-		   (setf (lambda-var-arg-info var) info)
-		   (vars var)
-		   (names-so-far name)
-		   (parse-default spec info)))
-		(t
-		 (let ((head (first spec)))
-		   (unless (= (length head) 2)
-		     (error "Malformed keyword arg specifier: ~S." spec))
-		   (let* ((name (second head))
-			  (var (varify-lambda-arg name (names-so-far)))
-			  (info (make-arg-info :kind :keyword
-					       :keyword (make-keyword (first head) (vars)))))
-		     (setf (lambda-var-arg-info var) info)
-		     (vars var)
-		     (names-so-far name)
-		     (parse-default spec info))))))
-	
-	(dolist (spec aux)
-	  (cond ((atom spec)
-		 (let ((var (varify-lambda-arg spec (names-so-far))))
-		   (aux-vars var)
-		   (aux-vals nil)
-		   (names-so-far spec)))
-		(t
-		 (unless (<= 1 (length spec) 2)
-		   (compiler-error "Malformed &aux binding specifier: ~S." spec))
-		 (let* ((name (first spec))
-			(var (varify-lambda-arg name (names-so-far))))
-		   (aux-vars var)
-		   (aux-vals (second spec))
-		   (names-so-far name)))))
-	  
-	(values (vars) keyp allowp (aux-vars) (aux-vals))))))
-
-
-;;; Find-In-Bindings  --  Internal
-;;;
-;;;    Given a list of Lambda-Var structures and a variable name, return the
-;;; structure for that name, or NIL if it isn't found.
-;;;
-(proclaim '(function find-in-bindings (list symbol) (or lambda-var null)))
-(defun find-in-bindings (vars name)
-  (dolist (var vars)
-    (when (eq (leaf-name var) name) (return var))
-    (let ((info (lambda-var-arg-info var)))
-      (when info
-	(let ((supplied-p (arg-info-supplied-p info)))
-	  (when (and supplied-p
-		     (eq (leaf-name supplied-p) name))
-	    (return supplied-p)))))))
-
-
-;;; Find-Lexically-Apparent-Function  --  Internal
-;;;
-;;;    Return the Leaf structure for the lexically apparent function definition
-;;; of Name.  The second value is the inlinep information which currently
-;;; applies to the variable.
-;;;
-(proclaim '(function find-lexically-apparent-function (symbol string)
-		     (values var inlinep)))
-(defun find-lexically-apparent-function (name context)
-  (let ((var (cdr (assoc name *fenv* :test #'equal))))
-    (cond (var
-	   (unless (leaf-p var)
-	     (assert (and (consp var) (eq (car var) 'macro)) ()
-		     "Strange *fenv* entry: ~S." var)
-	     (compiler-error "Found macro name ~S ~A." name context))
-	   (values var (leaf-inlinep var)))
-	  (t
-	   (find-free-function name context)))))
-
-
-;;; Process-Type-Declaration  --  Internal
-;;;
-;;;    Called by Process-Declarations to deal with a variable type declaration.
-;;;
-(proclaim '(function process-type-declaration (list list) void))
-(defun process-type-declaration (decl vars)
-  (let ((type (specifier-type (first decl))))
-    (dolist (var-name (rest decl))
-      (let ((var (find-in-bindings vars var-name)))
-	(cond
-	 ((not var)
-	  (compiler-warning "Type declaration for unbound variable: ~S."
-			    var-name))
-	 ((or (function-type-p type)
-	      (function-type-p (leaf-type var)))
-	  ;;
-	  ;; ### For now, just quietly set type...
-	  (setf (leaf-type var) type))
-	 (t
-	  (let ((int (type-intersection (leaf-type var) type)))
-	    (if (eq int *empty-type*)
-		(compiler-warning
-		 "Conflicting type declarations ~S and ~S for ~S."
-		 (type-specifier (leaf-type var))
-		 (type-specifier type) var-name)
-		(setf (leaf-type var) int)))))))))
-
-
-;;; Process-Ftype-Declaration  --  Internal
-;;;
-;;;    Somewhat similar to Process-Type-Declaration, but handles declarations
-;;; for function variables.  In addition to allowing declarations for functions
-;;; being bound, we must also deal with declarations that constrain the type of
-;;; lexically apparent functions.
-;;;
-;;; [In the non-pervasive case, we should propagate type constraints into the
-;;; function getting the declaration.  We should also think about checking for
-;;; incompatible declarations and possibly intersecting the declared types.
-;;; Handling of pervasive declarations is also sub-optimal, but with any luck
-;;; this feature will go away.]
-;;;
-(proclaim '(function process-ftype-declaration (t list list) list))
-(defun process-ftype-declaration (spec names fvars)
-  (let ((type (specifier-type spec)))
-    (collect ((res))
-      (dolist (name names)
-	(let ((found (find name fvars :key #'leaf-name)))
-	  (if found
-	      (setf (leaf-type found) type)
-	      (res (cons (find-lexically-apparent-function
-			  name "in a function type declaration")
-			 type)))))
-      (res))))
-
-
-
-;;; Process-Declarations  --  Internal
-;;;
-;;;    Use a list of Declare forms to annotate the lists of Lambda-Var and
-;;; Functional structures which are being bound.  In addition to filling in
-;;; slots in the leaf structures, we return new values for *venv*, *inlines*,
-;;; *type-restrictions* and *current-cookie* which reflect pervasive special
-;;; and function type declarations, (not)inline declarations and optimize
-;;; declarations.
-;;;
-(proclaim '(function process-declarations (list list list) (values list list list cookie)))
-(defun process-declarations (decls vars fvars)
-  (let ((new-cookie *current-cookie*))
-    (collect ((new-venv nil cons)
-	      (new-inlines nil cons)
-	      (new-restrictions *type-restrictions* nconc))
-      (dolist (decl decls)
-	(dolist (spec (rest decl))
-	  (unless (consp spec)
-	    (compiler-error "Malformed declaration specifier ~S in ~S." spec decl))
-	  (case (first spec)
-	    (special
-	     (dolist (name (cdr spec))
-	       (let ((var (find-in-bindings vars name))
-		     (specvar (specvar-for-binding name)))
-		 (cond (var
-			(when (lambda-var-ignorep var)
-			  (compiler-warning "Ignored variable ~S is being declared special." name))
-			(setf (lambda-var-specvar var) specvar))
-		       ((assoc name (new-venv)))
-		       (t
-			(new-venv (cons name specvar)))))))
-	    (ftype
-	     (unless (cdr spec)
-	       (compiler-error "No type specified in FTYPE declaration: ~S." decl))
-	     (new-restrictions
-	      (process-ftype-declaration (second spec) (cddr spec) fvars)))
-	    (function
-	     (unless (cdr spec)
-	       (compiler-error "No function name specified in FUNCTION declaration: ~S." decl))
-	     (new-restrictions
-	      (process-ftype-declaration `(function ,@(cddr spec)) (list (second spec))
-					 fvars)))
-	    ((inline notinline maybe-inline)
-	     (let ((sense (case (first spec)
-			    (inline :inline)
-			    (notinline :notinline)
-			    (maybe-inline :maybe-inline))))
-	       (dolist (name (rest spec))
-		 (let* ((var (or (find name fvars :key #'leaf-name)
-				 (find-lexically-apparent-function
-				  name "in an inline or notinline declaration")))
-			(found (cdr (assoc var (new-inlines)))))
-		   (if found
-		       (unless (eq found sense)
-			 (compiler-warning "Conflicting inline/notinline declarations in ~S." decl))
-		       (new-inlines (cons var sense)))))))
-	    ((ignore ignorable)
-	     (dolist (name (rest spec))
-	       (let ((var (find-in-bindings vars name)))
-		 (cond
-		  ((not var)
-		   (compiler-warning
-		    "Ignore declaration for unknown variable ~S." name))
-		  ((lambda-var-specvar var)
-		   (compiler-warning
-		    "Declaring special variable ~S to be ignored." name))
-		  ((eq (first spec) 'ignorable)
-		   (setf (leaf-ever-used var) t))
-		  (t
-		   (setf (lambda-var-ignorep var) t))))))
-	    (optimize
-	     (setq new-cookie (process-optimize-declaration spec new-cookie)))
-	    (type
-	     (process-type-declaration (cdr spec) vars))
-	    (t
-	     (let ((what (first spec)))
-	       (cond ((member what type-specifier-symbols)
-		      (process-type-declaration spec vars))
-		     ((info declaration recognized what))
-		     (t
-		      (compiler-warning "Unrecognized declaration: ~S." spec))))))))
-
-      (values (nconc (new-venv) *venv*) (nconc (new-inlines) *inlines*)
-	      (new-restrictions) new-cookie))))
-
-
-;;; Specvar-For-Binding  --  Internal
-;;;
-;;;    Return the Specvar for Name to use when we see a local SPECIAL
-;;; declaration.  If there is a global variable of that name, then check that
-;;; it isn't a constant and return it.  Otherwise, create an anonymous
-;;; GLOBAL-VAR.
-;;;
-(defun specvar-for-binding (name)
-  (cond ((not (eq (info variable where-from name) :assumed))
-	 (let ((found (find-free-variable name)))
-	   (when (or (not (global-var-p found))
-		     (eq (global-var-kind found) :constant))
-	     (compiler-error "Declaring a constant to be special: ~S." name))
-	   found))
-	(t
-	 (make-global-var :kind :special  :name name  :where-from :declared))))
-
-
-;;; IR1-Convert-Aux-Bindings  --  Internal
-;;;
-;;;    Similar to IR1-Convert-Progn-Body except that we sequentially bind each
-;;; Aux-Var to the corresponding Aux-Val before converting the body.  If there
-;;; are no bindings, just convert the body, otherwise do one binding and
-;;; recurse on the rest.
-;;;
-(proclaim '(function ir1-convert-aux-bindings
-		     (continuation continuation list list list)
-		     void))
-(defun ir1-convert-aux-bindings (start cont body source aux-vars aux-vals)
-  (if (null aux-vars)
-      (ir1-convert-progn-body start cont body)
-      (let ((fun-cont (make-continuation))
-	    (fun (ir1-convert-lambda-body body (list (first aux-vars)) source
-					  (rest aux-vars) (rest aux-vals))))
-	(reference-leaf start fun-cont fun nil)
-	(ir1-convert-combination-args fun-cont cont source
-				      (list (first aux-vals))))))
-
-
-;;; IR1-Convert-Special-Bindings  --  Internal
-;;;
-;;;    Similar to IR1-Convert-Progn-Body except that code to bind the Specvar
-;;; for each Svar to the value of the variable is wrapped around the body.  If
-;;; there are no special bindings, we just convert the body, otherwise we do
-;;; one special binding and recurse on the rest.
-;;;
-;;;    We make a cleanup, bind *Current-Cleanup* to it, and also set the
-;;; Block-End-Cleanup for the start block.  If there are multiple special
-;;; bindings, the cleanup for the blocks will end up being the innermost one.
-;;; We force Cont to start a block outside of this cleanup, causing cleanup
-;;; code to be emitted when the scope is exited.
-;;;
-(defun ir1-convert-special-bindings (start cont body aux-vars aux-vals
-					   svars source)
-  (declare (type continuation start cont)
-	   (list body aux-vars aux-vals svars))
-  (cond
-   ((null svars)
-    (ir1-convert-aux-bindings start cont body source aux-vars aux-vals))
-   (t
-    (continuation-starts-block cont)
-    (let* ((cleanup (make-cleanup :kind :special-bind))
-	   (*current-cleanup* cleanup)
-	   (var (first svars))
-	   (next-cont (make-continuation)))
-      (setf (cleanup-start cleanup) next-cont)
-      (setf (block-end-cleanup (continuation-block start)) cleanup)
-      (ir1-convert start next-cont
-		   `(%special-bind ',(lambda-var-specvar var) ,var))
-      (ir1-convert-special-bindings next-cont cont body aux-vars aux-vals
-				    (rest svars) source)))))
-
-
-;;; IR1-Convert-Lambda-Body  --  Internal
-;;;
-;;;    Create a lambda node out of some code, returning the result.  The
-;;; bindings are specified by the list of var structures Vars.  We deal with
-;;; adding the names to the *venv* for the conversion.  The result is added to
-;;; the New-Functions in the *Current-Component* and linked to the component
-;;; head and tail.
-;;;
-;;; We detect special bindings here, replacing the original Var in the lambda
-;;; list with a temporary variable.  We then pass a list of the special vars to
-;;; IR1-Convert-Special-Bindings, which actually emits the special binding
-;;; code.
-;;;
-;;; We ignore any Arg-Info in the Vars, trusting that someone else is dealing
-;;; with &nonsense.
-;;;
-;;; Aux-Vars is a list of Var structures for variables that are to be
-;;; sequentially bound.  Each Aux-Val is a form that is to be evaluated to get
-;;; the initial value for the corresponding Aux-Var.
-;;;
-(proclaim '(function ir1-convert-lambda-body (list list t &optional list list)
-		     lambda))
-(defun ir1-convert-lambda-body (body vars source &optional aux-vars aux-vals)
-  (let* ((bind (make-bind :source source))
-	 (lambda (make-lambda :vars vars  :bind bind))
-	 (*current-lambda* lambda)
-	 (*current-cleanup* lambda)
-	 (result (make-continuation)))
-    (setf (lambda-home lambda) lambda)
-    (collect ((svars)
-	      (new-venv *venv* cons))
-
-      (dolist (var vars)
-	(setf (lambda-var-home var) lambda)
-	(let ((specvar (lambda-var-specvar var)))
-	  (cond (specvar
-		 (svars var)
-		 (new-venv (cons (leaf-name specvar) specvar)))
-		(t
-		 (new-venv (cons (leaf-name var) var))))))
-      
-      (setf (bind-lambda bind) lambda)
-      (let ((*venv* (new-venv))
-	    (cont1 (make-continuation))
-	    (cont2 (make-continuation)))
-	(continuation-starts-block cont1)
-	(prev-link bind cont1)
-	(use-continuation bind cont2)
-	(ir1-convert-special-bindings cont2 result body aux-vars aux-vals
-				      (svars) source))
-
-      (let ((block (continuation-block result)))
-	(when block
-	  (let ((return (make-return :source source  :result result
-				     :lambda lambda))
-		(tail-set (make-tail-set :functions (list lambda)))
-		(dummy (make-continuation)))
-	    (setf (lambda-tail-set lambda) tail-set)
-	    (setf (lambda-return lambda) return)
-	    (setf (continuation-dest result) return)
-	    (setf (block-last block) return)
-	    (prev-link return result)
-	    (use-continuation return dummy))
-	  (link-blocks block (component-tail *current-component*)))))
-
-    (link-blocks (component-head *current-component*) (node-block bind))
-    (push lambda (component-new-functions *current-component*))
-    lambda))
-
-
-;;; Convert-Optional-Entry  --  Internal
-;;;
-;;;    Create the actual entry-point function for an optional entry point.  The
-;;; lambda binds copies of each of the Vars, then calls Fun with the argument
-;;; Vals and the Defaults.  Presumably the Vals refer to the Vars by name.  The
-;;; Vals are passed in in reverse order.
-;;;
-;;;    If any of the copies of the vars are referenced more than once, then we
-;;; mark the corresponding var as Ever-Used to inhibit "defined but not read"
-;;; warnings for arguments that are only used by default forms.
-;;;
-(proclaim '(function convert-optional-entry (lambda list list list t) lambda))
-(defun convert-optional-entry (fun vars vals defaults source)
-  (let* ((fvars (reverse vars))
-	 (arg-vars (mapcar #'(lambda (var)
-			       (make-lambda-var
-				:name (leaf-name var)
-				:type (leaf-type var)
-				:where-from (leaf-where-from var)
-				:specvar (lambda-var-specvar var)))
-			   fvars))
-	 (fun
-	  (ir1-convert-lambda-body
-	   `((%funcall ,fun ,@(reverse vals) ,@defaults))
-	   arg-vars source)))
-    (mapc #'(lambda (var arg-var)
-	      (when (cdr (leaf-refs arg-var))
-		(setf (leaf-ever-used var) t)))
-	  fvars arg-vars)
-    fun))
-
-
-;;; Generate-Optional-Default-Entry  --  Internal
-;;;
-;;;    This function deals with supplied-p vars in optional arguments.  If the
-;;; there is no supplied-p arg, then we just call IR1-Convert-Hairy-Args on the
-;;; remaining arguments, and generate a optional entry that calls the result.
-;;; If there is a supplied-p var, then we add it into the default vars and
-;;; throw a T into the entry values.  The resulting entry point function is
-;;; returned.
-;;;
-(proclaim '(function generate-optional-default-entry
-		     (optional-dispatch list list list list list boolean list
-					list list list)
-		     lambda))
-(defun generate-optional-default-entry (res default-vars default-vals
-					    entry-vars entry-vals
-					    vars supplied-p-p body source
-					    aux-vars aux-vals)
-  (let* ((arg (first vars))
-	 (arg-name (leaf-name arg))
-	 (info (lambda-var-arg-info arg))
-	 (supplied-p (arg-info-supplied-p info))
-	 (ep (if supplied-p
-		 (ir1-convert-hairy-args
-		  res
-		  (list* supplied-p arg default-vars)
-		  (list* (leaf-name supplied-p) arg-name default-vals)
-		  (cons arg entry-vars)
-		  (list* t arg-name entry-vals)
-		  (rest vars) t body source aux-vars aux-vals)
-		 (ir1-convert-hairy-args 
-		  res
-		  (cons arg default-vars)
-		  (cons arg-name default-vals)
-		  (cons arg entry-vars)
-		  (cons arg-name entry-vals)
-		  (rest vars) supplied-p-p body source aux-vars aux-vals))))
-		 
-    (convert-optional-entry ep default-vars default-vals
-			    (if supplied-p
-				(list (arg-info-default info) nil)
-				(list (arg-info-default info)))
-			    source)))
-
-
-;;; Convert-More-Entry  --  Internal
-;;;
-;;;    Create the More-Entry function for the Optional-Dispatch Res.
-;;; Entry-Vars and Entry-Vals describe the fixed arguments.  Rest is the var
-;;; for any Rest arg.  Keys is a list of the keyword arg vars.
-;;;
-;;;    The most interesting thing that we do is parse keywords.  We create a
-;;; bunch of temporary variables to hold the result of the parse, and then loop
-;;; over the supplied arguments, setting the appropriate temps for the supplied
-;;; keyword.
-;;;
-;;;    If there is no supplied-p var, then we initialize the temp to the
-;;; default and just pass the temp into the main entry.  Since non-constant
-;;; keyword args are forcibly given a supplied-p var, we know that the default
-;;; is constant, and thus safe to evaluate out of order.
-;;;
-;;;    If there is a supplied-p var, then we create temps for both the value
-;;; and the supplied-p, and pass them into the main entry, letting it worry
-;;; about defaulting.
-;;;
-;;;    We deal with :allow-other-keys by delaying unknown keyword errors until
-;;; we have scanned all the keywords.
-;;;
-(proclaim '(function convert-more-entry
-		     (optional-dispatch list list (or lambda-var null)
-					list list)
-		     void))
-(defun convert-more-entry (res entry-vars entry-vals rest keys source)
-  (collect ((arg-vars)
-	    (arg-vals (reverse entry-vals))
-	    (temps)
-	    (body))
-    
-    (dolist (var (reverse entry-vars))
-      (arg-vars (make-lambda-var
-		 :name (leaf-name var)
-		 :type (leaf-type var)
-		 :where-from (leaf-where-from var))))
-
-    (let* ((n-context (gensym))
-	   (context-temp (make-lambda-var :name n-context))
-	   (n-count (gensym))
-	   (count-temp (make-lambda-var :name n-count
-					:type (specifier-type 'fixnum))))
-      (arg-vars context-temp count-temp)
-
-      (when rest
-	(arg-vals `(%listify-rest-args ,n-context ,n-count)))
-
-      (when (optional-dispatch-keyp res)
-	(let ((n-index (gensym))
-	      (n-key (gensym))
-	      (n-value-temp (gensym))
-	      (n-allowp (gensym))
-	      (n-losep (gensym))
-	      (allowp
-	       (or (optional-dispatch-allowp res)
-		   (policy nil (or (> space safety) (> speed safety))))))
-	  
-	  (temps `(,n-index 0) n-key n-value-temp)
-	  (body `(declare (fixnum ,n-index) (ignorable ,n-key ,n-value-temp)))
-
-	  (collect ((tests))
-	    (dolist (key keys)
-	      (let* ((info (lambda-var-arg-info key))
-		     (default (arg-info-default info))
-		     (keyword (arg-info-keyword info))
-		     (supplied-p (arg-info-supplied-p info))
-		     (n-value (gensym)))
-		(cond (supplied-p
-		       (let ((n-supplied (gensym)))
-			 (temps n-value n-supplied)
-			 (arg-vals n-value n-supplied)
-			 (tests `((eq ,n-key ,keyword)
-				  (setq ,n-supplied t)
-				  (setq ,n-value ,n-value-temp)))))
-		      (t
-		       (temps `(,n-value ,default))
-		       (arg-vals n-value)
-		       (tests `((eq ,n-key ,keyword)
-				(setq ,n-value ,n-value-temp)))))))
-
-	    (unless allowp
-	      (temps n-allowp n-losep)
-	      (tests `((eq ,n-key :allow-other-keys)
-		       (setq ,n-allowp ,n-value-temp)))
-	      (tests `(t
-		       (setq ,n-losep ,n-key))))
-
-	    (body
-	     `(when (oddp ,n-count)
-		(%odd-keyword-arguments-error)))
-
-	    (body
-	     `(locally
-		(declare (optimize (safety 0)))
-		(loop
-		  (when (= ,n-index ,n-count) (return))
-		  (setq ,n-key (%more-arg ,n-context ,n-index))
-		  (incf ,n-index)
-		  (setf ,n-value-temp (%more-arg ,n-context ,n-index))
-		  (incf ,n-index)
-		  (cond ,@(tests)))))
-
-	    (unless allowp
-	      (body `(when (and ,n-losep (not ,n-allowp))
-		       (%unknown-keyword-argument-error ,n-losep)))))))
-      
-      (let ((ep (ir1-convert-lambda-body
-		 `((let ,(temps)
-		     ,@(body)
-		     (%funcall ,(optional-dispatch-main-entry res)
-			      . ,(arg-vals))))
-		 (arg-vars) source)))
-	(setf (optional-dispatch-more-entry res) ep)))))
-
-
-;;; IR1-Convert-More  --  Internal
-;;;
-;;;    Called by IR1-Convert-Hairy-Args when we run into a rest or keyword arg.
-;;; The arguments are similar to that function, but we split off any rest arg
-;;; and pass it in separately.  Rest is the rest arg var, or NIL if there is no
-;;; rest arg.  Keys is a list of the keyword argument vars.
-;;;
-(proclaim '(function ir1-convert-more
-		     (optional-dispatch list list list list (or lambda-var null)
-					list boolean list list list list)
-		     lambda))
-(defun ir1-convert-more (res default-vars default-vals entry-vars entry-vals
-			     rest keys supplied-p-p body source aux-vars
-			     aux-vals)
-  (collect ((main-vars (reverse default-vars))
-	    (main-vals default-vals cons)
-	    (bind-vars)
-	    (bind-vals))
-    (when rest
-      (main-vars rest)
-      (main-vals '()))
-
-    (dolist (key keys)
-      (let* ((info (lambda-var-arg-info key))
-	     (default (arg-info-default info))
-	     (hairy-default (not (compiler-constantp default)))
-	     (supplied-p (arg-info-supplied-p info))
-	     (n-val (gensym))
-	     (val-temp (make-lambda-var :name n-val)))
-	(main-vars val-temp)
-	(bind-vars key)
-	(cond ((or hairy-default supplied-p)
-	       (let* ((n-supplied (gensym))
-		      (supplied-temp (make-lambda-var :name n-supplied)))
-		 (unless supplied-p
-		   (setf (arg-info-supplied-p info) supplied-temp))
-		 (setf (arg-info-default info) nil)
-		 (main-vars supplied-temp)
-		 (main-vals nil nil)
-		 (bind-vals `(if ,n-supplied ,n-val ,default))
-		 (when supplied-p
-		   (bind-vars supplied-p)
-		   (bind-vals n-supplied))))
-	      (t
-	       (main-vals (arg-info-default info))
-	       (bind-vals n-val)))))
-
-    (let* ((main-entry (ir1-convert-lambda-body body (main-vars) source
-						(append (bind-vars) aux-vars)
-						(append (bind-vals) aux-vals)))
-	   (last-entry (convert-optional-entry main-entry default-vars
-					       (main-vals) () source)))
-      (setf (optional-dispatch-main-entry res) main-entry)
-      (convert-more-entry res entry-vars entry-vals rest keys source)
-
-      (push (if supplied-p-p
-		(convert-optional-entry last-entry entry-vars entry-vals
-					() source)
-		last-entry)
-	    (optional-dispatch-entry-points res))
-      last-entry)))
-
-
-;;; IR1-Convert-Hairy-Args  --  Internal
-;;;
-;;;    This function generates the entry point functions for the
-;;; optional-dispatch Res.  We accomplish this by recursion on the list of
-;;; arguments, analyzing the arglist on the way down and generating entry
-;;; points on the way up.
-;;;
-;;;    Default-Vars is a reversed list of all the argument vars processed so
-;;; far, including supplied-p vars.  Default-Vals is a list of the names of the
-;;; Default-Vars.
-;;;
-;;;    Entry-Vars is a reversed list of processed argument vars, excluding
-;;; supplied-p vars.  Entry-Vals is a list things that can be evaluated to get
-;;; the values for all the vars from the Entry-Vars.  It has the var name for
-;;; each required or optional arg, and has T for each supplied-p arg.
-;;;
-;;;    Vars is a list of the Lambda-Var structures for arguments that haven't
-;;; been processed yet.  Supplied-p-p is true if a supplied-p argument has
-;;; already been processed; only in this case are the Default-XXX and Entry-XXX
-;;; different.
-;;;
-;;;    The result at each point is a lambda which should be called by the above
-;;; level to default the remaining arguments and evaluate the body.  We cause
-;;; the body to be evaluated by converting it and returning it as the result
-;;; when the recursion bottoms out.
-;;;
-;;;    Each level in the recursion also adds its entry point function to the
-;;; result Optional-Dispatch.  For most arguments, the defaulting function and
-;;; the entry point function will be the same, but when supplied-p args are
-;;; present they may be different.
-;;;
-;;;     When we run into a rest or keyword arg, we punt out to
-;;; IR1-Convert-More, which finishes for us in this case.
-;;;
-(proclaim '(function ir1-convert-hairy-args
-		     (optional-dispatch list list list list list boolean list
-					list list list)
-		     lambda))
-(defun ir1-convert-hairy-args (res default-vars default-vals
-				   entry-vars entry-vals
-				   vars supplied-p-p body source aux-vars
-				   aux-vals)
-  (cond ((not vars)
-	 (let ((fun (ir1-convert-lambda-body body (reverse default-vars) source
-					     aux-vars aux-vals)))
-	   (setf (optional-dispatch-main-entry res) fun)
-	   (push (if supplied-p-p
-		     (convert-optional-entry fun entry-vars entry-vals
-					     () source)
-		     fun)
-		 (optional-dispatch-entry-points res))
-	   fun))
-	((not (lambda-var-arg-info (first vars)))
-	 (let* ((arg (first vars))
-		(nvars (cons arg default-vars))
-		(nvals (cons (leaf-name arg) default-vals)))
-	   (ir1-convert-hairy-args res nvars nvals nvars nvals
-				   (rest vars) nil body source aux-vars
-				   aux-vals)))
-	(t
-	 (let* ((arg (first vars))
-		(info (lambda-var-arg-info arg))
-		(kind (arg-info-kind info)))
-	   (ecase kind
-	     (:optional
-	      (let ((ep (generate-optional-default-entry
-			 res default-vars default-vals
-			 entry-vars entry-vals vars supplied-p-p body source
-			 aux-vars aux-vals)))
-		(push (if supplied-p-p
-			  (convert-optional-entry ep entry-vars entry-vals
-						  () source)
-			  ep)
-		      (optional-dispatch-entry-points res))
-		ep))
-	     (:rest
-	      (ir1-convert-more res default-vars default-vals entry-vars entry-vals
-				arg (rest vars) supplied-p-p body source
-				aux-vars aux-vals))
-	     (:keyword
-	      (ir1-convert-more res default-vars default-vals entry-vars entry-vals
-				nil vars supplied-p-p body source aux-vars
-				aux-vals)))))))
-
-
-;;; IR1-Convert-Hairy-Lambda  --  Internal
-;;;
-;;;     This function deals with the case where we have to make an
-;;; Optional-Dispatch to represent a lambda.  We cons up the result and call
-;;; IR1-Convert-Hairy-Args to do the work.  When it is done, we figure out the
-;;; min-args and max-args. 
-;;;
-(proclaim '(function ir1-convert-hairy-lambda
-		     (list list boolean boolean list list list)
-		     optional-dispatch))
-(defun ir1-convert-hairy-lambda (body vars keyp allowp source aux-vars aux-vals)
-  (let ((res (make-optional-dispatch :arglist vars  :allowp allowp
-				     :keyp keyp))
-	(min (or (position-if #'lambda-var-arg-info vars) (length vars))))
-    (push res (component-new-functions *current-component*))
-    (ir1-convert-hairy-args res () () () () vars nil body source aux-vars
-			    aux-vals)
-    (setf (optional-dispatch-min-args res) min)
-    (setf (optional-dispatch-max-args res)
-	  (+ (1- (length (optional-dispatch-entry-points res))) min))
-
-    (flet ((frob (ep)
-	     (when ep
-	       (setf (functional-kind ep) :optional)
-	       (setf (lambda-optional-dispatch ep) res))))
-      (dolist (ep (optional-dispatch-entry-points res)) (frob ep))
-      (frob (optional-dispatch-more-entry res))
-      (frob (optional-dispatch-main-entry res)))
-      
-    res))
-    
-    
-;;; IR1-Convert-Lambda  --  Internal
-;;;
-;;;    Convert a Lambda into a Lambda or Optional-Dispatch leaf.
-;;;
-(proclaim '(function ir1-convert-lambda (t &optional t) functional))
-(defun ir1-convert-lambda (form &optional (source form))
-  (unless (and (consp form) (eq (car form) 'lambda) (consp (cdr form))
-	       (listp (cadr form)))
-    (compiler-error "Malformed lambda expression: ~S." form))
-
-  (multiple-value-bind (vars keyp allow-other-keys aux-vars aux-vals)
-		       (find-lambda-vars (cadr form))
-    (multiple-value-bind
-	(body decls)
-	(system:parse-body (cddr form) *fenv* t)
-      (multiple-value-bind
-	  (*venv* *inlines* *type-restrictions* *current-cookie*)
-	  (process-declarations decls (append aux-vars vars) nil)
-	(let ((res (if (or (find-if #'lambda-var-arg-info vars) keyp)
-		       (ir1-convert-hairy-lambda body vars keyp
-						 allow-other-keys source
-						 aux-vars aux-vals)
-		       (ir1-convert-lambda-body body vars source aux-vars
-						aux-vals))))
-	  (setf (functional-inline-expansion res) form)
-	  (setf (functional-arg-documentation res) (cadr form))
-	  res)))))
-
-
-;;;; Variable hacking:
-
-
-;;; Find-Free-Really-Function  --  Internal
-;;;
-;;;    Return a Global-Var structure usable for referencing the global function
-;;; Name.
-;;;
-(defun find-free-really-function (name)
-  (unless (info function kind name)
-    (setf (info function kind name) :function)
-    (setf (info function where-from name) :assumed))
-
-  (make-global-var :kind :global-function  :name name
-		   :type (info function type name)
-		   :where-from (info function where-from name)))
-
-
-;;; Find-Slot-Accessor  --  Internal
-;;;
-;;;    Return a Slot-Accessor structure usable for referencing the slot
-;;; accessor Name.  Info is the structure definition.
-;;;
-(defun find-slot-accessor (info name)
-  (declare (type defstruct-description info))
-  (let* ((accessor (if (listp name) (cadr name) name))
-	 (slot (find accessor (dd-slots info)
-		     :key #'dsd-accessor))
-	 (type (dd-name info))
-	 (slot-type (dsd-type slot)))
-    (assert slot () "Can't find slot ~S." type)
-    (make-slot-accessor
-     :name name
-     :type (specifier-type
-	    (if (listp name)
-		`(function (,type ,slot-type) ,slot-type)
-		`(function (,type) ,slot-type)))
-     :for info
-     :slot slot)))
-
-
-;;; Find-Free-Function  --  Internal
-;;;
-;;;    If Name is already entered in *free-functions*, then return the value.
-;;; Otherwise, make a new Global-Var using information from the global
-;;; environment and enter it in *free-functions*.  If Name names a macro or
-;;; special form, then we error out using the supplied context which indicates
-;;; what we were trying to do that demanded a function.  The second value is
-;;; the inlinep information which currently applies to the variable.
-;;;
-(proclaim '(function find-free-function (t string) (values global-var inlinep)))
-(defun find-free-function (name context)
-  (let ((found (gethash name *free-functions*)))
-    (if found
-	(values found (leaf-inlinep found))
-	(ecase (info function kind name)
-	  (:macro
-	   (compiler-error "Found macro name ~S ~A." name context))
-	  (:special-form
-	   (compiler-error "Found special-form name ~S ~A." name context))
-	  ((:function nil)
-	   (check-function-name name)
-	   (let ((info (info function accessor-for name)))
-	     (values (setf (gethash name *free-functions*)
-			   (if info
-			       (find-slot-accessor info name)
-			       (find-free-really-function name)))
-		     (info function inlinep name))))))))
-
-
-;;; IR1-Convert-Variable  --  Internal
-;;;
-;;;    Convert a reference to a symbolic constant or variable.  If the symbol
-;;; is entered in *venv*, then we use that definition, otherwise we find the
-;;; current global definition.
-;;;
-(proclaim '(function ir1-convert-variable (continuation continuation symbol) void))
-(defun ir1-convert-variable (start cont name)
-  (let ((var (or (cdr (assoc name *venv*)) (find-free-variable name))))
-    (when (and (lambda-var-p var) (lambda-var-ignorep var))
-      (compiler-warning "Reading an ignored variable: ~S." name))
-    (if (lisp::ct-a-val-p var)
-	(ir1-convert start cont `(alien-value ,name))
-	(reference-leaf start cont var nil))))
-
-
-;;; Find-Free-Variable  --  Internal
-;;;
-;;;    Return the Leaf node for a global variable reference to Name.  If Name
-;;; is already entered in *free-variables*, then we just return the
-;;; corresponding value.  Otherwise, we make a new leaf using information from
-;;; the global environment and enter it in *free-variables*.  If the variable
-;;; is unknown, then we emit a warning.
-;;;
-(proclaim '(function find-free-variable (symbol) leaf))
-(defun find-free-variable (name)
-  (unless (symbolp name)
-    (compiler-error "Variable name is not a symbol: ~S." name))
-  (or (gethash name *free-variables*)
-      (let ((kind (info variable kind name))
-	    (type (info variable type name))
-	    (where-from (info variable where-from name)))
-	(when (and (eq where-from :assumed) (eq kind :global))
-	  (compiler-warning "Unknown variable: ~S." name))
-
-	(multiple-value-bind (val valp)
-			     (info variable constant-value name)
-	  (setf (gethash name *free-variables*)
-		(if (and (eq kind :constant) valp)
-		    (make-constant :value val  :name name
-				   :type (ctype-of val)
-				   :where-from where-from)
-		    (make-global-var :kind kind  :name name  :type type
-				     :where-from where-from)))))))
-
-
-;;; Reference-Constant  --  Internal
-;;;
-;;;    Generate a reference to a manifest constant, creating a new leaf if
-;;; necessary.
-;;;
-(proclaim '(function reference-constant (continuation continuation t t)
-		     void))
-(defun reference-constant (start cont value source)
-  (let* ((leaf (find-constant value))
-	 (res (make-ref (leaf-type leaf) source leaf nil)))
-    (push res (leaf-refs leaf))
-    (prev-link res start)
-    (use-continuation res cont)))
-
-
-;;; Reference-Leaf  --  Internal
-;;;
-;;;    Generate a Ref node for a Leaf, frobbing the Leaf structure as
-;;; needed.  Inlinep specifies the legality of inline coding for a 
-;;; function-valued variable. 
-;;;
-(proclaim '(function reference-leaf
-		     (continuation continuation leaf inlinep)
-		     void))
-(defun reference-leaf (start cont leaf inlinep)
-  (let ((res (make-ref (or (cdr (assoc leaf *type-restrictions*))
-			   (leaf-type leaf))
-		       (leaf-name leaf)
-		       leaf
-		       inlinep)))
-    (push res (leaf-refs leaf))
-    (setf (leaf-ever-used leaf) t)
-    (prev-link res start)
-    (use-continuation res cont)))
-
-
-;;; Set-Variable  --  Internal
-;;;
-;;;    Kind of like Reference-Leaf, but we generate a Set node.  This
-;;; should only need to be called in Setq.
-;;;
-(proclaim '(function set-variable (continuation continuation basic-var t list) void)) 
-(defun set-variable (start cont var value source)
-  (let ((dest (make-continuation)))
-    (setf (continuation-asserted-type dest) (leaf-type var))
-    (ir1-convert start dest value)
-    (let ((res (make-set :source source :var var :value dest)))
-      (setf (continuation-dest dest) res)
-      (setf (leaf-ever-used var) t)
-      (push res (basic-var-sets var))
-      (prev-link res dest)
-      (use-continuation res cont))))
-      
-
-;;;; Some flow-graph hacking utilities:
-
-;;; Prev-Link  --  Internal
-;;;
-;;;    This function sets up the back link between the node and the
-;;; continuation which continues at it. 
-;;;
-(proclaim '(function prev-link (node continuation) void))
-(defun prev-link (node cont)
-  (assert (not (continuation-next cont)) () "~S already has a next." cont)
-  (assert (not (node-prev node)) () "Garbage in Prev for ~S." node)
-  (setf (continuation-next cont) node)
-  (setf (node-prev node) cont))
-
-
-;;; Use-Continuation  --  Internal
-;;;
-;;;    This function is used to set the continuation for a node, and thus
-;;; determine what recieves the value and what is evaluated next.  If the
-;;; continuation has no block, then we make it be in the block that the node is
-;;; in.  If the continuation heads its block, we end our block and link it to
-;;; that block.  If the continuation is not currently used, then we set the
-;;; derived-type for the continuation to that of the node, so that a little
-;;; type propagation gets done.
-;;;
-(proclaim '(function use-continuation (node continuation) void))
-(defun use-continuation (node cont)
-  (let ((block (continuation-block cont))
-	(node-block (continuation-block (node-prev node))))
-    (assert (not (node-cont node)) () "Garbage in Cont for ~S." node)
-    (ecase (continuation-kind cont)
-      (:unused
-       (setf (continuation-block cont) node-block)
-       (setf (continuation-kind cont) :inside-block)
-       (setf (continuation-use cont) node)
-       (setf (node-cont node) cont))
-      (:block-start
-       (assert (not (block-last node-block)) () "~S has already ended."
-	       node-block)
-       (setf (block-last node-block) node)
-       (assert (null (block-succ node-block)) () "~S already has successors."
-	       node-block)
-       (setf (block-succ node-block) (list block))
-       (assert (not (member node-block (block-pred block))) ()
-	       "~S is already a predecessor of ~S." node-block block)
-       (push node-block (block-pred block))
-       (add-continuation-use node cont)))))
-
-
-;;; Continuation-Starts-Block  --  Internal
-;;;
-;;;    Return the block that Continuation is the start of, making a block if
-;;; necessary.  This function is called by IR1 translators which may cause a
-;;; continuation to be used more than once.  Every continuation which may be
-;;; used more than once must start a block by the time that anyone does a
-;;; Use-Continuation on it.
-;;;
-;;;    Note that the block is made in the *current-lambda*, so continuations
-;;; without blocks cannot be passed across function boundaries since they might
-;;; get a block assigned which is in the wrong function.  Basically this means
-;;; that BLOCK and TAGBODY must make sure that their named continuations have
-;;; blocks.
-;;;
-;;;    We also throw the block into the next/prev list for the
-;;; *current-component* so that we keep track of which blocks we have made.
-;;;
-(defun continuation-starts-block (cont)
-  (declare (type continuation cont))
-  (ecase (continuation-kind cont)
-    (:unused
-     (assert (not (continuation-block cont)))
-     (let* ((head (component-head *current-component*))
-	    (next (block-next head))
-	    (new-block (make-block cont)))
-       (setf (block-next new-block) next)
-       (setf (block-prev new-block) head)
-       (setf (block-prev next) new-block)
-       (setf (block-next head) new-block)
-       (setf (continuation-block cont) new-block)
-       (setf (continuation-use cont) nil)
-       (setf (continuation-kind cont) :block-start)
-       new-block))
-    (:block-start
-     (continuation-block cont))))
-
-
-;;;; Exported functions:
-
-;;; IR1-Top-Level  --  Interface
-;;;
-;;;    This function takes a form and the top-level form number for that form,
-;;; and returns a lambda representing the translation of that form in the
-;;; current global environment.  The lambda is top-level lambda that can be
-;;; called to cause evaluation of the forms.  This lambda is in the initial
-;;; component.  If For-Value is T, then the value of the form is returned from
-;;; the function, otherwise NIL is returned.
-;;;
-;;;    This function may have arbitrary effects on the global environment due
-;;; to processing of Proclaims and Eval-Whens.  All syntax error checking is
-;;; done, with erroneous forms being replaced by a proxy which signals an error
-;;; if it is evaluated.  Warnings about possibly inconsistent or illegal
-;;; changes to the global environment will also be given.
-;;;
-;;;    We make the initial component and convert the form in a progn (and an
-;;; optional NIL tacked on the end.)  We then return the lambda.  We bind all
-;;; of our state variables here, rather than relying on the global value (if
-;;; any) so that IR1 conversion will be reentrant.  This is necessary for
-;;; eval-when processing, etc.
-;;;
-;;;    The hashtables used to hold global namespace info must be reallocated
-;;; elsewhere.  Note also that *fenv* is not rebound, so that local macro
-;;; definitions can be introduced by enclosing code.
-;;;
-(defun ir1-top-level (form tlf-num for-value)
-  (declare (type index tlf-num))
-  (let* ((*current-path* (or (gethash form *source-paths*)
-			     (list 0 tlf-num)))
-	 (*inlines* ())
-	 (*type-restrictions* ())
-	 (*venv* ())
-	 (*benv* ())
-	 (*tenv* ())
-	 (*current-cookie* (make-cookie))
-	 (*current-lambda* nil)
-	 (*current-cleanup* nil)
-	 (*current-form* nil)
-	 (component (make-empty-component))
-	 (*current-component* component))
-    (setf (component-name component) "initial component")
-    (setf (component-kind component) :initial)
-    (let* ((forms (if for-value `(,form) `(,form nil)))
-	   (res (ir1-convert-lambda-body forms () `(progn ,@forms))))
-      (setf (leaf-name res) "Top-Level Form")
-      (setf (functional-entry-function res) res)
-      (setf (functional-arg-documentation res) ())
-      (setf (functional-kind res) :top-level)
-      res)))
-
-
-;;; *CURRENT-FORM-NUMBER* is used in FIND-SOURCE-PATHS to compute the form
-;;; number to associate with a source path.  This should be bound to 0 around
-;;; the processing of each truly top-level form.
-;;;
-(proclaim '(type index *current-form-number*))
-(defvar *current-form-number*)
-
-;;; Find-Source-Paths  --  Interface
-;;;
-;;;    This function is called on freshly read forms to record the initial
-;;; location of each form (and subform.)  Form is the form to find the paths
-;;; in, and TLF-Num is the top-level form number of the truly top-level form.
-;;;
-;;;    This gets a bit interesting when the source code is circular.  This can
-;;; (reasonably?) happen in the case of circular list constants. 
-;;;
-(defun find-source-paths (form tlf-num)
-  (declare (type index tlf-num))
-  (let ((*current-form-number* 0))
-    (sub-find-source-paths form (list tlf-num)))
-  (undefined-value))
-;;;
-(defun sub-find-source-paths (form path)
-  (unless (gethash form *source-paths*)
-    (setf (gethash form *source-paths*)
-	  (cons *current-form-number* path))
-    (incf *current-form-number*)
-    (let ((pos 0)
-	  (subform form)
-	  (trail form))
-      (declare (fixnum pos))
-      (macrolet ((frob ()
-		   '(progn
-		      (when (atom subform) (return))
-		      (let ((fm (car subform)))
-			(when (consp fm)
-			  (sub-find-source-paths fm (cons pos path)))
-			(incf pos))
-		      (setq subform (cdr subform))
-		      (when (eq subform trail) (return)))))
-	(loop
-	  (frob)
-	  (frob)
-	  (setq trail (cdr trail)))))))
-
-
-;;;; Control special forms:
-
-(def-ir1-translator progn ((&rest forms) start cont)
-  "Progn Form*
-  Evaluates each Form in order, returing the values of the last form.  With no
-  forms, returns NIL."
-  (ir1-convert-progn-body start cont forms))
-
-(def-ir1-translator if ((test then &optional else &whole source) start cont)
-  "If Predicate Then [Else]
-  If Predicate evaluates to non-null, evaluate Then and returns its values,
-  otherwise evaluate Else and return its values.  Else defaults to NIL."
-  (let* ((pred (make-continuation))
-	 (then-cont (make-continuation))
-	 (then-block (continuation-starts-block then-cont))
-	 (else-cont (make-continuation))
-	 (else-block (continuation-starts-block else-cont))
-	 (dummy-cont (make-continuation))
-	 (node (make-if :test pred
-			:consequent then-block  :alternative else-block
-			:source source)))
-    (setf (continuation-dest pred) node)
-    (ir1-convert start pred test)
-    (prev-link node pred)
-    (use-continuation node dummy-cont)
-    
-    (let ((start-block (continuation-block pred)))
-      (setf (block-last start-block) node)
-      (continuation-starts-block cont)
-      
-      (link-blocks start-block then-block)
-      (link-blocks start-block else-block)
-      
-      (ir1-convert then-cont cont then)
-      (ir1-convert else-cont cont else))))
-
-
-;;;; Block and Tagbody:
-;;;
-;;;    We make an Entry node to mark the start and a :Entry cleanup to
-;;; mark its extent.  When doing Go or Return-From, we emit an Exit node.
-;;; 
-
-;;; Block IR1 convert  --  Internal
-;;;
-;;;    Make a :entry cleanup and emit an Entry node, then convert the body in
-;;; the modified environment.  We make Cont start a block now, since if it was
-;;; done later, the block would be in the wrong environment.
-;;;
-(def-ir1-translator block ((name &rest forms &whole source) start cont)
-  "Block Name Form*
-  Evaluate the Forms as a PROGN.  Within the lexical scope of the body,
-  (RETURN-FROM Name Value-Form) can be used to exit the form, returning the
-  result of Value-Form."
-  (unless (symbolp name)
-    (compiler-error "Block name is not a symbol: ~S." name))
-  (continuation-starts-block cont)
-  (let* ((dummy (make-continuation))
-	 (entry (make-entry :exits (list cont)  :source source))
-	 (cleanup (make-cleanup :kind :entry  :start dummy)))
-    (push entry (lambda-entries *current-lambda*))
-    (prev-link entry start)
-    (use-continuation entry dummy)
-    (setf (block-end-cleanup (continuation-block dummy)) cleanup)
-    (let ((*benv* (acons name (list entry cont) *benv*))
-	  (*current-cleanup* cleanup))
-      (ir1-convert-progn-body dummy cont forms))))
-
-;;; We make Cont start a block just so that it will have a block assigned.
-;;; People assume that when they pass a continuation into IR1-Convert as Cont,
-;;; it will have a block when it is done.
-;;;
-(def-ir1-translator return-from ((name &optional value &whole source)
-				 start cont)
-  "Return-From Block-Name Value-Form
-  Evaluate the Value-Form, returning its values from the lexically enclosing
-  BLOCK Block-Name.  This is constrained to be used only within the dynamic
-  extent of the BLOCK."
-  (continuation-starts-block cont)
-  (let* ((found (or (cdr (assoc name *benv*))
-		    (compiler-error "Return for unknown block: ~S." name)))
-	 (value-cont (make-continuation))
-	 (exit (make-exit :entry (first found)  :value value-cont
-			  :source source)))
-    (setf (continuation-dest value-cont) exit)
-    (ir1-convert start value-cont value)
-    (prev-link exit value-cont)
-    (use-continuation exit (second found))))
-
-
-;;; Parse-Tagbody  --  Internal
-;;;
-;;;    Return a list of the segments of a tagbody.  Each segment looks like
-;;; (<tag> <form>* (go <next tag>)).  That is, we break up the tagbody into
-;;; segments of non-tag statements, and explicitly represent the drop-through
-;;; with a GO.  The first segment has a dummy NIL tag, since it represents code
-;;; before the first tag.  The last segment (which may also be the first
-;;; segment) ends in NIL rather than a GO.
-;;;
-(defun parse-tagbody (body)
-  (declare (list body))
-  (collect ((segments))
-    (let ((current (cons nil body)))
-      (loop
-	(let ((tag-pos (position-if #'atom current :start 1)))
-	  (unless tag-pos
-	    (segments `(,@current nil))
-	    (return))
-	  (let ((tag (elt current tag-pos)))
-	    (when (assoc tag (segments))
-	      (compiler-error "Repeated tagbody tag: ~S." tag))
-	    (unless (or (symbolp tag) (integerp tag))
-	      (compiler-error "Illegal tagbody statement: ~S." tag))	      
-	    (segments `(,@(subseq current 0 tag-pos) (go ,tag))))
-	  (setq current (nthcdr tag-pos current)))))
-    (segments)))
-  
-
-;;; Tagbody IR1 convert  --  Internal
-;;;
-;;;    Set up the cleanup, emitting the entry node.  Then make a block for each
-;;; tag, building up the tag list for *tenv* as we go.  Finally, convert each
-;;; segment with the precomputed Start and Cont values.
-;;;
-(def-ir1-translator tagbody ((&rest statements &whole source) start cont)
-  "Tagbody {Tag | Statement}*
-  Define tags for used with GO.  The Statements are evaluated in order
-  (skipping Tags) and NIL is returned.  If a statement contains a GO to a
-  defined Tag within the lexical scope of the form, then control is transferred
-  to the next statement following that tag.  A Tag must an integer or a
-  symbol.  A statement must be a list.  Other objects are illegal within the
-  body."
-  (continuation-starts-block cont)
-  (let* ((dummy (make-continuation))
-	 (entry (make-entry :source source))
-	 (*current-cleanup* (make-cleanup :kind :entry  :start dummy))
-	 (segments (parse-tagbody statements)))
-    (push entry (lambda-entries *current-lambda*))
-    (prev-link entry start)
-    (use-continuation entry dummy)
-    (setf (block-end-cleanup (continuation-block start)) *current-cleanup*)
-
-    (collect ((tags)
-	      (starts)
-	      (conts))
-      (starts dummy)
-      (dolist (segment (rest segments))
-	(let ((tag-cont (make-continuation)))
-	  (conts tag-cont)
-	  (starts tag-cont)
-	  (continuation-starts-block tag-cont)
-	  (tags (list (car segment) entry tag-cont))))
-      (conts cont)
-      
-      (setf (entry-exits entry) (rest (starts)))
-      
-      (let ((*tenv* (append (tags) *tenv*)))
-	(mapc #'(lambda (segment start cont)
-		  (ir1-convert-progn-body start cont (rest segment)))
-	      segments (starts) (conts))))))
-
-
-;;; Go IR1 convert  --  Internal
-;;;
-;;;    Emit an Exit node without any value.
-;;;
-(def-ir1-translator go ((tag &whole source) start cont)
-  "Go Tag
-  Transfer control to the named Tag in the lexically enclosing TAGBODY.  This
-  is constrained to be used only within the dynamic extent of the TAGBODY."
-  (continuation-starts-block cont)
-  (let* ((found (or (cdr (assoc tag *tenv*))
-		    (compiler-error "Go to nonexistent tag: ~S." tag)))
-	 (exit (make-exit :entry (first found)  :source source)))
-    (prev-link exit start)
-    (use-continuation exit (second found))))
-
-
-;;;; Translators for compiler-magic special forms:
-
-(def-ir1-translator compiler-let ((bindings &rest body) start cont)
-  (collect ((vars)
-	    (values))
-    (dolist (bind bindings)
-      (typecase bind
-	(symbol
-	 (vars bind)
-	 (values nil))
-	(list
-	 (unless (= (length bind) 2)
-	   (compiler-error "Bad compiler-let binding spec: ~S." bind))
-	 (vars (first bind))
-	 (values (eval (second bind))))
-	(t
-	 (compiler-error "Bad compiler-let binding spec: ~S." bind))))
-    (progv (vars) (values)
-      (ir1-convert-progn-body start cont body))))
-
-
-#-new-compiler
-;;;
-;;; This flag is used by Eval-When to keep track of when code has already been
-;;; evaluated so that it can avoid multiple evaluation of nested Eval-When
-;;; (Compile)s.
-(defvar *already-evaled-this* nil)
-
-#-new-compiler
-;;; DO-EVAL-WHEN-STUFF  --  Interface
-;;;
-;;;    Do stuff to do an EVAL-WHEN.  This is split off from the IR1 convert
-;;; method so that it can be shared by the special-case top-level form
-;;; processing code.  We play with the dynamic environment and eval stuff, then
-;;; call Fun with a list of forms to be processed at load time.
-;;; 
-;;;    We have to go through serious contortions to ensure that the forms get
-;;; eval'ed exactly once.  If *already-evaled-this* is true then we *do not*
-;;; eval since some enclosing eval-when already did.  If we do eval, we
-;;; throw a binding of the funny lexical variable %compiler-eval-when-marker%
-;;; into the %venv% before we eval the code.  This is to inform the eval-when
-;;; in the interpreter that it should eval forms even if they contain only
-;;; a COMPILE.  We don't want to use a special as a flag, since that would
-;;; pervasively alter the semantics of eval-when, when we just want to
-;;; alter it within the lexical scope of this eval-when.
-;;;
-;;;    We know we are eval'ing for load since we wouldn't get called otherwise.
-;;; If LOAD is a situation we convert the body like a progn.  If we eval'ed the
-;;; body, then we bind *already-evaled-this* to T around the conversion of body
-;;; inhibiting the evaluation of any nested eval-when's.  If we aren't
-;;; evaluating for load, then we just convert NIL for the result of the
-;;; Eval-When.
-;;;
-(defun do-eval-when-stuff (situations body fun)
-  (when (or (not (listp situations))
-	    (set-difference situations '(compile load eval)))
-    (compiler-error "Bad Eval-When situation list: ~S." situations))
-
-  (let* ((compilep (member 'compile situations))
-	 (evalp (member 'eval situations))
-	 (do-eval (and compilep (not *already-evaled-this*))))
-    (when do-eval
-      (let ((lisp::%venv% '((lisp::%compile-eval-when-marker% t))))
-	(lisp::eval-as-progn body)))
-    (if (member 'load situations)
-	(let ((*already-evaled-this* (or do-eval (and *already-evaled-this* evalp))))
-	  (funcall fun body))
-	(funcall fun ()))))
-
-#+new-compiler
-(proclaim '(special lisp::*already-evaled-this*))
-
-#+new-compiler
-;;; DO-EVAL-WHEN-STUFF  --  Interface
-;;;
-;;;    Do stuff to do an EVAL-WHEN.  This is split off from the IR1 convert
-;;; method so that it can be shared by the special-case top-level form
-;;; processing code.  We play with the dynamic environment and eval stuff, then
-;;; call Fun with a list of forms to be processed at load time.
-;;;
-;;; Note: the EVAL situation is always ignored: this is conceptually a
-;;; compile-only implementation.
-;;;
-;;; We have to interact with the interpreter to ensure that the forms get
-;;; eval'ed exactly once.  We bind *already-evaled-this* to true to inhibit
-;;; evaluation of any enclosed EVAL-WHENs, either by IR1 conversion done by
-;;; EVAL, or by conversion of the body for load-time processing.  If
-;;; *already-evaled-this* is true then we *do not* eval since some enclosing
-;;; eval-when already did.
-;;;
-;;;    We know we are eval'ing for load since we wouldn't get called otherwise.
-;;; If LOAD is a situation we call Fun on body. If we aren't evaluating for
-;;; load, then we call Fun on NIL for the result of the EVAL-WHEN.
-;;;
-(defun do-eval-when-stuff (situations body fun)
-  (when (or (not (listp situations))
-	    (set-difference situations '(compile load eval)))
-    (compiler-error "Bad Eval-When situation list: ~S." situations))
-
-  (let* ((do-eval (and (member 'compile situations)
-		       (not lisp::*already-evaled-this*)))
-	 (lisp::*already-evaled-this* t))
-    (when do-eval
-      (eval `(progn ,@body)))
-    (if (member 'load situations)
-	(funcall fun body)
-	(funcall fun '(nil)))))
-
-  
-(def-ir1-translator eval-when ((situations &rest body) start cont)
-  (do-eval-when-stuff situations body
-		      #'(lambda (forms)
-			  (ir1-convert-progn-body start cont forms))))
-
-
-;;; DO-MACROLET-STUFF  --  Interface
-;;;
-;;;    Like DO-EVAL-WHEN-STUFF, only do a macrolet.  Fun is not passed any
-;;; arguments.  We cleverly make the FENV entry for a macro look like the
-;;; interpreter version so that we can pass in *fenv* as a macroexpansion
-;;; environment.
-;;;
-(defun do-macrolet-stuff (definitions fun)
-  (declare (list definitions) (function fun))
-  (let ((*fenv* *fenv*)
-	(whole (gensym))
-	(environment (gensym)))
-    (dolist (def definitions)
-      (let ((name (first def))
-	    (arglist (second def))
-	    (body (cddr def)))
-	(multiple-value-bind (body local-decs)
-			     (lisp::parse-defmacro
-			      arglist whole body name
-			      :environment environment
-			      :error-string 'lisp::defmacro-error-string)
-	  (unless (symbolp name)
-	    (compiler-error "Macro name ~S is not a symbol." name))
-	  (when (< (length def) 3)
-	    (compiler-error "Local macro ~S is too short to be a legal definition." name))
-	  #-new-compiler
-	  (push `(,(first def) macro lambda
-		  (,whole ,environment) ,@local-decs (block ,name ,body))
-		*fenv*)
-	  #+new-compiler
-	  (push `(,(first def) macro .
-		  ,(coerce `(lambda (,whole ,environment)
-			      ,@local-decs (block ,name ,body))
-			   'function))
-		*fenv*))))
-    (funcall fun))
-
-  (undefined-value))
-
-
-(def-ir1-translator macrolet ((definitions &rest body) start cont)
-  (do-macrolet-stuff definitions
-		     #'(lambda ()
-			 (ir1-convert-progn-body start cont body))))
-
-
-;;; Not really a special form, but...
-;;;
-(def-ir1-translator declare ((&rest stuff) start cont)
-  (declare (ignore stuff))
-  start cont; Ignore hack
-  (compiler-error "Misplaced declaration."))
-
-
-;;;; %Primitive:
-;;;
-;;;    Uses of %primitive are either expanded into Lisp code or turned into a
-;;; funny function.
-;;;
-
-;;; Eval-Info-Args  --  Internal
-;;;
-;;;    Carefully evaluate a list of forms, returning a list of the results.
-;;;
-(defun eval-info-args (args)
-  (declare (list args))
-  (handler-case (mapcar #'eval args)
-    (error (condition)
-      (compiler-error "Lisp error during evaluation of info args:~%~A"
-		      condition))))
-
-;;; A hashtable that translates from primitive names to translation functions.
-;;;
-(defvar *primitive-translators* (make-hash-table :test #'eq))
-
-;;; IR1-Convert-%Primitive  --  Internal
-;;;
-;;;    If there is a primitive translator, then we expand the call.  Otherwise,
-;;; we convert to the %%Primitive funny function.  The first argument is the
-;;; template, the second is a list of the results of any codegen-info args, and
-;;; the remaining arguments are the runtime arguments.
-;;;
-;;;    We do a bunch of error checking now so that we don't bomb out with a
-;;; fatal error during IR2 conversion.
-;;;
-(def-ir1-translator system:%primitive ((name &rest args &whole form)
-				       start cont)
-  
-  (unless (symbolp name)
-    (compiler-error "%Primitive name is not a symbol: ~S." name))
-
-  (let* ((name (intern (symbol-name name) "C"))
-	 (translator (gethash name *primitive-translators*)))
-    (if translator
-	(ir1-convert start cont (funcall translator (cdr form)))
-	(let* ((template (or (gethash name *template-names*)
-			     (compiler-error "Undefined primitive name: ~A."
-					     name)))
-	       (required (length (template-arg-types template)))
-	       (info (template-info-arg-count template))
-	       (min (+ required info))
-	       (nargs (length args)))
-	  (if (template-more-args-type template)
-	      (when (< nargs min)
-		(compiler-error "Primitive called with ~R argument~:P, ~
-	    		         but wants at least ~R."
-				nargs min))
-	      (unless (= nargs min)
-		(compiler-error "Primitive called with ~R argument~:P, ~
-				 but wants exactly ~R."
-				nargs min)))
-
-	  (when (eq (template-result-types template) :conditional)
-	    (compiler-error "%Primitive used with a conditional template."))
-
-	  (when (template-more-results-type template)
-	    (compiler-error
-	     "%Primitive used with an unknown values template."))
-	  
-	  (ir1-convert start cont
-		      `(%%primitive ',template
-				    ',(eval-info-args
-				       (subseq args required min))
-				    ,@(subseq args 0 required)
-				    ,@(subseq args min)))))))
-
-
-;;;; Quote and Function:
-
-(def-ir1-translator quote ((thing &whole source) start cont)
-  (reference-constant start cont thing source))
-
-
-(def-ir1-translator function ((thing) start cont)
-  (if (and (consp thing) (eq (car thing) 'lambda))
-      (reference-leaf start cont (ir1-convert-lambda thing) nil)
-      (multiple-value-bind (var inlinep)
-			   (find-lexically-apparent-function
-			    thing "as the argument to FUNCTION")
-	(reference-leaf start cont var inlinep))))
-
-
-;;;; Magic functions:
-;;;
-;;;    Various global functions must be treated magically in IR1 conversion.
-;;; If a function is always magical, then we just define an IR1-Convert method
-;;; for it.  If the magic is effectively a form of inline expansion, then we
-;;; define a source transform which transforms to an internal thing which we
-;;; pretend is a special form.
-;;;
-;;; %Funcall is used by people who want the call to be open-coded regardless of
-;;; user policy settings.
-;;;
-
-(def-source-transform funcall (function &rest args)
-  `(%funcall ,function ,@args))
-
-(def-ir1-translator %funcall ((function &rest args) start cont)
-  (let ((fun-cont (make-continuation)))
-    (ir1-convert start fun-cont function)
-    (ir1-convert-combination-args fun-cont cont `(funcall ,function ,@args)
-				  args)))
-
-
-;;;; Proclaim:
-;;;
-;;;    Proclaim changes the global environment, so we must special-case it if
-;;; we are to keep the information in the *FREE-xxx* variables up to date.
-;;; When there is a var structure we disown it by replacing it with an updated
-;;; copy.  Uses of the variable which were translated before the PROCLAIM will
-;;; get the old version, while subsequent references will get the updated
-;;; information. 
-
-
-;;; Get-Old-Vars  --  Internal
-;;;
-;;;    Look up some symbols in *free-variables*, returning the var structures
-;;; for any which exist.  If any of the names aren't symbols, we complain.
-;;;
-(proclaim '(function get-old-vars (list) list))
-(defun get-old-vars (names)
-  (collect ((vars))
-    (dolist (name names (vars))
-      (unless (symbolp name)
-	(compiler-error "Name is not a symbol: ~S." name))
-      (let ((old (gethash name *free-variables*)))
-	(when old (vars old))))))
-
-
-;;; Process-Type-Proclamation  --  Internal
-;;;
-;;;    Replace each old var entry with one having the new type.  If the new
-;;; type doesn't intersect with the old type, give a warning.  
-;;;
-;;;    We also check that the old type of each variable intersects with the new
-;;; one, giving a warning if not.  This isn't as serious as conflicting local
-;;; declarations, since we assume a redefinition semantics rather than an
-;;; intersection semantics.
-;;;
-(proclaim '(function process-type-proclamation (t list) void))
-(defun process-type-proclamation (spec names)
-  (let ((type (single-value-type (specifier-type spec))))
-    (when (policy nil (>= safety brevity))
-      (dolist (name names)
-	(let ((old-type (info variable type name)))
-	  (unless (or (function-type-p type)
-		      (function-type-p old-type)
-		      (types-intersect type old-type))
-	    (compiler-warning
-	     "New proclaimed type ~S for ~S conflicts with old type ~S."
-	     (type-specifier type) name (type-specifier old-type))))))
-
-    (dolist (var (get-old-vars names))
-      (let ((new (etypecase var
-		   (global-var (copy-global-var var))
-		   (constant (copy-constant var)))))
-	(setf (leaf-type new) type)
-	(setf (leaf-where-from new) :declared)
-	(setf (gethash (leaf-name var) *free-variables*) new)))))
-
-
-
-;;; Process-1-Ftype-Proclamation  --  Internal
-;;;
-;;;    For now, just update the type of any old var and remove the name from
-;;; the list of undefined functions.  Eventually we whould check for
-;;; incompatible redefinition.
-;;;
-(defun process-1-ftype-proclamation (name type)
-  (declare (type function-type type))
-  (let ((var (gethash (define-function-name name) *free-functions*)))
-    (when var
-      (let ((new (copy-global-var var))
-	    (name (leaf-name var)))
-	(setf (leaf-type new) type)
-	(setf (leaf-where-from new) :declared)
-	(setf (gethash name *free-functions*) new))))
-
-  (setq *unknown-functions*
-	(delete name *unknown-functions*
-		:test #'equal
-		:key #'unknown-function-name))
-  (undefined-value))
-
-
-;;; Process-Ftype-Proclamation  --  Internal
-;;;
-(proclaim '(function process-ftype-proclamation (t list) void))
-(defun process-ftype-proclamation (spec names)
-  (let ((type (specifier-type spec)))
-    (unless (function-type-p type)
-      (compiler-error
-       "Declared functional type is not a function type: ~S." spec))
-    (dolist (name names)
-      (process-1-ftype-proclamation name type))))
-
-
-(def-ir1-translator proclaim ((what) start cont :kind :function)
-  (when (constantp what)
-    (let ((form (eval what)))
-      (unless (consp form)
-	(compiler-error "Malformed PROCLAIM spec: ~S." form))
-       
-      (let ((name (first form))
-	    (args (rest form)))
-	(case (first form)
-	  (special
-	   (dolist (old (get-old-vars (rest form)))
-	     (when (or (constant-p old)
-		       (eq (global-var-kind old) :constant))
-	       (compiler-error
-		"Attempt to proclaim constant ~S to be special." name))
-
-	     (ecase (global-var-kind old)
-	       (:special)
-	       (:global
-		(let ((new (copy-global-var old)))
-		  (setf (global-var-kind new) :special)
-		  (setf (gethash name *free-variables*) new))))))
-	  (type
-	   (when (endp args)
-	     (compiler-error "Malformed TYPE proclamation: ~S." form))
-	   (process-type-proclamation (first args) (rest args)))
-	  (function
-	   (when (endp args)
-	     (compiler-error "Malformed FUNCTION proclamation: ~S." form))
-	   (process-ftype-proclamation `(function . ,(rest args))
-				       (list (first args))))
-	  (ftype
-	   (when (endp args)
-	     (compiler-error "Malformed FTYPE proclamation: ~S." form))
-	   (process-ftype-proclamation (first args) (rest args)))
-	  ;;
-	  ;; No non-global state to be updated.
-	  ((inline notinline maybe-inline optimize declaration))
-	  (t
-	   (cond ((member name type-specifier-symbols)
-		  (process-type-proclamation name args))
-		 ((info declaration recognized name))
-		 (t
-		  (compiler-warning "Unrecognized proclamation: ~S." form))))))
-
-      (funcall #'%proclaim form)))
-  (ir1-convert start cont `(%proclaim ,what)))
-
-
-;;; %Compiler-Defstruct IR1 Convert  --  Internal
-;;;
-;;;    This is a frob that DEFMACRO expands into to establish the compiler
-;;; semantics.  This is similar to the translator for proclaim: its job is to
-;;; keep the *free-functions* in sync.
-;;;
-(def-ir1-translator %compiler-defstruct ((info) start cont :kind :function)
-  (let* ((info (eval info))
-	 (name (dd-name info))
-	 (copier (dd-copier info))
-	 (predicate (dd-predicate info)))
-    (setf (info type kind name) :structure)
-    (setf (info type structure-info name) info)
-    (dolist (slot (dd-slots info))
-      (let ((fun (dsd-accessor slot))
-	    (type (dsd-type slot)))
-	(process-1-ftype-proclamation
-	 fun
-	 (specifier-type `(function (,name) ,type)))
-	(unless (dsd-read-only slot)
-	  (process-1-ftype-proclamation
-	   `(setf ,fun)
-	   (specifier-type `(function (,name ,type) ,type))))))
-
-    (collect ((forms))
-      (when copier
-	(forms `(proclaim '(ftype (function (,name) ,name) ,copier))))
-      
-      (when predicate
-	(forms `(proclaim '(ftype (function (t) boolean) ,predicate))))
-      
-      (funcall #'%%compiler-defstruct info)
-      (ir1-convert start cont `(progn
-				 ,@(forms)
-				 (%%compiler-defstruct ',info))))))
-
-
-;;;; Let and Let*:
-;;;
-;;;    Let and Let* can't be implemented as macros due to the fact that
-;;; any pervasive declarations also affect the evaluation of the arguments.
-
-;;; Extract-Let-Variables  --  Internal
-;;;
-;;;    Given a list of binding specifiers in the style of Let, return:
-;;;  1] The list of var structures for the variables bound.
-;;;  2] The initial value form for each variable.
-;;;
-;;; The variable names are checked for legality and globally special variables
-;;; are marked as such.  Context is the name of the form, for error reporting
-;;; purposes.
-;;;
-(proclaim '(function extract-let-variables (list symbol) (values list list)))
-(defun extract-let-variables (bindings context)
-  (collect ((vars)
-	    (vals)
-	    (names))
-    (dolist (spec bindings)
-      (cond ((atom spec)
-	     (let ((var (varify-lambda-arg spec (names))))
-	       (vars var)
-	       (names (cons spec var)) 
-	       (vals nil)))
-	    (t
-	     (when (/= (length spec) 2)
-	       (compiler-error "Malformed ~S binding spec: ~S." context spec))
-	     (let* ((name (first spec))
-		    (var (varify-lambda-arg name (names))))
-	       (vars var)
-	       (names name)
-	       (vals (second spec))))))
-
-    (values (vars) (vals) (names))))
-
-
-(def-ir1-translator let ((bindings &body (body decls) &whole source) start cont)
-  (multiple-value-bind (vars values)
-		       (extract-let-variables bindings 'let)
-    (multiple-value-bind (*venv* *inlines* *type-restrictions* *current-cookie*)
-			 (process-declarations decls vars nil)
-
-      (let ((fun-cont (make-continuation))
-	    (fun (ir1-convert-lambda-body body vars source)))
-	(reference-leaf start fun-cont fun nil)
-	(ir1-convert-combination-args fun-cont cont source values)))))
-
-
-(def-ir1-translator let* ((bindings &body (body decls) &whole source) start cont)
-  (multiple-value-bind (vars values)
-		       (extract-let-variables bindings 'let*)
-    (multiple-value-bind (*venv* *inlines* *type-restrictions* *current-cookie*)
-			 (process-declarations decls vars nil)
-      (ir1-convert-aux-bindings start cont body source vars values))))
-
-
-;;;; Flet and Labels:
-
-;;; Extract-Flet-Variables  --  Internal
-;;;
-;;;    Given a list of local function specifications in the style of Flet,
-;;; return lists of the function names and of the lambdas which are their
-;;; definitions.
-;;;
-;;; The function names are checked for legality.  Context is the name of the
-;;; form, for error reporting.
-;;;
-(proclaim '(function extract-flet-variables (list symbol) (values list list)))
-(defun extract-flet-variables (definitions context)
-  (collect ((names)
-	    (defs))
-    (dolist (def definitions)
-      (when (or (atom def) (< (length def) 2))
-	(compiler-error "Malformed ~S definition spec: ~S." context def))
-
-      (let ((name (check-function-name (first def))))
-	(names name)
-	(defs (cons 'lambda (rest def)))))
-    (values (names) (defs))))
-
-
-(def-ir1-translator flet ((definitions &body (body decls))
-			  start cont)
-  (multiple-value-bind (names defs)
-		       (extract-flet-variables definitions 'flet)
-    (let ((fvars (mapcar #'(lambda (n d)
-			     (let ((res (ir1-convert-lambda d)))
-			       (setf (leaf-name res) n)
-			       res))
-			 names defs)))
-      (multiple-value-bind (*venv* *inlines* *type-restrictions* *current-cookie*)
-			   (process-declarations decls nil fvars)
-	(let ((*fenv* (pairlis names fvars *fenv*)))
-	  (ir1-convert-progn-body start cont body))))))
-
-
-;;; For Labels, we have to create dummy function vars and add them to *fenv*
-;;; while converting the functions.  We then modify all the references to these
-;;; leaves so that they point to the real functional leaves.
-;;;
-;;; [Perhaps not totally correct, since the declarations aren't processed until
-;;; after the function definitions.  This means that declarations for local
-;;; functions may not have their full effect on references within the local
-;;; functions.]
-;;;
-(def-ir1-translator labels ((definitions &body (body decls)) start cont)
-  (multiple-value-bind (names defs)
-		       (extract-flet-variables definitions 'labels)
-    (let* ((dummies (mapcar #'(lambda (x)
-				(make-functional :name x)) names))
-	   (real-funs 
-	    (let ((*fenv* (pairlis names dummies *fenv*)))
-	      (mapcar #'(lambda (n d)
-			  (let ((res (ir1-convert-lambda d)))
-			    (setf (leaf-name res) n)
-			    res))
-		      names defs))))
-
-      (mapc #'substitute-leaf real-funs dummies)
-
-      (multiple-value-bind
-	  (*venv* *inlines* *type-restrictions* *current-cookie*)
-	  (process-declarations decls nil real-funs)
-
-	(let ((*fenv* (pairlis names real-funs *fenv*)))
-	  (ir1-convert-progn-body start cont body))))))
-
-
-;;;; THE
-;;;
-;;;    This is somewhat involved, since a type assertion may only be made on a
-;;; continuation, not on a node.  If the continuation has no uses before the
-;;; form is converted, then we may make the type the assertion for the
-;;; continuation.  If there are other uses, then we accept some loss of
-;;; information, but try to retain as much as possible.  In this case, we make
-;;; the type assertion the union of the pre-existing type assertion and the new
-;;; type.
-
-(def-ir1-translator the ((type value) start cont)
-  (let ((ctype (specifier-type type)))
-    (if (null (find-uses cont))
-	(let* ((old-type (continuation-asserted-type cont))
-	       (int (values-type-intersection old-type ctype)))
-	  (when (eq int *empty-type*)
-	    (compiler-warning
-	     "Type ~S in THE declaration conflicts with previous type ~S."
-	     (type-specifier ctype) (type-specifier old-type)))
-	  (setf (continuation-asserted-type cont) int))
-	(setf (continuation-asserted-type cont)
-	      (values-type-union ctype (continuation-asserted-type cont)))))
-  (ir1-convert start cont value))
-
-
-;;; Truly-The IR1 convert  --  Internal
-;;;
-;;;    Since the Continuation-Derive-Type is computed as the union of its
-;;; uses's types, setting it won't work.  Instead we must intersect the type
-;;; with the uses's Derived-Type.
-;;;
-(def-ir1-translator truly-the ((type value) start cont)
-  "Truly-The Type Value
-  Like the THE special form, except that it believes whatever you tell it.  It
-  will never generate a type check, but will cause a warning if the compiler
-  can prove the assertion is wrong."
-  (let ((type (specifier-type type)))
-    (ir1-convert start cont value)
-    (do-uses (use cont)
-      (derive-node-type use type))))
-
-
-;;;; Setq
-;;;
-;;;    If there is a definition in *venv*, just set that, otherwise
-;;; look at the global information.  If the name is for a constant, then
-;;; error out.
-
-(def-ir1-translator setq ((&rest things &whole source) start cont)
-  (let ((len (length things)))
-    (when (oddp len)
-      (compiler-error "Odd number of args to SETQ: ~S." source))
-    (if (= len 2)
-	(let* ((name (first things))
-	       (leaf (or (cdr (assoc name *venv*))
-			 (find-free-variable name))))
-	  (when (or (constant-p leaf)
-		    (and (global-var-p leaf)
-			 (eq (global-var-kind leaf) :constant)))
-	    (compiler-error "Attempt to set constant ~S." name))
-	  (when (and (lambda-var-p leaf)
-		     (lambda-var-ignorep leaf))
-	    (compiler-warning "Setting an ignored variable: ~S." name))
-	  (set-variable start cont leaf (second things) source))
-	(collect ((sets))
-	  (do ((thing things (cddr thing)))
-	      ((endp thing)
-	       (ir1-convert-progn-body start cont (sets)))
-	    (sets `(setq ,(first thing) ,(second thing))))))))
-
-;;;; Catch, Throw and Unwind-Protect:
-;;;
-
-;;; Throw  --  Public
-;;;
-;;;    Although throw could be a macro, it seems this would cause unnecessary
-;;; confusion.  We turn THROW into a multiple-value-call of a magical function,
-;;; since as as far as IR1 is concerned, it has no interesting properties other
-;;; than receiving multiple-values.
-;;;
-(def-ir1-translator throw ((tag result) start cont)
-  "Throw Tag Form
-  Do a non-local exit, return the values of Form from the CATCH whose tag
-  evaluates to the same thing as Tag."
-  (ir1-convert start cont
-	       `(multiple-value-call #'%throw ,tag ,result)))
-
-
-;;; This is a special special form used to instantiate a cleanup as the current
-;;; cleanup within the body.  Kind is a the kind of cleanup to make.  We make
-;;; the Start be Start, then set Block-End-Cleanup and bind *Current-Cleanup*.
-;;;
-(def-ir1-translator %within-cleanup ((kind &body body) start cont)
-  (let* ((cleanup (make-cleanup :kind kind  :start start))
-	 (*current-cleanup* cleanup))
-    (setf (block-end-cleanup (continuation-block start)) cleanup)
-    (ir1-convert-progn-body start cont body)))
-
-;;; This is a special special form that makes an "escape function" which
-;;; returns unknown values from named block.  We convert the function, set its
-;;; kind to :Escape, and then reference it.  The :Escape kind indicates that
-;;; this function's purpose is to represent a non-local control transfer, and
-;;; that it might not actually have to be compiled.
-;;;
-;;; Note that environment analysis replaces references to escape functions
-;;; with references to the corresponding NLX-Info structure.
-;;;
-(def-ir1-translator %escape-function ((tag) start cont)
-  (let ((fun (ir1-convert-lambda
-	      `(lambda ()
-		 (return-from ,tag (%unknown-values))))))
-    (setf (functional-kind fun) :escape)
-    (reference-leaf start cont fun nil)))
-
-;;; Yet another special special form.  This one looks up a local function and
-;;; smashes it to a :Cleanup function, as well as referencing it.
-;;;
-(def-ir1-translator %cleanup-function ((name) start cont)
-  (let ((fun (cdr (assoc name *fenv*))))
-    (assert (lambda-p fun))
-    (setf (functional-kind fun) :cleanup)
-    (reference-leaf start cont fun nil)))
-
-
-;;; Catch  --  Public
-;;;
-;;;    Catch could be a macro, but it's somewhat tasteless to expand into
-;;; implementation-dependent special forms.
-;;;
-;;;    We represent the possibility of the control transfer by making an
-;;; "escape function" that does a lexical exit, and instantiate the cleanup
-;;; using %within-cleanup.  It is crucial that %Within-Cleanup immediately
-;;; follows the %Catch call so that the Cleanup-Start's Use will be the
-;;; combination node for the %Catch.
-;;;
-(def-ir1-translator catch ((tag &body body) start cont)
-  "Catch Tag Form*
-  Evaluates Tag and instantiates it as a catcher while the body forms are
-  evaluated in an implicit PROGN.  If a THROW is done to Tag within the dynamic
-  scope of the body, then control will be transferred to the end of the body
-  and the thrown values will be returned."
-  (ir1-convert
-   start cont
-   (let ((exit-block (gensym)))
-     `(block ,exit-block
-	(%catch (%escape-function ,exit-block) ,tag)
-	(%within-cleanup :catch
-	  ,@body)))))
-
-
-;;; Unwind-Protect  --  Public
-;;;
-;;;    Unwind-Protect is similar to Catch, but more hairy.  We make the cleanup
-;;; forms into a local function so that they can be referenced both in the case
-;;; where we are unwound and in any local exits.  We use %Cleanup-Function on
-;;; this to indicate that reference by %Unwind-Protect isn't "real", and thus
-;;; doesn't cause creation of an XEP.
-;;;
-(def-ir1-translator unwind-protect ((protected &body cleanup) start cont)
-  "Unwind-Protect Protected Cleanup*
-  Evaluate the form Protected, returning its values.  The cleanup forms are
-  evaluated whenever the dynamic scope of the Protected form is exited (either
-  due to normal completion or a non-local exit such as THROW)."
-  (ir1-convert
-   start cont
-   (let ((cleanup-fun (gensym))
-	 (drop-thru-tag (gensym))
-	 (exit-tag (gensym))
-	 (next (gensym))
-	 (start (gensym))
-	 (count (gensym)))
-     `(flet ((,cleanup-fun () ,@cleanup nil))
-	(block ,drop-thru-tag
-	  (multiple-value-bind
-	      (,next ,start ,count)
-	      (block ,exit-tag
-		(%unwind-protect (%escape-function ,exit-tag)
-				 (%cleanup-function ,cleanup-fun))
-		(%within-cleanup :unwind-protect
-				 (return-from ,drop-thru-tag ,protected)))
-	    (,cleanup-fun)
-	    (%continue-unwind ,next ,start ,count)))))))
-
-
-;;;; MV stuff.
-
-;;; If there are arguments, multiple-value-call turns into an MV-Combination.
-;;;
-;;; If there are no arguments, then we convert to a normal combination,
-;;; ensuring that a MV-Combination always has at least one argument.  This can
-;;; be regarded as an optimization, but it is more important for simplifying
-;;; compilation of MV-Combinations.
-;;;
-(def-ir1-translator multiple-value-call ((fun &rest args &whole source)
-					 start cont)
-  (let* ((fun-cont (make-continuation))
-	 (node (if args
-		   (make-mv-combination source fun-cont)
-		   (make-combination source fun-cont))))
-    (ir1-convert start fun-cont fun)
-    (setf (continuation-dest fun-cont) node)
-    (assert-continuation-type fun-cont
-			      (specifier-type '(or function symbol)))
-    (collect ((arg-conts))
-      (let ((this-start fun-cont))
-	(dolist (arg args)
-	  (let ((this-cont (make-continuation node)))
-	    (ir1-convert this-start this-cont arg)
-	    (setq this-start this-cont)
-	    (arg-conts this-cont)))
-	(prev-link node this-start)
-	(use-continuation node cont)
-	(setf (basic-combination-args node) (arg-conts))))))
-
-
-;;; IR1 convert Multiple-Value-Prog1  --  Internal
-;;;
-;;; Multiple-Value-Prog1 is represented implicitly in IR1 by having a the
-;;; result code use result continuation (CONT), but transfer control to the
-;;; evaluation of the body.  In other words, the result continuation isn't
-;;; Immediately-Used-P by the nodes that compute the result.
-;;;
-;;; In order to get the control flow right, we convert the result with a dummy
-;;; result continuation, then convert all the uses of the dummy to be uses of
-;;; CONT.  If a use is an Exit, then we also substitute CONT for the dummy in
-;;; the corresponding Entry node so that they are consistent.  Note that this
-;;; doesn't amount to changing the exit target, since the control destination
-;;; of an exit is determined by the block successor; we are just indicating the
-;;; continuation that the result is delivered to.
-;;;
-;;; We then convert the body, using another dummy continuation in its own block
-;;; as the result.  After we are done converting the body, we move all
-;;; predecessors of the dummy end block to CONT's block.
-;;;
-;;; Note that we both exploit and maintain the invariant that the CONT to an
-;;; IR1 convert method either has no block or starts the block that control
-;;; should transfer to after completion for the form.  Nested MV-Prog1's work
-;;; because during conversion of the result form, we use dummy continuation
-;;; whose block is the true control destination.
-;;;
-(def-ir1-translator multiple-value-prog1 ((result &rest forms) start cont)
-  (continuation-starts-block cont)
-  (let* ((dummy-result (make-continuation))
-	 (dummy-start (make-continuation))
-	 (cont-block (continuation-block cont)))
-    (continuation-starts-block dummy-start)
-    (ir1-convert start dummy-start result)
-
-    (substitute-continuation-uses cont dummy-start)
-
-    (continuation-starts-block dummy-result)
-    (ir1-convert-progn-body dummy-start dummy-result forms)
-    (let ((end-block (continuation-block dummy-result)))
-      (dolist (pred (block-pred end-block))
-	(unlink-blocks pred end-block)
-	(link-blocks pred cont-block))
-      (assert (not (continuation-dest dummy-result)))
-      (delete-continuation dummy-result)
-      (remove-from-dfo end-block))))
-
-
-;;;; Interface to defining macros:
-;;;
-;;;    DEFMACRO, DEFUN and DEFCONSTANT expand into calls to %DEFxxx functions
-;;; so that we get a chance to see what is going on.  We define IR1 translators
-;;; for these functions which look at the definition and then generate a call
-;;; to the %%DEFxxx function. 
-;;;
-
-;;; Warn about incompatible or illegal definitions and add the macro to the
-;;; compiler environment.  
-;;;
-;;; Someday we could check for macro arguments being incompatibly redefined.
-;;; Doing this right will involve finding the old macro lambda-list and
-;;; comparing it with the new one.  We don't want to use min-args and max-args
-;;; since they don't completely describe the macro's syntax.
-;;;
-(def-ir1-translator %defmacro ((name def lambda-list doc) start cont
-			       :kind :function)
-  (let ((name (eval name))
-	(def (second def))) ; Don't want to make a function just yet...
-    (unless (symbolp name)
-      (compiler-error "Macro name is not a symbol: ~S." name))
-
-    (force-output)
-    (ecase (info function kind name)
-      ((nil))
-      (:function
-       (remhash name *free-functions*)
-       (compiler-warning
-	"Defining ~S to be a macro when it was ~(~A~) to be a function."
-	name (info function where-from name)))
-      (:macro)
-      (:special-form
-       (compiler-error "Attempt to redefine special form ~S as a macro."
-		       name)))
-
-    (setf (info function kind name) :macro)
-    (setf (info function where-from name) :defined)
-
-    (when *compile-time-define-macros*
-      (setf (info function macro-function name)
-	    #+new-compiler (coerce def 'function)
-	    #-new-compiler def))
-
-    (let ((fun (ir1-convert-lambda def)))
-      (setf (leaf-name fun)
-	    (concatenate 'string "DEFMACRO " (symbol-name name)))
-      (setf (functional-arg-documentation fun) (eval lambda-list))
-
-      (ir1-convert start cont `(%%defmacro ',name ,fun ,doc)))
-
-    (compiler-mumble "Converted ~S.~%" name)))
-
-;;;
-;;; Convert the definition and substitute for previous global uses.  We only
-;;; do the substitution if the function is in the null environment, ensuring
-;;; that the function cannot be called outside of the correct environment.
-;;; Emit top-level code to install the definition.
-;;;
-(def-ir1-translator %defun ((name def doc source) start cont
-			    :kind :function)
-  (let* ((name (define-function-name (eval name)))
-	 (expansion
-	  (if (and (member (info function inlinep name)
-			   '(:inline :maybe-inline))
-		   (in-null-environment))
-	      (cadr def) nil)))
-    (setf (info function where-from name) :defined)
-    (setf (info function inline-expansion name) expansion)
-    ;;
-    ;; If there is a previous defun for the same name, disown the leaf for it.
-    (let ((old (gethash name *free-functions*)))
-      (when (functional-p old) (remhash name *free-functions*)))
-
-    (let ((fun (ir1-convert-lambda (cadr def) (cadr source)))
-	  (new (gethash name *free-functions*))
-	  (info (info function info name)))
-      (setf (leaf-name fun) name)
-      (cond ((and (in-null-environment t)
-		  (not (eq (info function inlinep name) :notinline))
-		  (or (not info)
-		      (and (null (function-info-transforms info))
-			   (null (function-info-templates info))
-			   (not (function-info-ir2-convert info)))))
-	     (setf (gethash name *free-functions*) fun)
-	     (when new (substitute-leaf fun new)))
-	    (t
-	     (let ((var (find-free-function name "in a strange place")))
-	       (setf (leaf-where-from var) :defined))))
-
-      (ir1-convert start cont
-		   `(%%defun ',name ,fun ,doc
-			     ,@(when expansion `(',expansion))))
-      (compiler-mumble "Converted ~S.~%" name))))
-
-
-;;; Update the global environment to correspond to the new definition.  We only
-;;; record a constant-value when the value is obviously constant.  We can have
-;;; an optimizer for %%Defconstant that notices when the value becomes constant
-;;; and substitutes for the Global-Var structure.
-;;;
-(def-ir1-translator %defconstant ((name value doc) start cont
-				  :kind :function)
-  (let ((name (eval name)))
-    (unless (symbolp name)
-      (compiler-error "Constant name is not a symbol: ~S." name))
-
-    (setf (info variable kind name) :constant)
-    (setf (info variable where-from name) :defined)
-
-    (when (and (constantp value) (not (symbolp value)))
-      (setf (info variable constant-value name) (eval value)))
-    (remhash name *free-variables*))
-
-  (ir1-convert start cont `(%%defconstant ,name ,value ,doc)))
diff --git a/compiler/ir1util.lisp b/compiler/ir1util.lisp
deleted file mode 100644
index 7c223b179edd48c36ac0fec0bd00ea91e113e1cc..0000000000000000000000000000000000000000
--- a/compiler/ir1util.lisp
+++ /dev/null
@@ -1,1472 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    This file contains random utilities used for manipulating the IR1
-;;; representation.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-
-;;;; Cleanup hackery:
-
-;;; Find-Enclosing-Cleanup  --  Interface
-;;;
-;;;    Chain up the Lambda-Cleanup thread until we find a Cleanup or null.
-;;;
-(defun find-enclosing-cleanup (thing)
-  (declare (type (or cleanup clambda null) thing))
-  (etypecase thing
-    ((or cleanup null) thing)
-    (clambda (find-enclosing-cleanup (lambda-cleanup thing)))))
-
-
-;;; Insert-Cleanup-Code  --  Interface
-;;;
-;;;    Convert the Form in a block inserted between Block1 and Block2 as an
-;;; implicit MV-Prog1.  The inserted block is returned.  Node is used for IR1
-;;; context when converting the form.  Note that the block is not assigned a
-;;; number, and is linked into the DFO at the beginning.  We indicate that we
-;;; have trashed the DFO by setting Component-Reanalyze.
-;;;
-(defun insert-cleanup-code (block1 block2 node form)
-  (declare (type cblock block1 block2) (type node node))
-  (with-ir1-environment node
-    (setf (component-reanalyze *current-component*) t)
-    (let* ((start (make-continuation))
-	   (block (continuation-starts-block start))
-	   (cont (make-continuation)))
-      (change-block-successor block1 block2 block)
-      (link-blocks block block2)
-      (ir1-convert start cont form)
-      (setf (block-last block) (continuation-use cont))
-      block)))
-  
-
-;;;; Continuation use hacking:
-
-;;; Find-Uses  --  Interface
-;;;
-;;;    Return a list of all the nodes which use Cont.
-;;;
-(proclaim '(function find-uses (continuation) list))
-(defun find-uses (cont)
-  (ecase (continuation-kind cont)
-    ((:block-start :deleted-block-start)
-     (block-start-uses (continuation-block cont)))
-    (:inside-block (list (continuation-use cont)))
-    (:unused nil)))
-
-      
-;;; Delete-Continuation-Use  --  Interface
-;;;
-;;;    Update continuation use information so that Node is no longer a use of
-;;; its Cont.  If the old continuation doesn't start its block, then we don't
-;;; update the Block-Start-Uses, since it will be deleted when we are done.
-;;;
-;;; Note: if you call this function, you may have to do a
-;;; REOPTIMIZE-CONTINUATION to inform IR1 optimization that something has
-;;; changed.
-;;;
-(proclaim '(function delete-continuation-use (node) void))
-(defun delete-continuation-use (node)
-  (let* ((cont (node-cont node))
-	 (block (continuation-block cont)))
-    (ecase (continuation-kind cont)
-      (:deleted)
-      ((:block-start :deleted-block-start)
-       (let ((uses (delete node (block-start-uses block))))
-	 (setf (block-start-uses block) uses)
-	 (setf (continuation-use cont)
-	       (if (cdr uses) nil (car uses)))))
-      (:inside-block
-       (setf (continuation-kind cont) :unused)
-       (setf (continuation-block cont) nil)
-       (setf (continuation-use cont) nil)
-       (setf (continuation-next cont) nil)))
-    (setf (node-cont node) nil)))
-
-
-;;; Add-Continuation-Use  --  Interface
-;;;
-;;;    Update continuation use information so that Node uses Cont.  If Cont is
-;;; :Unused, then we set its block to Node's Node-Block (which must be set.)
-;;;
-;;; Note: if you call this function, you may have to do a
-;;; REOPTIMIZE-CONTINUATION to inform IR1 optimization that something has
-;;; changed.
-;;;
-(proclaim '(function add-continuation-use (node continuation) void))
-(defun add-continuation-use (node cont)
-  (assert (not (node-cont node)))
-  (let ((block (continuation-block cont)))
-    (ecase (continuation-kind cont)
-      (:deleted)
-      (:unused
-       (assert (not block))
-       (let ((block (node-block node)))
-	 (assert block)
-	 (setf (continuation-block cont) block))
-       (setf (continuation-kind cont) :inside-block)
-       (setf (continuation-use cont) node))
-      ((:block-start :deleted-block-start)
-       (let ((uses (cons node (block-start-uses block))))
-	 (setf (block-start-uses block) uses)
-	 (setf (continuation-use cont)
-	       (if (cdr uses) nil (car uses)))))))
-  (setf (node-cont node) cont))
-
-
-;;; Immediately-Used-P  --  Interface
-;;;
-;;;    Return true if Cont is the Node-Cont for Node and Cont is transferred to
-;;; immediately after the evaluation of Node.
-;;;
-(defun immediately-used-p (cont node)
-  (declare (type continuation cont) (type node node))
-  (and (eq (node-cont node) cont)
-       (not (eq (continuation-kind cont) :deleted))
-       (let ((cblock (continuation-block cont))
-	     (nblock (node-block node)))
-	 (or (eq cblock nblock)
-	     (let ((succ (block-succ nblock)))
-	       (and (= (length succ) 1)
-		    (eq (first succ) cblock)))))))
-
-
-;;;; Continuation substitution:
-
-;;; Substitute-Continuation  --  Interface
-;;;
-;;;    In Old's Dest, replace Old with New.  New's Dest must initially be NIL.
-;;; When we are done, we call Flush-Dest on Old to clear its Dest and to note
-;;; potential optimization opportunities.
-;;;
-(defun substitute-continuation (new old)
-  (declare (type continuation old new))
-  (assert (not (continuation-dest new)))
-  (let ((dest (continuation-dest old)))
-    (etypecase dest
-      ((or ref bind))
-      (cif (setf (if-test dest) new))
-      (cset (setf (set-value dest) new))
-      (creturn (setf (return-result dest) new))
-      (exit (setf (exit-value dest) new))
-      (basic-combination
-       (if (eq old (basic-combination-fun dest))
-	   (setf (basic-combination-fun dest) new)
-	   (setf (basic-combination-args dest)
-		 (nsubst new old (basic-combination-args dest))))))
-
-    (flush-dest old)
-    (setf (continuation-dest new) dest))
-  (undefined-value))
-
-
-;;; Ensure-Block-Start  --  Interface
-;;;
-;;;    Ensure that Cont is the start of a block (or deleted) so that the use
-;;; set can be freely manipulated.
-;;; -- If the continuation is :Unused or is :Inside-Block and the Cont of Last
-;;;    in its block, then we make it the start of a new deleted block.
-;;; -- If the continuation is :Inside-Block inside a block, then we split the
-;;;    block using Node-Ends-Block, which makes the continuation be a
-;;;    :Block-Start.
-;;;
-(defun ensure-block-start (cont)
-  (declare (type continuation cont))
-  (let ((kind (continuation-kind cont)))
-    (ecase kind
-      ((:deleted :block-start :deleted-block-start))
-      ((:unused :inside-block)
-       (let ((block (continuation-block cont)))
-	 (cond ((or (eq kind :unused)
-		    (eq (node-cont (block-last block)) cont))
-		(setf (continuation-block cont)
-		      (make-block-key :start cont :lambda nil
-				      :start-cleanup nil :end-cleanup nil
-				      :component nil))
-		(setf (continuation-kind cont) :deleted-block-start))
-	       (t
-		(node-ends-block (continuation-use cont))))))))
-  (undefined-value))
-
-
-;;; Substitute-Continuation-Uses  --  Interface
-;;;
-;;;    Replace all uses of Old with uses of New, where New has an arbitary
-;;; number of uses.  If a use is an Exit, then we also substitute New for Old
-;;; in the Entry's Exits to maintain consistency between the two.
-;;;
-;;;    If New will end up with more than one use, then we must arrange for it
-;;; to start a block if it doesn't already.
-;;;
-(defun substitute-continuation-uses (new old)
-  (declare (type continuation old new))
-  (unless (and (eq (continuation-kind new) :unused)
-	       (eq (continuation-kind old) :inside-block))
-    (ensure-block-start new))
-  
-  (do-uses (node old)
-    (when (exit-p node)
-      (let ((entry (exit-entry node)))
-	(when entry
-	  (setf (entry-exits entry)
-		(nsubst new old (entry-exits entry))))))
-    (delete-continuation-use node)
-    (add-continuation-use node new))
-
-  (reoptimize-continuation new)
-  (undefined-value))
-
-#|
-;;; Substitute-Node-Cont  --  Interface
-;;;
-;;;    Replace Old's single use with a use of New.  This is used in contexts
-;;; where we know that New has no use and Old has a single use.
-;;;
-(defun substitute-node-cont (new old)
-  (declare (type continuation new old))
-  (assert (member (continuation-kind new) '(:block-start :unused)))
-  (assert (eq (continuation-kind old) :inside-block))
-
-  (let ((use (continuation-use old)))
-    (delete-continuation-use use)
-    (add-continuation-use use new))
-
-  (undefined-value))
-|#
-
-
-;;; NODE-BLOCK, NODE-ENVIRONMENT, NODE-TLF-NUMBER  --  Interface
-;;;
-;;;    Shorthand for common idiom.
-;;;
-(proclaim '(inline node-block node-environment node-tlf-number))
-(defun node-block (node)
-  (declare (type node node))
-  (the cblock (continuation-block (node-prev node))))
-;;;
-(defun node-environment (node)
-  (declare (type node node))
-  (the environment (lambda-environment (block-lambda (node-block node)))))
-;;;
-(defun node-tlf-number (node)
-  (declare (type node node))
-  (car (last (node-source-path node))))
-
-
-;;;; Flow/DFO/Component hackery:
-
-;;; Link-Blocks, Unlink-Blocks  --  Interface
-;;;
-;;;    Join or separate Block1 and Block2.
-;;;
-(proclaim '(ftype (function (block block) void) link-blocks unlink-blocks))
-(defun link-blocks (block1 block2)
-  (assert (not (member block2 (block-succ block1))))
-  (push block2 (block-succ block1))
-  (push block1 (block-pred block2)))
-;;;
-(defun unlink-blocks (block1 block2)
-  (assert (member block2 (block-succ block1)))
-  (setf (block-succ block1)
-	(delete block2 (block-succ block1)))
-  (setf (block-pred block2)
-	(delete block1 (block-pred block2))))
-
-
-;;; Change-Block-Successor  --  Internal
-;;;
-;;;    Swing the succ/pred link between Block and Old to be between Block and
-;;; New.  If Block ends in an IF, then we have to fix up the
-;;; consequent/alternative blocks to point to New.
-;;;
-(defun change-block-successor (block old new)
-  (declare (type cblock new old block))
-  (unlink-blocks block old)
-  (unless (member new (block-succ block))
-    (link-blocks block new))
-  
-  (let ((last (block-last block)))
-    (when (if-p last)
-      (macrolet ((frob (slot)
-		   `(when (eq (,slot last) old)
-		      (setf (,slot last) new))))
-	(frob if-consequent)
-	(frob if-alternative))))
-  
-  (undefined-value))
-
-
-;;; Remove-From-DFO  --  Interface
-;;;
-;;;    Unlink a block from the next/prev chain.  We also null out the
-;;; Component.
-;;;
-(proclaim '(function remove-from-dfo (cblock) void))
-(defun remove-from-dfo (block)
-  (let ((next (block-next block))
-	(prev (block-prev block)))
-    (setf (block-component block) nil)
-    (setf (block-next prev) next)
-    (setf (block-prev next) prev)))
-
-;;; Add-To-DFO  --  Interface
-;;;
-;;;    Add Block to the next/prev chain following After.  We also set the
-;;; Component to be the same as for After.
-;;;
-(proclaim '(function add-to-dfo (block block) void))
-(defun add-to-dfo (block after)
-  (let ((next (block-next after)))
-    (setf (block-component block) (block-component after))
-    (setf (block-next after) block)
-    (setf (block-prev block) after)
-    (setf (block-next block) next)
-    (setf (block-prev next) block)))
-
-
-;;; Clear-Flags  --  Interface
-;;;
-;;;    Set the Flag for all the blocks in Component to NIL, except for the head
-;;; and tail which are set to T.
-;;;
-(proclaim '(function clear-flags (component) void))
-(defun clear-flags (component)
-  (let ((head (component-head component))
-	(tail (component-tail component)))
-    (setf (block-flag head) t)
-    (setf (block-flag tail) t)
-    (do-blocks (block component)
-      (setf (block-flag block) nil))))
-
-
-;;; Make-Empty-Component  --  Interface
-;;;
-;;;    Make a component with no blocks in it.  The Block-Flag is initially true
-;;; in the head and tail blocks.
-;;;
-(proclaim '(function make-empty-component () component))
-(defun make-empty-component ()
-  (let* ((head (make-block-key :start nil :lambda nil :start-cleanup nil
-			       :end-cleanup nil :component nil))
-	 (tail (make-block-key :start nil :lambda nil :start-cleanup nil
-			       :end-cleanup nil :component nil))
-	 (res (make-component :head head  :tail tail)))
-    (setf (block-flag head) t)
-    (setf (block-flag tail) t)
-    (setf (block-component head) res)
-    (setf (block-component tail) res)
-    (setf (block-next head) tail)
-    (setf (block-prev tail) head)
-    res))
-
-
-;;; Node-Ends-Block  --  Interface
-;;;
-;;;    Makes Node the Last node in its block, splitting the block if necessary.
-;;;
-;;;    If the mess-up for one of Block's End-Cleanups is moved into the new
-;;; block, then we must adjust the end/start cleanups of the new and old blocks
-;;; to reflect the movement of the mess-up.  If any of the old end cleanups
-;;; were in the new block, then we scan up from that cleanup trying to find one
-;;; that isn't.  When we do, that becomes the new start/end cleanup of the
-;;; old/new block.  We set the start/end as a pair, since we don't want anyone
-;;; to think that a cleanup is necessary.
-;;;
-(defun node-ends-block (node)
-  (declare (type node node))
-  (let* ((block (node-block node))
-	 (start (node-cont node))
-	 (last (block-last block))
-	 (last-cont (node-cont last)))
-    (unless (eq last node)
-      (assert (eq (continuation-kind start) :inside-block))
-      (let* ((succ (block-succ block))
-	     (cleanup (block-end-cleanup block))
-	     (new-block
-	      (make-block-key :start start
-			      :lambda (block-lambda block)
-			      :start-cleanup cleanup
-			      :end-cleanup cleanup
-			      :component (block-component block)
-			      :start-uses (list (continuation-use start))
-			      :succ succ :last last)))
-	(setf (continuation-kind start) :block-start)
-	(dolist (b succ)
-	  (setf (block-pred b)
-		(cons new-block (remove block (block-pred b)))))
-	(setf (block-succ block) ())
-	(setf (block-last block) node)
-	(link-blocks block new-block)
-	(add-to-dfo new-block block)
-	
-	(do ((cont start (node-cont (continuation-next cont))))
-	    ((eq cont last-cont)
-	     (when (eq (continuation-kind last-cont) :inside-block)
-	       (setf (continuation-block last-cont) new-block)))
-	  (setf (continuation-block cont) new-block))
-
-	(let ((start-cleanup (block-start-cleanup block)))
-	  (do ((cup (find-enclosing-cleanup cleanup)
-		    (find-enclosing-cleanup (cleanup-enclosing cup))))
-	      ((null cup))
-	    (when (eq (node-block (continuation-use (cleanup-start cup)))
-		      new-block)
-	      (do ((cup (find-enclosing-cleanup (cleanup-enclosing cup))
-			(find-enclosing-cleanup (cleanup-enclosing cup))))
-		  ((null cup)
-		   (setf (block-end-cleanup block) start-cleanup)
-		   (setf (block-start-cleanup new-block) start-cleanup))
-		(let ((cb (node-block (continuation-use (cleanup-start cup)))))
-		  (unless (eq cb new-block)
-		    (setf (block-end-cleanup block) cup)
-		    (setf (block-start-cleanup new-block) cup)
-		    (return))))
-	      (return))))
-
-	(setf (block-type-asserted block) t)
-	(setf (block-test-modified block) t))))
-
-  (undefined-value))
-
-
-;;;; Deleting stuff:
-
-;;; Delete-Lambda-Var  --  Internal
-;;;
-;;;    Deal with deleting the last (read) reference to a lambda-var.  We
-;;; iterate over all local calls flushing the corresponding argument, allowing
-;;; the computation of the argument to be deleted.
-;;;
-;;;    The lambda-var may still have some sets, but this doesn't cause too much
-;;; difficulty, since we can efficiently implement write-only variables.  We
-;;; iterate over the sets, marking their blocks for dead code flushing, since
-;;; we can delete sets whose value is unused.
-;;;
-(defun delete-lambda-var (leaf)
-  (declare (type lambda-var leaf))
-  (let* ((fun (lambda-var-home leaf))
-	 (n (position leaf (lambda-vars fun))))
-    (dolist (ref (leaf-refs fun))
-      (let* ((cont (node-cont ref))
-	     (dest (continuation-dest cont)))
-	(when (and (combination-p dest)
-		   (eq (basic-combination-fun dest) cont)
-		   (eq (basic-combination-kind dest) :local))
-	  (let ((args (basic-combination-args dest)))
-	    (flush-dest (elt args n))
-	    (setf (elt args n) nil))))))
-
-  (dolist (set (lambda-var-sets leaf))
-    (setf (block-flush-p (node-block set)) t))
-
-  (undefined-value))
-
-
-;;; Delete-Lambda  --  Internal
-;;;
-;;;    Deal with deleting the last reference to a lambda.  Since there is only
-;;; one way into a lambda, deleting the last reference to a lambda ensures that
-;;; there is no way to reach any of the code in it.  So we just set the
-;;; Functional-Kind for Fun and its Lets to :Deleted, causing IR1 optimization
-;;; to delete blocks in that lambda.
-;;;
-;;;    If the function isn't a Let, we unlink the function head and tail from
-;;; the component head and tail to indicate that the code is unreachable.  We
-;;; also delete the function Component-Lambdas (it won't be there before local
-;;; call analysis, but no matter.)
-;;;
-;;;    If the lambda is an XEP, then we null out the Entry-Function in its
-;;; Entry-Function so that people will know that it is not an entry point
-;;; anymore.
-;;;
-(defun delete-lambda (leaf)
-  (declare (type clambda leaf))
-  (let ((kind (functional-kind leaf)))
-    (assert (not (member kind '(:deleted :optional :top-level))))
-    (setf (functional-kind leaf) :deleted)
-    (dolist (let (lambda-lets leaf))
-      (setf (functional-kind let) :deleted))
-
-    (if (or (eq kind :let) (eq kind :mv-let))
-	(let ((home (lambda-home leaf)))
-	  (setf (lambda-lets home) (delete leaf (lambda-lets home))))
-	(let* ((bind-block (node-block (lambda-bind leaf)))
-	       (component (block-component bind-block))
-	       (return (lambda-return leaf)))
-	  (unlink-blocks (component-head component) bind-block)
-	  (when return
-	    (unlink-blocks (node-block return) (component-tail component)))
-	  (setf (component-lambdas component)
-		(delete leaf (component-lambdas component)))))
-
-    (when (eq kind :external)
-      (let ((fun (functional-entry-function leaf)))
-	(setf (functional-entry-function fun) nil)
-	(when (optional-dispatch-p fun)
-	  (delete-optional-dispatch fun)))))
-
-  (undefined-value))
-
-
-;;; Delete-Optional-Dispatch  --  Internal
-;;;
-;;;    Deal with deleting the last reference to an Optional-Dispatch.  We have
-;;; to be a bit more careful than with lambdas, since Delete-Ref is used both
-;;; before and after local call analysis.  Afterward, all references to
-;;; still-existing optional-dispatches have been moved to the XEP, leaving it
-;;; with no references at all.  So we look at the XEP to see if an
-;;; optional-dispatch is still really being used.  But before local call
-;;; analysis, there are no XEPs, and all references are direct.
-;;;
-;;;    When we do delete the optional-dispatch, we grovel all of its
-;;; entry-points, making them be normal lambdas, and then deleting the ones
-;;; with no references.  This deletes any e-p lambdas that were either never
-;;; referenced, or couldn't be deleted when the last deference was deleted (due
-;;; to their :Optional kind.)
-;;;
-;;; Note that the last optional ep may alias the main entry, so when we process
-;;; the main entry, its kind may have been changed to NIL or even converted to
-;;; a let.
-;;;
-(defun delete-optional-dispatch (leaf)
-  (declare (type optional-dispatch leaf))
-  (let ((entry (functional-entry-function leaf)))
-    (unless (and entry (leaf-refs entry))
-      (assert (or (not entry) (eq (functional-kind entry) :deleted)))
-      (setf (functional-kind leaf) :deleted)
-
-      (flet ((frob (fun)
-	       (unless (eq (functional-kind fun) :deleted)
-		 (assert (eq (functional-kind fun) :optional))
-		 (setf (functional-kind fun) nil)
-		 (let ((refs (leaf-refs fun)))
-		   (cond ((null refs)
-			  (delete-lambda fun))
-			 ((null (rest refs))
-			  (maybe-let-convert fun)))))))
-	
-	(dolist (ep (optional-dispatch-entry-points leaf))
-	  (frob ep))
-	(when (optional-dispatch-more-entry leaf)
-	  (frob (optional-dispatch-more-entry leaf)))
-	(let ((main (optional-dispatch-main-entry leaf)))
-	  (when (eq (functional-kind main) :optional)
-	    (frob main))))))
-
-  (undefined-value))
-
-
-;;; Delete-Ref  --  Interface
-;;;
-;;;    Do stuff to delete the semantic attachments of a Ref node.  When this
-;;; leaves zero or one reference, we do a type dispatch off of the leaf to
-;;; determine if a special action is appropriate.
-;;;
-(defun delete-ref (ref)
-  (declare (type ref ref))
-  (let* ((leaf (ref-leaf ref))
-	 (refs (delete ref (leaf-refs leaf))))
-    (setf (leaf-refs leaf) refs)
-    
-    (cond ((null refs)
-	   (typecase leaf
-	     (lambda-var (delete-lambda-var leaf))
-	     (clambda
-	      (ecase (functional-kind leaf)
-		((nil :external :let :mv-let :escape :cleanup)
-		 (delete-lambda leaf))
-		((:deleted :optional))))
-	     (optional-dispatch
-	      (unless (eq (functional-kind leaf) :deleted)
-		(delete-optional-dispatch leaf)))))
-	  ((null (rest refs))
-	   (typecase leaf
-	     (clambda (maybe-let-convert leaf))))))
-
-  (undefined-value))
-
-
-;;; Delete-Return  --  Interface
-;;;
-;;;    Do stuff to indicate that the return node Node is being deleted.
-;;;
-(defun delete-return (node)
-  (declare (type creturn node))
-  (let* ((fun (return-lambda node))
-	 (tail-set (lambda-tail-set fun)))
-    (assert (lambda-return fun))
-    (setf (tail-set-functions tail-set)
-	  (delete fun (tail-set-functions tail-set)))
-    (setf (lambda-tail-set fun) nil)
-    (setf (lambda-return fun) nil))
-  (undefined-value))
-
-
-;;; Flush-Dest  --  Interface
-;;;
-;;;    This function is called by people who delete nodes; it provides a way to
-;;; indicate that the value of a continuation is no longer used.  We null out
-;;; the Continuation-Dest, set Block-Flush-P in the blocks containing uses of
-;;; Cont and set Component-Reoptimize.
-;;;
-;;;    If the continuation is :Deleted, then we don't do anything, since all
-;;; semantics have already been flushed.  If the continuation is a
-;;; :Deleted-Block-Start, then we delete the continuation, since its control
-;;; semantics have already been deleted.  Deleting the continuation causes its
-;;; uses to be reoptimized.  If the Prev of the use is deleted, then we blow
-;;; off reoptimization.
-;;;
-(defun flush-dest (cont)
-  (declare (type continuation cont))
-  
-  (ecase (continuation-kind cont)
-    (:deleted)
-    (:deleted-block-start
-     (assert (continuation-dest cont))
-     (setf (continuation-dest cont) nil)
-     (delete-continuation cont))
-    ((:inside-block :block-start)
-     (assert (continuation-dest cont))
-     (setf (continuation-dest cont) nil)
-     (setf (component-reoptimize (block-component (continuation-block cont)))
-	   t)
-     (do-uses (use cont)
-       (let ((prev (node-prev use)))
-	 (unless (eq (continuation-kind prev) :deleted)
-	   (let ((block (continuation-block prev)))
-	     (setf (block-flush-p block) t)
-	     (setf (block-type-asserted block) t)))))))
-
-  (setf (continuation-%type-check cont) nil)
-  
-  (undefined-value))
-
-
-;;; MARK-FOR-DELETION  --  Internal
-;;;
-;;;    Do a graph walk backward from Block, marking all predecessor blocks with
-;;; the DELETE-P flag.
-;;;
-(defun mark-for-deletion (block)
-  (declare (type cblock block))
-  (unless (block-delete-p block)
-    (setf (block-delete-p block) t)
-    (dolist (pred (block-pred block))
-      (mark-for-deletion pred)))
-  (undefined-value))
-
-
-;;; DELETE-CONTINUATION  --  Interface
-;;;
-;;;    Delete Cont, eliminating both control and value semantics.  We set
-;;; FLUSH-P and COMPONENT-REOPTIMIZE similarly to in FLUSH-DEST.  Here we must
-;;; get the component from the use block, since the continuation may be a
-;;; :DELETED-BLOCK-START.
-;;;
-;;;    If Cont has DEST, then it must be the case that the DEST is unreachable,
-;;; since we can't compute the value desired.  In this case, we call
-;;; MARK-FOR-DELETION to cause the DEST block and its predecessors to tell
-;;; people to ignore them, and to cause them to be deleted eventually.
-;;;
-(defun delete-continuation (cont)
-  (declare (type continuation cont))
-  (assert (not (eq (continuation-kind cont) :deleted)))
-  
-  (do-uses (use cont)
-    (let ((prev (node-prev use)))
-      (unless (eq (continuation-kind prev) :deleted)
-	(let ((block (continuation-block prev)))
-	  (setf (block-flush-p block) t)
-	  (setf (block-type-asserted block) t)
-	  (setf (component-reoptimize (block-component block)) t)))))
-
-  (let ((dest (continuation-dest cont)))
-    (when dest
-      (let ((block (node-block dest)))
-	(unless (block-delete-p block)
-	  (mark-for-deletion block)))))
-  
-  (setf (continuation-kind cont) :deleted)
-  (setf (continuation-dest cont) nil)
-  (setf (continuation-next cont) nil)
-  (setf (continuation-asserted-type cont) *empty-type*)
-  (setf (continuation-%derived-type cont) *empty-type*)
-  (setf (continuation-use cont) nil)
-  (setf (continuation-block cont) nil)
-  (setf (continuation-reoptimize cont) nil)
-  (setf (continuation-%type-check cont) nil)
-  (setf (continuation-info cont) nil)
-  
-  (undefined-value))
-
-
-;;; Delete-Block  --  Interface
-;;;
-;;;    This function does what is necessary to eliminate the code in it from
-;;; the IR1 representation.  This involves unlinking it from its predecessors
-;;; and successors and deleting various node-specific semantic information.
-;;;
-;;;    We mark the Start as has having no next and remove the last node from
-;;; its Cont's uses.  We also flush the DEST for all continuations whose values
-;;; are received by nodes in the block.
-;;;
-(defun delete-block (block)
-  (declare (type cblock block))
-  (assert (block-component block) () "Block is already deleted.")
-  (setf (block-delete-p block) t)
-
-  (let* ((last (block-last block))
-	 (cont (node-cont last)))
-    (delete-continuation-use last)
-    (cond ((eq (continuation-kind cont) :unused)
-	   (assert (not (continuation-dest cont)))
-	   (delete-continuation cont))
-	  (t
-	   (reoptimize-continuation cont))))
-
-  (dolist (b (block-pred block))
-    (unlink-blocks b block))
-  (dolist (b (block-succ block))
-    (unlink-blocks block b))
-
-  (do-nodes (node cont block)
-    (typecase node
-      (ref (delete-ref node))
-      (basic-combination
-       (flush-dest (basic-combination-fun node))
-       (dolist (arg (basic-combination-args node))
-	 (when arg (flush-dest arg))))
-      (cif
-       (flush-dest (if-test node)))
-      (bind
-       (let ((lambda (bind-lambda node)))
-	 (unless (eq (functional-kind lambda) :deleted)
-	   (assert (member (functional-kind lambda) '(:let :mv-let)))
-	   (delete-lambda lambda))))
-      (exit
-       (let ((value (exit-value node)))
-	 (when value
-	   (flush-dest value))))
-      (creturn
-       (flush-dest (return-result node))
-       (delete-return node))
-      (cset
-       (flush-dest (set-value node))
-       (let ((var (set-var node)))
-	 (setf (basic-var-sets var)
-	       (delete node (basic-var-sets var))))))
-
-    (delete-continuation (node-prev node)))
-
-  (remove-from-dfo block)
-  (undefined-value))
-
-
-;;; Unlink-Node  --  Interface
-;;;
-;;;    Delete a node from a block, deleting the block if there are no nodes
-;;; left.  We remove the node from the uses of its CONT, but we don't deal with
-;;; cleaning up any type-specific semantic attachments.  If the CONT is :UNUSED
-;;; after deleting this use, then we delete CONT.  (Note :UNUSED is not the
-;;; same as no uses.  A continuation will only become :UNUSED if it was
-;;; :INSIDE-BLOCK before.) 
-;;;
-;;;    If the node is the last node, there must be exactly one successor.  We
-;;; link all of our precedessors to the successor and unlink the block.  In
-;;; this case, we return T, otherwise NIL.  If no nodes are left, and the block
-;;; is a successor of itself, then we replace the only node with a degenerate
-;;; exit node.  This provides a way to represent the bodyless infinite loop,
-;;; given the prohibition on empty blocks in IR1.
-;;;
-(defun unlink-node (node)
-  (declare (type node node))
-  (let* ((cont (node-cont node))
-	 (next (continuation-next cont))
-	 (prev (node-prev node))
-	 (block (continuation-block prev))
-	 (prev-kind (continuation-kind prev))
-	 (last (block-last block)))
-    
-    (unless (eq (continuation-kind cont) :deleted)
-      (delete-continuation-use node)
-      (when (eq (continuation-kind cont) :unused)
-	(assert (not (continuation-dest cont)))
-	(delete-continuation cont)))
-    
-    (setf (block-type-asserted block) t)
-    (setf (block-test-modified block) t)
-
-    (cond ((or (eq prev-kind :inside-block)
-	       (and (eq prev-kind :block-start)
-		    (not (eq node last))))
-	   (cond ((eq node last)
-		  (setf (block-last block) (continuation-use prev))
-		  (setf (continuation-next prev) nil))
-		 (t
-		  (setf (continuation-next prev) next)
-		  (setf (node-prev next) prev)))
-	   (setf (node-prev node) nil)
-	   nil)
-	  (t
-	   (assert (eq prev-kind :block-start))
-	   (assert (eq node last))
-	   (let* ((succ (block-succ block))
-		  (next (first succ)))
-	     (assert (and succ (null (cdr succ))))
-	     (cond
-	      ((member block succ)
-	       (with-ir1-environment node
-		 (let ((exit (make-exit :source (node-source node)))
-		       (dummy (make-continuation)))
-		   (setf (continuation-next prev) nil)
-		   (prev-link exit prev)
-		   (add-continuation-use exit dummy)
-		   (setf (block-last block) exit)))
-	       (setf (node-prev node) nil)
-	       nil)
-	      (t
-	       (assert (eq (find-enclosing-cleanup (block-start-cleanup block))
-			   (find-enclosing-cleanup (block-end-cleanup block))))
-	       (unlink-blocks block next)
-	       (dolist (pred (block-pred block))
-		 (change-block-successor pred block next))
-	       (remove-from-dfo block)
-	       (cond ((continuation-dest prev)
-		      (setf (continuation-next prev) nil)
-		      (setf (continuation-kind prev) :deleted-block-start))
-		     (t
-		      (delete-continuation prev)))
-	       (setf (node-prev node) nil)
-	       t)))))))
-
-
-;;; NODE-DELETED  --  Interface
-;;;
-;;;    Return true if NODE has been deleted, false if it is still a valid part
-;;; of IR1.
-;;;
-(defun node-deleted (node)
-  (declare (type node node))
-  (let ((prev (node-prev node)))
-    (and prev
-	 (not (eq (continuation-kind prev) :deleted))
-	 (let ((block (continuation-block prev)))
-	   (and (block-component block)
-		(not (block-delete-p block)))))))
-  
-
-;;;; Leaf hackery:
-
-;;; Change-Ref-Leaf  --  Interface
-;;;
-;;;    Change the Leaf that a Ref refers to.
-;;;
-(defun change-ref-leaf (ref leaf)
-  (declare (type ref ref) (type leaf leaf))
-  (unless (eq (ref-leaf ref) leaf)
-    (push ref (leaf-refs leaf))
-    (delete-ref ref)
-    (setf (ref-leaf ref) leaf)
-    (derive-node-type ref (leaf-type leaf))
-    (reoptimize-continuation (node-cont ref)))
-  (undefined-value))
-
-
-;;; Substitute-Leaf  --  Interface
-;;;
-;;;    Change all Refs for Old-Leaf to New-Leaf.
-;;;
-(defun substitute-leaf (new-leaf old-leaf)
-  (declare (type leaf new-leaf old-leaf))
-  (dolist (ref (leaf-refs old-leaf))
-    (change-ref-leaf ref new-leaf))
-  (undefined-value))
-
-
-;;; Find-Constant  --  Interface
-;;;
-;;;    Return a Leaf which represents the specified constant object.  If the
-;;; object is not in *constants*, then we create a new constant Leaf and
-;;; enter it.
-;;;
-(defun find-constant (object)
-  (or (gethash object *constants*)
-      (setf (gethash object *constants*)
-	    (make-constant :value object  :name nil
-			   :type (ctype-of object)
-			   :where-from :defined))))
-
-
-;;;; Find-NLX-Info  --  Interface
-;;;
-;;;    If there is a non-local exit noted in Entry's environment that exits to
-;;; Cont in that entry, then return it, otherwise return NIL.
-;;;
-(defun find-nlx-info (entry cont)
-  (declare (type entry entry) (type continuation cont))
-  (dolist (nlx (environment-nlx-info (node-environment entry)) nil)
-    (let* ((cleanup (nlx-info-cleanup nlx))
-	   (entry-cleanup (ecase (cleanup-kind cleanup)
-			    ((:catch :unwind-protect)
-			     (cleanup-enclosing cleanup))
-			    (:entry cleanup))))
-      (when (and (eq (nlx-info-continuation nlx) cont)
-		 (eq (continuation-use (cleanup-start entry-cleanup))
-		     entry))
-	(return nlx)))))
-
-
-;;;; Functional hackery:
-
-;;; Main-Entry  --  Interface
-;;;
-;;;    If Functional is a Lambda, just return it; if it is an
-;;; optional-dispatch, return the main-entry.
-;;;
-(proclaim '(function main-entry (functional) lambda))
-(defun main-entry (functional)
-  (if (lambda-p functional)
-      functional
-      (optional-dispatch-main-entry functional)))
-
-;;; Looks-Like-An-MV-Bind  --  Interface
-;;;
-;;;    Returns true if Functional is a thing that can be treated like MV-Bind
-;;; when it appears in an MV-Call.  All fixed arguments must be optional with
-;;; null default and no supplied-p.  There must be a rest arg with no
-;;; references.
-;;;
-(proclaim '(function looks-like-an-mv-bind (functional) boolean))
-(defun looks-like-an-mv-bind (functional)
-  (and (optional-dispatch-p functional)
-       (do ((arg (optional-dispatch-arglist functional) (cdr arg)))
-	   ((null arg) nil)
-	 (let ((info (lambda-var-arg-info (car arg))))
-	   (unless info (return nil))
-	   (case (arg-info-kind info)
-	     (:optional
-	      (when (or (arg-info-supplied-p info) (arg-info-default info))
-		(return nil)))
-	     (:rest
-	      (return (and (null (cdr arg)) (null (leaf-refs (car arg))))))
-	     (t
-	      (return nil)))))))
-
-;;; External-Entry-Point-P  --  Interface
-;;;
-;;;    Return true if function is an XEP.  This is true of normal XEPs
-;;; (:External kind) and top-level lambdas (:Top-Level kind.)
-;;;
-(defun external-entry-point-p (fun)
-  (declare (type functional fun))
-  (not (null (member (functional-kind fun) '(:external :top-level)))))
-
-
-;;; Continuation-Function-Name  --  Interface
-;;;
-;;;    If Cont's only use is a global function reference, then return the
-;;; referenced symbol, otherwise NIL.
-;;;
-(defun continuation-function-name (cont)
-  (declare (type continuation cont))
-  (let ((use (continuation-use cont)))
-    (if (ref-p use)
-	(let ((leaf (ref-leaf use)))
-	  (if (and (global-var-p leaf)
-		   (eq (global-var-kind leaf) :global-function))
-	      (leaf-name leaf)
-	      nil))
-	nil)))
-
-
-;;; LET-COMBINATION  --  Interface
-;;;
-;;;    Return the COMBINATION node that is the call to the let Fun.
-;;;
-(defun let-combination (fun)
-  (declare (type clambda fun))
-  (assert (eq (functional-kind fun) :let))
-  (continuation-dest (node-cont (first (leaf-refs fun)))))
-
-
-;;; LET-VAR-INITIAL-VALUE  --  Interface
-;;;
-;;;    Return the initial value continuation for a let variable or NIL if none.
-;;;
-(defun let-var-initial-value (var)
-  (declare (type lambda-var var))
-  (let ((fun (lambda-var-home var)))
-    (elt (combination-args (let-combination fun))
-	 (position var (lambda-vars fun)))))
-
-
-;;; COMBINATION-LAMBDA  --  Interface
-;;;
-;;;    Return the LAMBDA that is called by the local Call.
-;;;
-(defun combination-lambda (call)
-  (declare (type basic-combination call))
-  (assert (eq (basic-combination-kind call) :local))
-  (ref-leaf (continuation-use (basic-combination-fun call))))
-
-
-;;;; Compiler error context determination:
-
-(proclaim '(special *current-path* *current-form*))
-
-
-;;; We separate the determination of compiler error contexts from the actual
-;;; signalling of those errors by objectifying the error context.  This allows
-;;; postponement of the determination of how (and if) to signal the error.
-;;; We take care not to reference any of the IR1 so that pending potential
-;;; error messages won't prevent the IR1 from being GC'd.
-;;;
-(defstruct (compiler-error-context
-	    (:print-function
-	     (lambda (s stream d)
-	       (declare (ignore s d))
-	       (format stream "#<Compiler-Error-Context>"))))
-  ;;
-  ;; The form immediately responsible for this error (may be the result of
-  ;; mecroexpansion, etc.)
-  source
-  ;;
-  ;; The form in the original source that expanded into Source.
-  original-source
-  ;;
-  ;; A list of prefixes of "interesting" forms that enclose original-source.
-  context)
-
-  
-;;; If true, this is the node which is used as context in compiler warning
-;;; messages.
-;;;
-(proclaim '(type (or null compiler-error-context node)
-		 *compiler-error-context*))
-(defvar *compiler-error-context* nil)
-
-
-;;; A list of "DEFxxx" forms for which we should we should compute the source
-;;; context by taking the CAR of the first arg when it is a list.
-;;;
-(defparameter defmumble-take-car-forms '(defstruct))
-
-
-;;; Find-Original-Source  --  Internal
-;;;
-;;;    Given a source path, return the original source form and a description
-;;; of the interesting aspects of the context in which it appeared.  The
-;;; context is a list of lists, one sublist per context form.  The sublist is a
-;;; list of some of the initial subforms of the context form.
-;;;
-;;; For now, we use the first two subforms of each interesting form.  A form is
-;;; interesting if the first element is a symbol beginning with "DEF" and it is
-;;; not the source form.  If there is no DEF-mumble, then we use the outermost
-;;; containing form.  If the second subform is a list, then in some cases we
-;;; return the car of that form rather than the whole form (i.e. don't show
-;;; defstruct options, etc.)
-;;;
-(defun find-original-source (path)
-  (declare (list path))
-  (assert path)
-  (let* ((rpath (reverse (rest path)))
-	 (root (find-source-root (first rpath) *source-info*)))
-    (collect ((context))
-      (let ((form root)
-	    (current (rest rpath)))
-	(loop
-	  (when (null current) (return))
-	  (let ((head (first form)))
-	    (when (symbolp head)
-	      (let ((name (symbol-name head)))
-		(when (and (>= (length name) 3) (string= name "DEF" :end1 3))
-		  (if (>= (length form) 2)
-		      (let ((next (second form)))
-			(context
-			 (list head
-			       (if (and (listp next)
-					(member head
-						defmumble-take-car-forms))
-				   (car next)
-				   next))))
-		      (context (list head)))))))
-	  (setq form (nth (pop current) form)))
-	
-	(cond ((context)
-	       (values form (context)))
-	      ((and path root)
-	       (if (listp root)
-		   (values form (list (subseq root 0 (min 2 (length root)))))
-		   (values form ())))
-	      (t
-	       (values '(unable to locate source)
-		       '((some strange place)))))))))
-
-
-;;; FIND-ERROR-CONTEXT  --  Interface
-;;;
-;;;    Return a COMPILER-ERROR-CONTEXT structure describing the current error
-;;; context, or NIL if we can't figure anything out.
-;;;
-(defun find-error-context ()
-  (let ((context *compiler-error-context*))
-    (if (compiler-error-context-p context)
-	context
-	(let ((source (cond (*current-form*)
-			    (context (node-source context))
-			    (t nil)))
-	      (path (if context (node-source-path context) *current-path*)))
-	  (when (and *source-info* path)
-	    (multiple-value-bind (form src-context)
-				 (find-original-source path)
-	      (make-compiler-error-context
-	       :source source
-	       :original-source form
-	       :context src-context)))))))
-
-
-;;;; Printing error messages:
-
-;;; A function that is called to unwind out of Compiler-Error.
-;;;
-(proclaim '(type (function () nil) *compiler-error-bailout*))
-(defvar *compiler-error-bailout*
-  #'(lambda () (error "Compiler-Error with no bailout.")))
-
-;;; We bind print level and length when printing out messages so that we don't
-;;; dump huge amounts of garbage.
-;;;
-(proclaim '(type (or unsigned-byte null) *error-print-level* *error-print-length*))
-(defvar *error-print-level* 3
-  "The value for *Print-Level* when printing compiler error messages.")
-(defvar *error-print-length* 5
-  "The value for *Print-Length* when printing compiler error messages.")
-
-
-;;; We save the context information that we printed out most recently so that
-;;; we don't print it out redundantly.
-;;;
-(proclaim '(list *last-source-context*))
-(defvar *last-source-context* nil)
-(defvar *last-original-source* nil)
-(defvar *last-source-form* nil)
-(defvar *last-format-string* nil)
-(defvar *last-format-args* nil)
-(defvar *last-message-count* 0)
-
-;;; The stream that compiler error output is directed to, or NIL if error
-;;; output is inhibited.
-;;;
-(defvar *compiler-error-output* (make-synonym-stream '*error-output*))
-(proclaim '(type (or stream null) *compiler-error-output*))
-
-
-;;; Note-Message-Repeats  --  Internal
-;;;
-;;;    If the last message was given more than once, then print out an
-;;; indication of how many times it was repeated.  We reset the message count
-;;; when we are done.
-;;;
-(defun note-message-repeats ()
-  (when (> *last-message-count* 1)
-    (format *compiler-error-output* "[Last message occurs ~D times]~%"
-	    *last-message-count*))
-  (setq *last-message-count* 0))
-
-
-;;; Print-Error-Message  --  Internal
-;;;
-;;;    Print out the message, with appropriate context if we can find it.  If
-;;; If the context is different from the context of the last message we
-;;; printed, then we print the context.  If the original source is different
-;;; from the source we are working on, then we print the current source in
-;;; addition to the original source.
-;;;
-;;;    We suppress printing of messages identical to the previous, but record
-;;; the number of times that the message is repeated.
-;;;
-(defun print-error-message (what format-string format-args)
-  (declare (string what format-string) (list format-args))
-  (let* ((*print-level* *error-print-level*)
-	 (*print-length* *error-print-length*)
-	 (stream *compiler-error-output*)
-	 (context (find-error-context)))
-    
-    (unless stream (return-from print-error-message (undefined-value)))
-    
-    (cond
-     (context
-      (let ((context (compiler-error-context-context context))
-	    (form (compiler-error-context-original-source context))
-	    (source (compiler-error-context-source context)))
-	
-	(unless (equal context *last-source-context*)
-	  (note-message-repeats)
-	  (setq *last-source-context* context)
-	  (setq *last-original-source* nil)
-	  (format stream "~2&In:~{~<~%   ~4:;~{ ~S~}~>~^ =>~}~%" context))
-	
-	(unless (equal form *last-original-source*)
-	  (note-message-repeats)
-	  (setq *last-original-source* form)
-	  (setq *last-source-form* nil)
-	  (format stream "  ~S~%" form))
-	
-	(unless (equal source *last-source-form*)
-	  (note-message-repeats)
-	  (setq *last-source-form* source)
-	  (setq *last-format-string* nil)
-	  (unless (or (equal source form) (member source format-args))
-	    (format stream "==>~%  ~S~%" source)))))
-     (t
-      (note-message-repeats)
-      (format stream "~2&")))
-    
-    (unless (and (equal format-string *last-format-string*)
-		 (equal format-args *last-format-args*))
-      (note-message-repeats)
-      (setq *last-format-string* format-string)
-      (setq *last-format-args* format-args)
-      (format stream "~&~A: ~?~&" what format-string format-args)))
-  
-  (incf *last-message-count*)
-  (undefined-value))
-
-
-;;; Keep track of how many times each kind of warning happens.
-;;;
-(proclaim '(type unsigned-byte *compiler-error-count* *compiler-warning-count*
-		 *compiler-note-count*))
-(defvar *compiler-error-count* 0)
-(defvar *compiler-warning-count* 0)
-(defvar *compiler-note-count* 0)
-
-
-;;; Compiler-Error, ...  --  Interface
-;;;
-;;;    Increment the count and print the message.  Compiler-Note never prints
-;;; anything when Brevity is 3.  Compiler-Error calls the bailout function
-;;; so that it never returns.  Compiler-Error-Message returns like
-;;; Compiler-Warning, but prints a message like Compiler-Error.
-;;;
-(proclaim '(ftype (function (string &rest t) void)
-		  compiler-error compiler-warning compiler-note))
-;;;
-(defun compiler-error (format-string &rest format-args)
-  (incf *compiler-error-count*)
-  (print-error-message "Error" format-string format-args)
-  (funcall *compiler-error-bailout*)
-  (error "*Compiler-Error-Bailout* returned?"))
-;;;
-(defun compiler-error-message (format-string &rest format-args)
-  (incf *compiler-error-count*)
-  (print-error-message "Error" format-string format-args))
-;;;
-(defun compiler-warning (format-string &rest format-args)
-  (incf *compiler-warning-count*)
-  (print-error-message "Warning" format-string format-args))
-;;;
-(defun compiler-note (format-string &rest format-args)
-  (incf *compiler-note-count*)
-  (unless (if *compiler-error-context*
-	      (policy *compiler-error-context* (= brevity 3))
-	      (policy nil (= brevity 3)))
-    (print-error-message "Note" format-string format-args)))
-
-
-;;; Compiler-Mumble  --  Interface
-;;;
-;;;    The politically correct way to print out random progress messages and
-;;; such like.  We clear the current error context so that we know that it
-;;; needs to be reprinted, and we also Force-Output so that the message gets
-;;; seen right away.
-;;;
-(proclaim '(function compiler-mumble (string &rest t) void))
-(defun compiler-mumble (format-string &rest format-args)
-  (when *last-format-string*
-    (note-message-repeats)
-    (terpri *compiler-error-output*)
-    (setq *last-source-context* nil)
-    (setq *last-format-string* nil))
-  (apply #'format *compiler-error-output* format-string format-args)
-  (force-output))
-
-
-;;; Find-Component-Name  --  Interface
-;;;
-;;;    Return a string that somehow names the code in Component.  We use the
-;;; source path for the bind node for an arbitrary entry point to find the
-;;; source context, then return that as a string.
-;;;
-(proclaim  '(function find-component-name (component) simple-string))
-(defun find-component-name (component)
-  (let ((ep (first (block-succ (component-head component)))))
-    (assert ep () "No entry points?")
-    (multiple-value-bind
-	(form context)
-	(find-original-source
-	 (node-source-path (continuation-next (block-start ep))))
-      (declare (ignore form))
-      (let ((*print-level* 2)
-	    (*print-pretty* nil))
-	(format nil "~{~{~S~^ ~}~^ => ~}" context)))))
-
-
-;;;; Careful call:
-
-;;; Careful-Call  --  Interface
-;;;
-;;;    Apply a function to some arguments, returning a list of the values
-;;; resulting of the evaulation.  If an error is signalled during the
-;;; application, then we print a warning message and return NIL as our second
-;;; value to indicate this.  Node is used as the error context for any error
-;;; message, and Context is a string that is spliced into the warning.
-;;;
-(proclaim '(function careful-call (function list node string) (values list boolean)))
-(defun careful-call (function args node context)
-  (values
-   (multiple-value-list
-    (handler-case (apply function args)
-      (error (condition)
-	(let ((*compiler-error-context* node))
-	  (compiler-warning "Lisp error during ~A:~%~A" context condition)
-	  (return-from careful-call (values nil nil))))))
-   t))
-
-
-;;;; Generic list (?) functions:
-
-;;; Find-In  --  Interface
-;;;
-(defun find-in (next element list &key (key #'identity)
-		     (test #'eql test-p) (test-not nil not-p))
-  "Find Element in a null-terminated List linked by the accessor function
-  Next.  Key, Test and Test-Not are the same as for generic sequence
-  functions."
-  (when (and test-p not-p)
-    (error "Silly to supply both :Test and :Test-Not."))
-  (if not-p
-      (do ((current list (funcall next current)))
-	  ((null current) nil)
-	(unless (funcall test-not (funcall key current) element)
-	  (return current)))
-      (do ((current list (funcall next current)))
-	  ((null current) nil)
-	(when (funcall test (funcall key current) element)
-	  (return current)))))
-
-;;; Position-In  --  Interface
-;;;
-(defun position-in (next element list &key (key #'identity)
-		     (test #'eql test-p) (test-not nil not-p))
-  "Return the position of Element (or NIL if absent) in a null-terminated List
-  linked by the accessor function Next.  Key, Test and Test-Not are the same as
-  for generic sequence functions."
-  (when (and test-p not-p)
-    (error "Silly to supply both :Test and :Test-Not."))
-  (if not-p
-      (do ((current list (funcall next current))
-	   (i 0 (1+ i)))
-	  ((null current) nil)
-	(unless (funcall test-not (funcall key current) element)
-	  (return i)))
-      (do ((current list (funcall next current))
-	   (i 0 (1+ i)))
-	  ((null current) nil)
-	(when (funcall test (funcall key current) element)
-	  (return i)))))
-
-
-;;; Map-In  --  Interface
-;;;
-(defun map-in (next function list)
-  "Map Function over the elements in a null-terminated List linked by the
-  accessor function Next, returning a list of the results."
-  (collect ((res))
-    (do ((current list (funcall next current)))
-	((null current))
-      (res (funcall function current)))
-    (res)))
-
-
-;;; Deletef-In  --  Interface
-;;;
-(defmacro deletef-in (next place item &environment env)
-  "Deletef-In Next Place Item
-  Delete Item from a null-terminated list linked by the accessor function Next
-  that is stored in Place.  Item must appear exactly once in the list."
-  (multiple-value-bind
-      (temps vals stores store access)
-      #-new-compiler
-      (if clc::*in-the-compiler*
-	  (get-setf-method place env)
-	  (lisp::foo-get-setf-method place env))
-      #+new-compiler
-      (lisp::foo-get-setf-method place env)
-    (let ((n-item (gensym))
-	  (n-place (gensym))
-	  (n-current (gensym))
-	  (n-prev (gensym)))
-      `(let* (,@(mapcar #'list temps vals)
-	      (,n-place ,access)
-	      (,n-item ,item))
-	 (if (eq ,n-place ,n-item)
-	     (let ((,(first stores) (,next ,n-place)))
-	       ,store)
-	     (do ((,n-prev ,n-place ,n-current)
-		  (,n-current (,next ,n-place)
-			      (,next ,n-current)))
-		 ((eq ,n-current ,n-item)
-		  (setf (,next ,n-prev)
-			(,next ,n-current)))))
-	 (undefined-value)))))
-
-
-;;; Push-In  --  Interface
-;;;
-(defmacro push-in (next item place &environment env)
-  "Push Item onto a list linked by the accessor function Next that is stored in
-  Place."
-  (multiple-value-bind
-      (temps vals stores store access)
-      #-new-compiler
-      (if clc::*in-the-compiler*
-	  (get-setf-method place env)
-	  (lisp::foo-get-setf-method place env))
-      #+new-compiler
-      (lisp::foo-get-setf-method place env)
-    `(let (,@(mapcar #'list temps vals)
-	   (,(first stores) ,item))
-       (setf (,next ,(first stores)) ,access)
-       ,store
-       (undefined-value))))
-
-
-;;; Compiler-Constantp  --  Interface
-;;;
-;;;    We don't want to assume that a variable is a constant just because it is
-;;; in the current lisp environment.
-;;;
-;;; ### For now, just use CONSTANTP to avoid bootstrapping problems with having
-;;; to have the INFO database available at meta-compile time.
-;;;
-(proclaim '(function compiler-constantp (t) boolean))
-(defun compiler-constantp (exp)
-  "Like constantp, only uses the compilation environment rather than the
-  current Lisp environment."
-#|
-  (if (symbolp exp)
-      (eq (info variable kind exp) :constant)
-      (constantp exp))
-|#
-  (constantp exp))
diff --git a/compiler/ir2tran.lisp b/compiler/ir2tran.lisp
deleted file mode 100644
index 67e2d8b9894037ae95e4b2c6a58d26224e0f9255..0000000000000000000000000000000000000000
--- a/compiler/ir2tran.lisp
+++ /dev/null
@@ -1,1798 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir2tran.lisp,v 1.4 1990/03/05 12:13:49 ram Exp $
-;;;
-;;;    This file contains the virtual machine independent parts of the code
-;;; which does the actual translation of nodes to VOPs.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-
-;;;; Random utilities:
-
-
-;;; Block-Label  --  Interface
-;;;
-;;;    Return the label marking the start of Block, assigning one if necessary.
-;;;
-(defun block-label (block)
-  (declare (type cblock block))
-  (let ((2block (block-info block)))
-    (or (ir2-block-%label 2block)
-	(setf (ir2-block-%label 2block) (gen-label)))))
-
-
-;;; Drop-Thru-P  --  Interface
-;;;
-;;;    Return true if Block is emitted immediately after the block ended by
-;;; Node.
-;;;
-(defun drop-thru-p (node block)
-  (declare (type node node) (type cblock block))
-  (let ((next-block (ir2-block-next (block-info (node-block node)))))
-    (assert (eq node (block-last (node-block node))))
-    (eq next-block (block-info block))))
-
-
-;;; Flush-Tail-Transfer  --  Interface
-;;;
-;;;    Annotate Node and Block to indicate that the Node is being
-;;; compiled in a way that exploits its tail-recursive position: Block ends
-;;; with a return or TR call, and will never transfer to the block containing
-;;; the return node.
-;;;
-;;;    For now, we just flush the link between the IR1 blocks, but we might
-;;; want to do something else someday.  If the return is is the same block as
-;;; Node, then we don't do any anything.  This works, since this can only
-;;; happen when there node is the sole use of the return continuation.  Since
-;;; Node is TR, LTN will annotate Cont as :Unused, and no return code will be
-;;; emitted.
-;;;
-(defun flush-tail-transfer (node block)
-  (declare (type node node) (type ir2-block block) (ignore block))
-  (let* ((cont (node-cont node))
-	 (ret (continuation-dest cont))
-	 (b1 (node-block node))
-	 (b2 (node-block ret)))
-    (assert (return-p ret))
-    (if (eq b1 b2)
-	(assert (eq (ir2-continuation-kind (continuation-info cont)) :unused))
-	(unlink-blocks b1 b2)))
-  (undefined-value))
-
-
-;;; Insert-VOP-Sequence  --  Interface
-;;;
-;;;    Link a list of VOPs from First to Last into Block, Before the specified
-;;; VOP.  If Before is NIL, insert at the end.
-;;;
-(defun insert-vop-sequence (first last block before)
-  (declare (type vop first last) (type ir2-block block)
-	   (type (or vop null) before))
-  (if before
-      (let ((prev (vop-prev before)))
-	(setf (vop-prev first) prev)
-	(if prev
-	    (setf (vop-next prev) first)
-	    (setf (ir2-block-start-vop block) first))
-	(setf (vop-next last) before)
-	(setf (vop-prev before) last))
-      (let ((current (ir2-block-last-vop block)))
-	(setf (vop-prev first) current)
-	(setf (ir2-block-last-vop block) last)
-	(if current
-	    (setf (vop-next current) first)
-	    (setf (ir2-block-start-vop block) first))))
-  (undefined-value))
-
-
-;;;; Moves and type checks:
-
-;;; Emit-Move-Template  --  Internal
-;;;
-;;;    Emit a move-like template determined at run-time, with X as the argument
-;;; and Y as the result.  If Template is null, then just use the Move VOP.
-;;; Useful for move, coerce and type-check templates.  If supplied, then insert
-;;; before VOP, otherwise insert at then end of the block.
-;;;
-(defun emit-move-template (node block template x y &optional before)
-  (declare (type node node) (type ir2-block block)
-	   (type (or template null) template) (type tn x y))
-  (let ((template (or template (template-or-lose 'move)))
-	(arg (reference-tn x nil))
-	(result (reference-tn y t)))
-    (multiple-value-bind
-	(first last)
-	(funcall (template-emit-function template) node block template arg
-		 result)
-      (insert-vop-sequence first last block before)))
-  (undefined-value))
-
-
-;;; Emit-Move  --  Internal
-;;;
-;;;    Move X to Y, emitting the appropriate move/coerce VOP.  If the primitive
-;;; types don't overlap, there there must be a type error.  In this case, we
-;;; coerce the source object to T, then emit ILLEGAL-MOVE to make properly
-;;; start the destination's lifetime.
-;;;
-(defun emit-move (node block x y)
-  (declare (type node node) (type ir2-block block) (type tn x y))
-  (let ((x-type (tn-primitive-type x))
-	(y-type (tn-primitive-type y)))
-    (cond ((eq x-type y-type)
-	   (emit-move-template node block (primitive-type-move x-type) x y))
-	  ((eq y-type *any-primitive-type*)
-	   (emit-move-template node block (primitive-type-coerce-to-t x-type)
-			       x y))
-	  ((eq x-type *any-primitive-type*)
-	   (emit-move-template node block (primitive-type-coerce-from-t y-type)
-			       x y))
-	  (t
-	   (let* ((c-to-t (primitive-type-coerce-to-t x-type))
-		  (src (if c-to-t
-			   (make-normal-tn *any-primitive-type*)
-			   x))
-		  (y-type (emit-constant
-			   (type-specifier
-			    (primitive-type-type
-			     (tn-primitive-type y))))))
-	     (when c-to-t
-	       (emit-move-template node block c-to-t x src))
-	     (vop illegal-move node block src y-type y)))))
-
-  (undefined-value))
-
-
-;;; Maybe-Coerce  --  Internal
-;;;
-;;;    If TN is of the specified type, or doesn't require a coercion to be of
-;;; that type, then return TN, otherwise convert the value into a temporary and
-;;; return the temporary.
-;;;
-(defun maybe-coerce (node block tn ptype)
-  (declare (type node node) (type ir2-block block)
-	   (type tn tn) (type primitive-type ptype))
-  (let ((tn-ptype (tn-primitive-type tn)))
-    (if (or (eq tn-ptype ptype)
-	    (not (or (primitive-type-coerce-to-t tn-ptype)
-		     (primitive-type-coerce-from-t ptype))))
-	tn
-	(let ((temp (make-normal-tn ptype)))
-	  (emit-move node block tn temp)
-	  temp))))
-
-
-;;; Get-Result-TN  --  Internal
-;;;
-;;;    Used together with Move-Result to handle any coercion necessary to
-;;; compute a value of the primitive-type PType in TN.  This is called before
-;;; computation of the result to get a TN to compute the result in.  If a
-;;; coercion is necessary, then we create a temporary and return it, otherwise
-;;; we return TN.
-;;;
-(defun get-result-tn (tn ptype)
-  (declare (type tn tn) (type primitive-type ptype))
-    (if (ok-result-tn tn ptype)
-	tn
-	(make-normal-tn ptype)))
-
-
-;;; OK-Result-TN  --  Internal
-;;;
-;;;    Return true if TN is an ok location to compute a result of the specified
-;;; primitive type in, i.e. no implicit coercion is needed.  This is true when
-;;; either the primitive types are the same or when no coercion is needed
-;;; to/from T.  If there is a manifest type error, then we always return T so
-;;; that EMIT-MOVE gets to do its thing.
-;;;
-(defun ok-result-tn (tn ptype)
-  (declare (type tn tn) (type primitive-type ptype))
-  (let ((tn-ptype (tn-primitive-type tn)))
-    (cond ((eq tn-ptype ptype))
-	  ((eq tn-ptype *any-primitive-type*)
-	   (not (primitive-type-coerce-to-t ptype)))
-	  ((eq ptype *any-primitive-type*)
-	   (not (primitive-type-coerce-from-t tn-ptype)))
-	  (t
-	   nil))))
-
-
-;;; Move-Result  --  Internal
-;;;
-;;;    Used with Get-Result-TN to handle result type coercions.  This is called
-;;; after the result is actually computed in order actually do the coercion.
-;;; If TN isn't EQ to Dest, then have Emit-Move figure out what to do.
-;;;
-(proclaim '(inline move-result))
-(defun move-result (node block tn dest)
-  (declare (type node node) (type ir2-block block) (type tn tn dest))
-  (unless (eq tn dest)
-    (emit-move node block tn dest))
-  (undefined-value))
-
-
-;;; Type-Check-Template  --  Interface
-;;;
-;;;    If there is any CHECK-xxx template for Type, then return it, otherwise
-;;; return NIL.
-;;;
-(defun type-check-template (type)
-  (declare (type ctype type))
-  (multiple-value-bind (check-ptype exact)
-		       (primitive-type type)
-    (if exact
-	(primitive-type-check check-ptype)
-	(let ((name (hairy-type-check-template type)))
-	  (if name
-	      (template-or-lose name)
-	      nil)))))
-
-
-;;; Emit-Type-Check  --  Internal
-;;;
-;;;    Emit code in Block to check that Value is of the specified Type,
-;;; yielding the checked result in Result.  Value and result may be of any
-;;; primitive type.  There must be CHECK-xxx VOP for Type.  Any other type
-;;; checks should have been converted to an explicit type test.
-;;;
-(defun emit-type-check (node block value result type)
-  (declare (type tn value result) (type node node) (type ir2-block block)
-	   (type ctype type))
-  (let ((check (type-check-template type)))
-    (assert check)
-    (let ((src (maybe-coerce node block value *any-primitive-type*))
-	  (dest (get-result-tn result *any-primitive-type*)))
-      (emit-move-template node block check src dest)
-      (move-result node block dest result)))
-  (undefined-value))
-
-
-;;; Move-From-Frame, Move-To-Frame  --  Internal
-;;;
-;;;    Move a value out of or into a different frame.  This is used during
-;;; function call/return to move an argument or return value into the
-;;; appropriate passing location.
-;;;
-;;; [### For now, we always use the same VOPs, and passing locations are always
-;;; in a descriptor representation.  To allow passing of non-descriptor
-;;; arguments or results, we will have to have type-specific argument/value
-;;; moving VOPs.]
-;;;
-(defun move-from-frame (node block src dest frame)
-  (declare (type node node) (type ir2-block block) (type tn src dest frame))
-  (let* ((dtype (tn-primitive-type dest))
-	 (temp (if (primitive-type-coerce-from-t dtype)
-		   (make-normal-tn *any-primitive-type*)
-		   dest)))
-    (vop move-argument node block src frame temp)
-    (unless (eq temp dest)
-      (emit-move node block temp dest)))
-  (undefined-value))
-;;;
-(defun move-to-frame (node block src dest frame)
-  (declare (type node node) (type ir2-block block) (type tn src dest frame))
-  (let* ((stype (tn-primitive-type src))
-	 (temp (if (primitive-type-coerce-to-t stype)
-		   (make-normal-tn *any-primitive-type*)
-		   src)))
-    (unless (eq src temp)
-      (emit-move node block src temp))
-    (vop move-value node block temp frame dest))
-  (undefined-value))
-
-
-;;;; Leaf reference:
-
-;;; Find-In-Environment  --  Internal
-;;;
-;;;    Return the TN that holds the value of Thing in the environment Env.
-;;;
-(defun find-in-environment (thing env)
-  (declare (type (or nlx-info lambda-var) thing) (type environment env))
-  (or (cdr (assoc thing (ir2-environment-environment (environment-info env))))
-      (etypecase thing
-	(lambda-var
-	 (assert (eq env (lambda-environment (lambda-var-home thing))))
-	 (leaf-info thing))
-	(nlx-info
-	 (assert (eq env
-		     (lambda-environment
-		      (block-lambda
-		       (continuation-block (nlx-info-continuation thing))))))
-	 (ir2-nlx-info-home (nlx-info-info thing))))))
-
-
-;;; Constant-TN  --  Internal
-;;;
-;;;    If Leaf already has a constant TN, return that, otherwise make a TN for
-;;; it.
-;;;
-(defun constant-tn (leaf)
-  (declare (type constant leaf))
-  (or (leaf-info leaf)
-      (setf (leaf-info leaf)
-	    (make-constant-tn leaf))))
-
-  
-;;; Leaf-TN  --  Internal
-;;;
-;;;    Return a TN that represents the value of Leaf, or NIL if Leaf isn't
-;;; directly represented by a TN.  Env is the environment that the reference is
-;;; done in.
-;;;
-(defun leaf-tn (leaf env)
-  (declare (type leaf leaf) (type environment env))
-  (typecase leaf
-    (lambda-var
-     (unless (lambda-var-indirect leaf)
-       (find-in-environment leaf env)))
-    (constant (constant-tn leaf))
-    (t nil)))
-
-
-;;; Emit-Constant  --  Internal
-;;;
-;;;    Used to conveniently get a handle on a constant TN during IR2
-;;; conversion.  Returns a constant TN representing the Lisp object Value.
-;;;
-(defun emit-constant (value)
-  (constant-tn (find-constant value)))
-
-
-;;; IR2-Convert-Hairy-Function-Ref  --  Internal
-;;;
-;;;    Handle a function Ref that can't be converted to a symbol access.  We
-;;; convert a call to FDEFINITION with Name as the argument.
-;;;
-(defun ir2-convert-hairy-function-ref (node block name)
-  (declare (type ref node) (type ir2-block block) (type tn name))
-  (when (policy node (> speed brevity))
-    (let ((*compiler-error-context* node))
-      (compiler-note "Compiling a full call to FDEFINITION.")))
-  (let ((arg (standard-argument-location 0))
-	(res (standard-argument-location 0))
-	(fun (emit-constant 'fdefinition)))
-    (emit-move node block name arg)
-    (vop* call-named node block (fun arg nil) (res nil) "<save info>" 1 1)
-    (move-continuation-result node block (list res) (node-cont node)))
-  (undefined-value))
-
-
-;;; IR2-Convert-Ref  --  Internal
-;;;
-;;;    Convert a Ref node.  The reference must not be delayed.
-;;;
-(defun ir2-convert-ref (node block)
-  (declare (type ref node) (type ir2-block block))
-  (let* ((cont (node-cont node))
-	 (leaf (ref-leaf node))
-	 (name (leaf-name leaf))
-	 (locs (continuation-result-tns
-		cont (list (primitive-type (leaf-type leaf)))))
-	 (res (first locs)))
-    (etypecase leaf
-      (lambda-var
-       (let ((tn (find-in-environment leaf (node-environment node))))
-	 (if (lambda-var-indirect leaf)
-	     (vop value-cell-ref node block tn res)
-	     (emit-move node block tn res))))
-      (constant
-       (emit-move node block (constant-tn leaf) res))
-      (functional
-       (ir2-convert-closure node block leaf res))
-      (global-var
-       (let ((name-tn (emit-constant name))
-	     (unsafe (policy node (> speed safety))))
-	 (ecase (global-var-kind leaf)
-	   ((:special :global :constant)
-	    (assert (symbolp name))
-	    (if unsafe
-		(vop fast-symbol-value node block name-tn res)
-		(vop symbol-value node block name-tn res)))
-	   (:global-function
-	    (unless (symbolp name)
-	      (ir2-convert-hairy-function-ref node block name-tn)
-	      (return-from ir2-convert-ref (undefined-value)))
-
-	    (if unsafe
-		(vop fast-symbol-function node block name-tn res)
-		(vop symbol-function node block name-tn res)))))))
-
-    (move-continuation-result node block locs cont))
-  (undefined-value))
-
-
-;;; IR2-Convert-Closure  --  Internal
-;;;
-;;;    Emit code to load a function object representing Leaf into Res.  This
-;;; gets interesting when the referenced function is a closure: we must make
-;;; the closure and move the closed over values into it.
-;;;
-;;; Leaf is the XEP lambda for the called function, since local call analysis
-;;; converts all closure references.
-;;;
-(defun ir2-convert-closure (node block leaf res)
-  (declare (type ref node) (type ir2-block block)
-	   (type clambda leaf) (type tn res))
-  (let ((entry (make-load-time-constant-tn :entry leaf))
-	(this-env (node-environment node))
-	(leaf-closure (environment-closure (lambda-environment leaf))))
-    (cond (leaf-closure
-	   (vop make-closure node block (emit-constant (length leaf-closure))
-		entry res)
-	   (let ((n (1- system:%function-closure-variables-offset)))
-	     (dolist (what leaf-closure)
-	       (vop closure-init node block
-		    res (find-in-environment what this-env)
-		    (incf n)))))
-	  (t
-	   (emit-move node block entry res))))
-  (undefined-value))
-
-
-;;; IR2-Convert-Set  --  Internal
-;;;
-;;;    Convert a Set node.  If the node's cont is annotated, then we also
-;;; deliver the value to that continuation.  If the var is a lexical variable
-;;; with no refs, then we don't actually set anything, since the variable has
-;;; been deleted.
-;;;
-(defun ir2-convert-set (node block)
-  (declare (type cset node) (type ir2-block block))
-  (let* ((cont (node-cont node))
-	 (leaf (set-var node))
-	 (val (continuation-tn node block (set-value node)))
-	 (locs (if (continuation-info cont)
-		   (continuation-result-tns
-		    cont (list (primitive-type (leaf-type leaf))))
-		   nil)))
-    (etypecase leaf
-      (lambda-var
-       (when (leaf-refs leaf)
-	 (let ((tn (find-in-environment leaf (node-environment node))))
-	   (if (lambda-var-indirect leaf)
-	       (vop value-cell-set node block tn val)
-	       (emit-move node block val tn)))))
-      (global-var
-       (ecase (global-var-kind leaf)
-	 ((:special :global)
-	  (assert (symbolp (leaf-name leaf)))
-	  (vop set node block (emit-constant (leaf-name leaf)) val
-	       (make-normal-tn *any-primitive-type*))))))
-
-    (when locs
-      (emit-move node block val (first locs))
-      (move-continuation-result node block locs cont)))
-  (undefined-value))
-
-
-;;;; Utilities for receiving single values:
-
-;;; Continuation-TN  --  Internal
-;;;
-;;;    Return a TN that can be referenced to get the value of Cont.  Cont must
-;;; be LTN-Annotated either as a delayed leaf ref or as a fixed, single-value
-;;; continuation.
-;;;
-(defun continuation-tn (node block cont)
-  (declare (type node node) (type ir2-block block) (type continuation cont))
-  (let ((2cont (continuation-info cont)))
-    (ecase (ir2-continuation-kind 2cont)
-      (:delayed
-       (let* ((ref (continuation-use cont))
-	      (tn (leaf-tn (ref-leaf ref) (node-environment ref)))
-	      (ptype (ir2-continuation-primitive-type 2cont)))
-	 (assert tn)
-	 (if (eq (continuation-type-check cont) t)
-	     (let ((temp (make-normal-tn ptype)))
-	       (emit-type-check node block tn temp
-				(continuation-asserted-type cont))
-	       temp)
-	     (maybe-coerce node block tn ptype))))
-      (:fixed
-       (assert (= (length (ir2-continuation-locs 2cont)) 1))
-       (first (ir2-continuation-locs 2cont))))))
-
-
-;;; Reference-Arguments  --  Internal
-;;;
-;;;    Build a TN-Refs list that represents access to the values of the
-;;; specified list of continuations Args.  Node and Block provide the context
-;;; for emitting any necessary coercion or type-checking code.
-;;;
-(defun reference-arguments (node block args)
-  (declare (type node node) (type ir2-block block) (list args))
-  (let ((last nil)
-	(first nil))
-    (dolist (arg args)
-      (let ((ref (reference-tn (continuation-tn node block arg)
-			       nil)))
-	(if last
-	    (setf (tn-ref-across last) ref)
-	    (setf first ref))
-	(setq last ref)))
-    (the (or tn-ref null) first)))
-
-
-;;;; Utilities for delivering values to continuations:
-
-;;; Continuation-Result-TNs  --  Internal
-;;;
-;;;    Return a list of TNs that can be used as result TNs to evaluate an
-;;; expression with fixed result types specified by RTypes into the
-;;; continuation Cont.  This is used together with Move-Continuation-Result to
-;;; deliver a fixed values of to a continuation.
-;;;
-;;;    If the continuation isn't annotated (meaning the values are discarded),
-;;; or wants a type check, then we make temporaries for each supplied value.
-;;; This provides a place to compute the result until we figure out what (if
-;;; anything) to do with it.
-;;;
-;;;    If the continuation is fixed-values, wants the same number of values as
-;;; the user wants to deliver, and requires no implicit coercion, then we just
-;;; return the IR2-Continuation-Locs.  If coercions are required, then we make
-;;; any necessary temporaries and return them.
-;;;
-;;;    If the continuation is unknown-values, then we make a boxed TN to
-;;; compute each desired result in.
-;;;
-;;;    If the continuation is :Unused (a tail-recursive result), then we look
-;;; at the return-info for the function being returned from.  If the return
-;;; convention is fixed, then we make result temporaries as specified by
-;;; rtypes, otherwise we make the same number of boxed temporaries.
-;;;
-(defun continuation-result-tns (cont rtypes)
-  (declare (type continuation cont) (list rtypes))
-  (let ((2cont (continuation-info cont)))
-    (if (or (not 2cont) (eq (continuation-type-check cont) t))
-	(mapcar #'make-normal-tn rtypes)
-	(ecase (ir2-continuation-kind 2cont)
-	  (:fixed
-	   (let ((locs (ir2-continuation-locs 2cont)))
-	     (if (and (= (length locs) (length rtypes))
-		      (every #'ok-result-tn locs rtypes))
-		 locs
-		 (collect ((res))
-		   (do ((loc locs (cdr loc))
-			(rtype rtypes (cdr rtype)))
-		       ((null rtype))
-		     (if loc
-			 (res (get-result-tn (car loc) (car rtype)))
-			 (res (make-normal-tn (car rtype)))))
-		   (res)))))
-	  ((:unknown :unused)
-	   (mapcar #'make-normal-tn rtypes))))))
-
-#|
-	  (:unknown
-	   (make-n-tns (length rtypes) *any-primitive-type*))
-	  (:unused
-	   (let ((returns (tail-set-info
-			   (lambda-tail-set
-			    (return-lambda
-			     (continuation-dest cont))))))
-	     (if (eq (return-info-kind returns) :fixed)
-		 (mapcar #'make-normal-tn rtypes)
-		 (make-n-tns (length rtypes) *any-primitive-type*))))
-|#
-
-;;; Make-Standard-Value-Tns  --  Internal
-;;;
-;;;    Make the first N standard value TNs, returning them in a list.
-;;;
-(defun make-standard-value-tns (n)
-  (declare (type unsigned-byte n))
-  (collect ((res))
-    (dotimes (i n)
-      (res (standard-argument-location i)))
-    (res)))
-
-
-;;; Standard-Result-TNs  --  Internal
-;;;
-;;;    Return a list of TNs wired to the standard value passing conventions
-;;; that can be used to receive values according to the unknown-values
-;;; convention.  This is used with together Move-Continuation-Result for
-;;; delivering unknown values to a fixed values continuation.
-;;;
-;;;    If the continuation isn't annotated, then we treat as 0-values,
-;;; returning an empty list of temporaries.
-;;;
-;;;    If the continuation is annotated, then it must either be :Fixed or be
-;;; :Unused with the Return-Info-Kind being :Fixed.
-;;;
-(defun standard-result-tns (cont)
-  (declare (type continuation cont))
-  (let ((2cont (continuation-info cont)))
-    (if 2cont
-	(ecase (ir2-continuation-kind 2cont)
-	  (:fixed
-	   (make-standard-value-tns (length (ir2-continuation-locs 2cont))))
-	  (:unused
-	   (let ((returns (tail-set-info
-			   (lambda-tail-set
-			    (return-lambda
-			     (continuation-dest cont))))))
-	     (assert (eq (return-info-kind returns) :fixed))
-	     (make-standard-value-tns
-	      (length (return-info-types returns))))))
-	())))
-
-
-;;; Move-Results-Checked  --  Internal
-;;;
-;;;    Move the values in the list of TNs Src to the list of TNs Dest, checking
-;;; that the types of the values match the Asserted-Type in Cont.  What we do
-;;; is look at the number of values supplied, desired and asserted, padding out
-;;; shorter lists appropriately.
-;;;
-;;;    Missing supplied values are defaulted to NIL.  Undesired supplied values
-;;; are just checked against the asserted type.  If more values are computed
-;;; than the type assertion expects, then we don't check these values.  We
-;;; ignore assertions on values neither supplied nor received.  So if there is
-;;; an assertion for an unsupplied value, it will be checked against NIL.  This
-;;; will cause a wrong-type error (if any) rather than a wrong number of values
-;;; error.  This is consistent with our general policy of not checking values
-;;; count.
-;;;
-(defun move-results-checked (node block src dest cont)
-  (declare (type node node) (type ir2-block block)
-	   (list src dest) (type ctype type))
-  (multiple-value-bind (check types)
-		       (continuation-check-types cont)
-    (assert (eq check :simple))
-    (let* ((count (length types))
-	   (nsrc (length src))
-	   (ndest (length dest))
-	   (nmax (max ndest nsrc)))
-      (mapc #'(lambda (from to assertion)
-		(if assertion
-		    (emit-type-check node block from to assertion)
-		    (emit-move node block from to)))
-	    (if (> ndest nsrc)
-		(append src (make-list (- ndest nsrc)
-				       :initial-element (emit-constant nil)))
-		src)
-	    (if (< ndest nsrc)
-		(append dest (nthcdr ndest src))
-		dest)
-	    (if (< count nmax)
-		(append types (make-list (- nmax count) :initial-element nil))
-		types))))
-  (undefined-value))
-
-
-;;; Move-Results-Coerced  --  Internal
-;;;
-;;;    Just move each Src TN into the corresponding Dest TN, defaulting any
-;;; unsupplied source values to NIL.  We let Emit-Move worry about doing the
-;;; appropriate coercions.
-;;;
-(defun move-results-coerced (node block src dest)
-  (declare (type node node) (type ir2-block block) (list src dest))
-  (let ((nsrc (length src))
-	(ndest (length dest)))
-    (mapc #'(lambda (from to)
-	      (unless (eq from to)
-		(emit-move node block from to)))
-	  (if (> ndest nsrc)
-	      (append src (make-list (- ndest nsrc)
-				     :initial-element (emit-constant nil)))
-	      src)
-	  dest))
-  (undefined-value))
-
-
-;;; Move-Continuation-Result  --  Internal
-;;;
-;;;    If necessary, emit type-checking/coercion code needed to deliver the
-;;; Results to the specified continuation.  Node and block provide context for
-;;; emitting code.  Although usually obtained from Standard-Result-TNs or
-;;; Continuation-Result-TNs, Results my be a list of any type or number of TNs.
-;;;
-;;;    If the continuation is fixed values, then move the results into the
-;;; continuation locations, doing type checks and defaulting unsupplied values.
-;;;
-;;;    If the continuation is unknown values, then do the moves/checks into the
-;;; standard value locations, and use Push-Values to put the values on the
-;;; stack.
-;;;
-;;;    If the continuation is :Unused, then this use is tail-recursive.  We
-;;; emit code that returns the values out of the current function.  Type
-;;; checking is done in-place in the Results, since we don't know where
-;;; Emit-Return-For-Locs is going to want to pass the values.  In this case, we
-;;; also flush the control transfer to the tail return.
-;;;
-(defun move-continuation-result (node block results cont)
-  (declare (type node node) (type ir2-block block)
-	   (list results) (type continuation cont))
-  (let* ((2cont (continuation-info cont))
-	 (check (eq (continuation-type-check cont) t)))
-    (when 2cont
-      (ecase (ir2-continuation-kind 2cont)
-	(:fixed
-	 (let ((locs (ir2-continuation-locs 2cont)))
-	   (cond ((eq locs results))
-		 (check
-		  (move-results-checked node block results locs cont))
-		 (t
-		  (move-results-coerced node block results locs)))))
-	(:unknown
-	 (let* ((nvals (length results))
-		(locs (make-standard-value-tns nvals)))
-	   (if check
-	       (move-results-checked node block results locs cont)
-	       (move-results-coerced node block results locs))
-	   (vop* push-values node block
-		 ((reference-tn-list locs nil))
-		 ((reference-tn-list (ir2-continuation-locs 2cont) t))
-		 nvals)))
-	(:unused
-	 (when check
-	   (move-results-checked node block results results cont))
-	 (emit-return-for-locs (continuation-dest cont) block :fixed results)
-	 (flush-tail-transfer node block)))))
-  (undefined-value))
-
-
-;;;; Template conversion:
-
-
-;;; IR2-Convert-Conditional  --  Internal
-;;;
-;;;    Convert a conditional template.  We try to exploit any drop-through, but
-;;; emit an unconditional branch afterward if we fail.  Not-P is true if the
-;;; sense of the Template's test should be negated.
-;;;
-(defun ir2-convert-conditional (node block template args if not-p)
-  (declare (type node node) (type ir2-block block)
-	   (type template template) (type (or tn-ref null) args)
-	   (type cif if) (type boolean not-p))
-  (assert (= (template-info-arg-count template) 2))
-  (let ((consequent (if-consequent if))
-	(alternative (if-alternative if)))
-    (cond ((drop-thru-p if consequent)
-	   (emit-template node block template args nil
-			  (list (block-label alternative) (not not-p))))
-	  (t
-	   (emit-template node block template args nil
-			  (list (block-label consequent) not-p))
-	   (unless (drop-thru-p if alternative)
-	     (vop branch node block (block-label alternative)))))))
-
-
-;;; IR2-Convert-IF  --  Internal
-;;;
-;;;    Convert an IF that isn't the DEST of a conditional template.
-;;;
-(defun ir2-convert-if (node block)
-  (declare (type (ir2-block block)) (type cif node))
-  (let* ((test (if-test node))
-	 (test-ref (reference-tn (continuation-tn node block test) nil))
-	 (nil-ref (reference-tn (emit-constant nil) nil)))
-    (setf (tn-ref-across test-ref) nil-ref)
-    (ir2-convert-conditional node block (template-or-lose 'if-eq)
-			     test-ref node t)))
-
-
-;;; IR2-Convert-Template  --  Internal
-;;;
-;;;    Get the operands into TNs, make TN-Refs for them, and then call the
-;;; template emit function. 
-;;;
-(defun ir2-convert-template (call block)
-  (declare (type combination call) (type ir2-block block))
-  (let* ((template (combination-info call))
-	 (cont (node-cont call))
-	 (args (reference-arguments call block (combination-args call)))
-	 (rtypes (template-result-types template)))
-    (assert (not (template-more-results-type template)))
-    (if (eq rtypes :conditional)
-	(ir2-convert-conditional call block template args
-				 (continuation-dest cont) nil)
-	(let ((results (continuation-result-tns cont rtypes)))
-	  (assert (zerop (template-info-arg-count template)))
-	  (emit-template call block template args
-			 (reference-tn-list results t))
-	  (move-continuation-result call block results cont))))
-  (undefined-value))
-
-
-;;; %%Primitive IR2 Convert  --  Internal
-;;;
-;;;    We don't have to do much because operand count checking is done by IR1
-;;; conversion.  The only difference between this and the function case of
-;;; IR2-Convert-Template is that there can be codegen-info arguments.
-;;;
-(defoptimizer (%%primitive ir2-convert) ((template info &rest args) call block)
-  (let* ((template (continuation-value template))
-	 (info (continuation-value info))
-	 (cont (node-cont call))
-	 (args (reference-arguments call block (cddr (combination-args call))))
-	 (rtypes (template-result-types template))
-	 (results (continuation-result-tns cont rtypes))
-	 (r-refs (reference-tn-list results t)))
-    (assert (not (template-more-results-type template)))
-    (assert (not (eq rtypes :conditional)))
-
-    (if info
-	(emit-template call block template args r-refs info)
-	(emit-template call block template args r-refs))
-
-    (move-continuation-result call block results cont))
-  (undefined-value))
-
-
-;;;; Local call:
-
-;;; IR2-Convert-Let  --  Internal
-;;;
-;;;    Convert a let by moving the argument values into the variables.  Since a
-;;; a let doesn't have any passing locations, we move the arguments directly
-;;; into the variables.  We must also allocate any indirect value cells, since
-;;; there is no function prologue to do this.
-;;;
-(defun ir2-convert-let (node block fun)
-  (declare (type combination node) (type ir2-block block) (type clambda fun))
-  (mapc #'(lambda (var arg)
-	    (when arg
-	      (let ((src (continuation-tn node block arg))
-		    (dest (leaf-info var)))
-		(if (lambda-var-indirect var)
-		    (vop make-value-cell node block src dest)
-		    (emit-move node block src dest)))))
-	(lambda-vars fun) (basic-combination-args node))
-  (undefined-value))
-
-
-;;; Move-Local-Call-Args  --  Internal
-;;;
-;;;    Set up the arguments for a local call.  This involves moving the actual
-;;; arguments into the passing locations (doing any type checking) and
-;;; computing the environment arguments for the called function.
-;;;
-(defun move-local-call-args (node block fun)
-  (declare (type combination node) (type ir2-block block) (type clambda fun))
-  (let* ((called-env (environment-info (lambda-environment fun)))
-	 (arg-locs (ir2-environment-arg-locs called-env))
-	 (1env (node-environment node)))
-    (dolist (arg (basic-combination-args node))
-      (when arg
-	(emit-move node block (continuation-tn node block arg)
-		   (pop arg-locs))))
-    
-    (dolist (thing (ir2-environment-environment called-env))
-      (emit-move node block (find-in-environment (car thing) 1env)
-		 (pop arg-locs))))
-
-  (undefined-value))
-
-
-;;; IR2-Convert-Tail-Local-Call   --  Internal
-;;;
-;;;    A tail-recursive local call is done by emitting moves of stuff into the
-;;; appropriate passing locations.  After setting up the args and environment,
-;;; we just move our return-pc and old-cont into the called function's passing
-;;; locations.  The Current-Cont VOP is used to set the arg pointer to point
-;;; to the current frame.
-;;;
-;;;    The Tail-Call-Local VOP's only purpose is to get the argument lifetimes
-;;; right.  We flush the tail control transfer for similar reasons.
-;;;
-(defun ir2-convert-tail-local-call (node block fun)
-  (declare (type combination node) (type ir2-block block) (type clambda fun))
-  (move-local-call-args node block fun)
-    
-  (let* ((this-env (environment-info (node-environment node)))
-	 (call-env (environment-info (lambda-environment fun)))
-	 (old-cont (ir2-environment-old-cont-pass call-env))
-	 (return-pc (ir2-environment-return-pc-pass call-env))
-	 (args (ir2-environment-argument-pointer call-env))
-	 (target (node-block (lambda-bind fun))))
-
-    (emit-move node block (ir2-environment-old-cont this-env) old-cont)
-    (emit-move node block (ir2-environment-return-pc this-env) return-pc)
-    (vop current-cont node block args)
-
-    (vop* tail-call-local node block
-	  (old-cont return-pc args
-		    (reference-tn-list (ir2-environment-arg-locs call-env)
-				       nil))
-	  (nil)
-	  (unless (drop-thru-p (block-last (node-block node)) target)
-	    (block-label target))))
-
-  (flush-tail-transfer node block)
-
-  (undefined-value))
-
-
-;;; IR2-Convert-Local-Known-Call  --  Internal
-;;;
-;;;    Handle a non-TR known-values local call.  We Emit the call, then move
-;;; the results to the continuation's destination.
-;;;
-(defun ir2-convert-local-known-call (node block env returns cont start)
-  (declare (type node node) (type ir2-block block) (type ir2-environment env)
-	   (type return-info returns) (type continuation cont)
-	   (type label start))
-  (let* ((locs (return-info-locations returns))
-	 (temps (continuation-result-tns
-		 cont (mapcar #'tn-primitive-type locs))))
-    (vop* known-call-local node block
-	  ((ir2-environment-old-cont-pass env)
-	   (ir2-environment-argument-pointer env)
-	   (reference-tn-list (ir2-environment-arg-locs env) nil))
-	  ((reference-tn-list locs t))
-	  "<save info>"
-	  (ir2-environment-return-pc-pass env)
-	  start)
-    (mapc #'(lambda (from to)
-	      (unless (eq from to)
-		(emit-move node block from to)))
-	  locs temps)
-    (move-continuation-result node block temps cont))
-  (undefined-value))
-
-
-;;; IR2-Convert-Local-Unknown-Call  --  Internal
-;;;
-;;;    Handle a non-TR unknown-values local call.  We do different things
-;;; depending on what kind of values the continuation wants.
-;;;
-;;;    If Cont is :Unkown, then we use the "Multiple-" variant, directly
-;;; specifying the continuation's Locs as the VOP results so that we don't have
-;;; to do anything after the call.
-;;;
-;;;    Otherwise, we use Standard-Result-Tns to get wired result TNs, and
-;;; then call Move-Continuation-Result to do any necessary type checks or
-;;; coercions.
-;;;
-(defun ir2-convert-local-unknown-call (node block env cont start)
-  (declare (type node node) (type ir2-block block) (type ir2-environment env)
-	   (type continuation cont) (type label start))
-  (let ((2cont (continuation-info cont))
-	(old-cont (ir2-environment-old-cont-pass env))
-	(argp (ir2-environment-argument-pointer env))
-	(return-pc (ir2-environment-return-pc-pass env))
-	(arg-locs (reference-tn-list (ir2-environment-arg-locs env) nil)))
-    (if (and 2cont (eq (ir2-continuation-kind 2cont) :unknown))
-	(vop* multiple-call-local node block (old-cont argp arg-locs)
-	      ((reference-tn-list (ir2-continuation-locs 2cont) t))
-	      "<save info>" return-pc start)
-	(let ((temps (standard-result-tns cont)))
-	  (vop* call-local node block
-		(old-cont argp arg-locs)
-		((reference-tn-list temps t))
-		"<save info>" return-pc start (length temps))
-	  (move-continuation-result node block temps cont))))
-  (undefined-value))
-
-
-;;; IR2-Convert-Local-Normal-Call  --  Internal
-;;;
-;;;    This function handles non-tail-recursive local call.  We move the
-;;; arguments into the passing locations and then look at return conventions
-;;; and think about how we are going to get the values back.
-;;;
-(defun ir2-convert-local-normal-call (node block fun)
-  (let* ((env (environment-info (lambda-environment fun)))
-	 (start (block-label (node-block (lambda-bind fun))))
-	 (returns (tail-set-info (lambda-tail-set fun)))
-	 (cont (node-cont node)))
-    (move-local-call-args node block fun)
-    (vop current-cont node block (ir2-environment-old-cont-pass env))
-    (vop current-cont node block (ir2-environment-argument-pointer env))
-    (ecase (return-info-kind returns)
-      (:unknown
-       (ir2-convert-local-unknown-call node block env cont start))
-      (:fixed
-       (ir2-convert-local-known-call node block env returns cont start))))
-  (undefined-value))
-
-
-;;; IR2-Convert-Local-Call  --  Internal
-;;;
-;;;    Dispatch to the appropriate function, depending on whether we have a
-;;; let, tail or normal call.
-;;;
-(defun ir2-convert-local-call (node block)
-  (declare (type combination node) (type ir2-block block))
-  (let ((fun (ref-leaf (continuation-use (basic-combination-fun node)))))
-    (cond ((eq (functional-kind fun) :let)
-	   (ir2-convert-let node block fun))
-	  ((node-tail-p node)
-	   (ir2-convert-tail-local-call node block fun))
-	  (t
-	   (ir2-convert-local-normal-call node block fun))))
-  (undefined-value))
-
-
-;;;; Full call:
-
-
-;;; Function-Continuation-TN  --  Internal
-;;;
-;;;    Given a function continuation Fun, return as values a TN holding the
-;;; thing that we call and true if the thing is a symbol (false if it is a
-;;; function).
-;;;
-(defun function-continuation-tn (node block cont)
-  (declare (type continuation cont))
-  (let* ((2cont (continuation-info cont))
-	 (name (if (eq (ir2-continuation-kind 2cont) :delayed)
-		   (let ((res (continuation-function-name cont)))
-		     (assert res)
-		     res)
-		   nil)))
-    (if name
-	(values (emit-constant name) t)
-	(let ((locs (ir2-continuation-locs 2cont))
-	      (type (ir2-continuation-primitive-type 2cont)))
-	  (assert (and (eq (ir2-continuation-kind 2cont) :fixed)
-		       (= (length locs) 1)))
-	  (if (eq (primitive-type-name type) 'function)
-	      (values (first locs) nil)
-	      (let ((temp (make-normal-tn *any-primitive-type*)))
-		(when (policy node (> speed brevity))
-		  (let ((*compiler-error-context* node))
-		    (compiler-note "Called function might be a symbol, so ~
-		                    must coerce at run-time.")))
-		(vop coerce-to-function node block (first locs) temp)
-		(values temp nil)))))))
-
-
-;;; Move-Full-Call-Args  --  Internal
-;;;
-;;;    Set up the arguments to a full call in the appropriate passing
-;;; locations.  Returns the head of a TN-Ref list to the passing locations.
-;;;
-(defun move-full-call-args (node block)
-  (declare (type combination node) (type ir2-block block))
-  (let ((args (basic-combination-args node))
-	(last nil)
-	(first nil))
-    (dotimes (num (length args))
-      (let ((loc (standard-argument-location num)))
-	(emit-move node block (continuation-tn node block (elt args num)) loc)
-	(let ((ref (reference-tn loc nil)))
-	  (if last
-	      (setf (tn-ref-across last) ref)
-	      (setf first ref))
-	  (setq last ref))))
-      first))
-
-
-;;; IR2-Convert-Tail-Full-Call  --  Internal
-;;;
-;;;    Move the arguments into the passing locations and do a (possibly named)
-;;; tail call.  We flush the tail control transfer so that nobody thinks that
-;;; we return.
-;;;
-(defun ir2-convert-tail-full-call (node block)
-  (declare (type combination node) (type ir2-block block))
-  (let* ((pass-refs (move-full-call-args node block))
-	 (env (environment-info (node-environment node)))
-	 (old-cont (ir2-environment-old-cont env))
-	 (return-pc (ir2-environment-return-pc env))
-	 (nargs (length (basic-combination-args node))))
-    (multiple-value-bind
-	(fun-tn named)
-	(function-continuation-tn node block (basic-combination-fun node))
-      (if named
-	  (vop* tail-call-named node block
-		(fun-tn old-cont return-pc pass-refs)
-		(nil)
-		nargs)
-	  (vop* tail-call node block
-		(fun-tn old-cont return-pc pass-refs)
-		(nil)
-		nargs))))
-  (flush-tail-transfer node block)
-  (undefined-value))
-
-
-;;; IR2-Convert-Fixed-Full-Call  --  Internal
-;;;
-;;;    Do full call when a fixed number of values are desired.  We make
-;;; Standard-Result-TNs for our continuation, then deliver the result using
-;;; Move-Continuation-Result.  We do named or normal call, as appropriate.
-;;;
-(defun ir2-convert-fixed-full-call (node block)
-  (declare (type combination node) (type ir2-block block))
-  (let* ((nargs (length (basic-combination-args node)))
-	 (pass-refs (move-full-call-args node block))
-	 (cont (node-cont node))
-	 (locs (standard-result-tns cont))
-	 (loc-refs (reference-tn-list locs t))
-	 (nvals (length locs)))
-    (multiple-value-bind
-	(fun-tn named)
-	(function-continuation-tn node block (basic-combination-fun node))
-      (if named
-	  (vop* call-named node block (fun-tn pass-refs) (loc-refs)
-		"<save info>" nargs nvals)
-	  (vop* call node block (fun-tn pass-refs) (loc-refs)
-		"<save info>" nargs nvals))
-      (move-continuation-result node block locs cont)))
-  (undefined-value))
-
-
-;;; IR2-Convert-Multiple-Full-Call  --  Internal
-;;;
-;;;    Do full call when unknown values are desired.
-;;;
-(defun ir2-convert-multiple-full-call (node block)
-  (declare (type combination node) (type ir2-block block))
-  (let* ((nargs (length (basic-combination-args node)))
-	 (pass-refs (move-full-call-args node block))
-	 (cont (node-cont node))
-	 (locs (ir2-continuation-locs (continuation-info cont)))
-	 (loc-refs (reference-tn-list locs t)))
-    (multiple-value-bind
-	(fun-tn named)
-	(function-continuation-tn node block (basic-combination-fun node))
-      (if named
-	  (vop* multiple-call-named node block (fun-tn pass-refs) (loc-refs)
-		"<save info>" nargs)
-	  (vop* multiple-call node block (fun-tn pass-refs) (loc-refs)
-		"<save info>" nargs))))
-  (undefined-value))
-
-
-;;; IR2-Convert-Full-Call  --  Internal
-;;;
-;;;    If the call is in a TR position and the return convention is standard,
-;;; then do a full call.  If one or fewer values are desired, then use a
-;;; single-value call, otherwise use a multiple-values call.
-;;;
-(defun ir2-convert-full-call (node block)
-  (declare (type combination node) (type ir2-block block))
-  (let ((2cont (continuation-info (node-cont node))))
-    (cond ((let ((tails (node-tail-p node)))
-	     (and tails
-		  (eq (return-info-kind (tail-set-info tails)) :unknown)))
-	   (ir2-convert-tail-full-call node block))
-	  ((and 2cont
-		(eq (ir2-continuation-kind 2cont) :unknown))
-	   (ir2-convert-multiple-full-call node block))
-	  (t
-	   (ir2-convert-fixed-full-call node block))))
-  (undefined-value))
-
-
-;;;; Function entry:
-
-;;; Init-XEP-Environment  --  Internal
-;;;
-;;;    Do all the stuff that needs to be done on XEP entry:
-;;; -- Create frame
-;;; -- Copy any more arg
-;;; -- Set up the environment, accessing any closure variables
-;;; 
-(defun init-xep-environment (node block fun)
-  (declare (type bind node) (type ir2-block block) (type clambda fun))
-  (vop allocate-frame node block)
-  (let ((ef (functional-entry-function fun)))
-    (when (and (optional-dispatch-p ef)
-	       (optional-dispatch-more-entry ef))
-      (vop copy-more-arg node block (optional-dispatch-max-args ef))))
-
-  (let ((env (environment-info (node-environment node))))
-    (if (ir2-environment-environment env)
-	(let ((closure (make-normal-tn *any-primitive-type*)))
-	  (vop setup-closure-environment node block closure)
-	  (let ((n (1- system:%function-closure-variables-offset)))
-	    (dolist (loc (ir2-environment-environment env))
-	      (vop closure-ref node block closure (incf n) (cdr loc)))))
-	(vop setup-environment node block)))
-
-  (undefined-value))
-
-
-;;; IR2-Convert-Bind  --  Internal
-;;;
-;;;    Emit moves from the passing locations to the internal locations.  This
-;;; is only called on bind nodes for functions that allocate environments.  All
-;;; semantics of let calls are handled by IR2-Convert-Let.
-;;;
-;;;    We special-case XEPs by calling Init-XEP-Environment before moving the
-;;; arguments.  Init-XEP-Environment accesses any environment values from the
-;;; closure, so initialization of the environment from implicit arguments is
-;;; suppressed.
-;;;
-(defun ir2-convert-bind (node block)
-  (declare (type bind node) (type ir2-block block))
-  (let* ((fun (bind-lambda node))
-	 (xep-p (external-entry-point-p fun))
-	 (env (environment-info (lambda-environment fun)))
-	 (argp (ir2-environment-argument-pointer env))
-	 (args (ir2-environment-arg-locs env)))
-    (assert (member (functional-kind fun)
-		    '(nil :external :optional :top-level :cleanup)))
-
-    (when xep-p
-      (init-xep-environment node block fun))
-
-    (dolist (arg (lambda-vars fun))
-      (when (leaf-refs arg)
-	(let ((pass (pop args))
-	      (home (leaf-info arg)))
-	  (if (lambda-var-indirect arg)
-	      (let ((temp (make-normal-tn *any-primitive-type*)))
-		(move-from-frame node block pass temp argp)
-		(vop make-value-cell node block temp home))
-	      (move-from-frame node block pass home argp)))))
-
-    (unless xep-p
-      (dolist (loc (ir2-environment-environment env))
-	(move-from-frame node block (pop args) (cdr loc) argp)))
-    
-    (when (ir2-environment-old-cont env)
-      (move-from-frame node block (ir2-environment-old-cont-pass env)
-		       (ir2-environment-old-cont env) argp))
-    
-    (when (ir2-environment-return-pc env)
-      (move-from-frame node block (ir2-environment-return-pc-pass env)
-		       (ir2-environment-return-pc env) argp)))
-  
-  (undefined-value))
-
-
-;;;; Function return:
-
-;;; IR2-Convert-Return  --  Internal
-;;;
-(defun ir2-convert-return (node block)
-  (let ((cont (continuation-info (return-result node))))
-    (unless (eq (ir2-continuation-kind cont) :unused)
-      (emit-return-for-locs node block
-			    (ir2-continuation-kind cont)
-			    (ir2-continuation-locs cont))))
-  (undefined-value))
-
-
-;;; Emit-Return-For-Locs  --  Internal
-;;;
-;;;    Do stuff to return from a function with the specified values and
-;;; convention.  Node must the Return node that we are doing a return for.
-;;; The reason that this is broken off from IR2-Convert-Return in this curious
-;;; way is that when all uses of the result are tail-recursive, we annotate the
-;;; result continuation as :Unused and then emit a return at each use of the
-;;; result.
-;;;
-;;;    If the return convention is :Fixed and we aren't returning from an XEP,
-;;; then we move the return values to the passing locs and do a Known-Return.
-;;; Otherwise, we use the unknown-values convention.  If there is a fixed
-;;; number of return values, then use Return, otherwise use Return-Multiple.
-;;;
-(defun emit-return-for-locs (node block cont-kind cont-locs)
-  (declare (type creturn node) (type ir2-block block)
-	   (type (member :fixed :unknown) cont-kind)
-	   (list cont-locs))
-  (let* ((fun (return-lambda node))
-	 (env (environment-info (lambda-environment fun)))
-	 (old-cont (ir2-environment-old-cont env))
-	 (return-pc (ir2-environment-return-pc env))
-	 (returns (tail-set-info (lambda-tail-set fun))))
-    (cond
-     ((and (eq (return-info-kind returns) :fixed)
-	   (not (external-entry-point-p fun)))
-      (let ((locs (return-info-locations returns)))
-	(mapc #'(lambda (from to)
-		  (move-to-frame node block from to old-cont))
-	      cont-locs locs)
-	(vop* known-return node block
-	      (old-cont return-pc (reference-tn-list locs nil))
-	      (nil))))
-     ((eq cont-kind :fixed)
-      (let* ((nvals (length cont-locs))
-	     (locs (make-standard-value-tns nvals)))
-	(mapc #'(lambda (val loc)
-		  (emit-move node block val loc))
-	      cont-locs
-	      locs)
-	(vop* return node block
-	      (old-cont return-pc (reference-tn-list locs nil))
-	      (nil)
-	      nvals)))
-     (t
-      (assert (eq cont-kind :unknown))
-      (vop* return-multiple node block
-	    (old-cont return-pc (reference-tn-list cont-locs nil))
-	    (nil)))))
-
-  (undefined-value))
-
-
-;;;; Multiple values:
-
-;;; IR2-Convert-MV-Bind  --  Internal
-;;;
-;;;    Almost identical to IR2-Convert-Let.  Since LTN annotates the
-;;; continuation for the correct number of values (with the continuation user
-;;; responsible for defaulting), we can just pick them up from the
-;;; continuation.
-;;;
-(defun ir2-convert-mv-bind (node block)
-  (declare (type mv-combination node) (type ir2-block block))
-  (let ((cont (continuation-info (first (basic-combination-args node))))
-	(fun (ref-leaf (continuation-use (basic-combination-fun node)))))
-    (assert (eq (functional-kind fun) :mv-let))
-  (mapc #'(lambda (src var)
-	    (when (leaf-refs var)
-	      (let ((dest (leaf-info var)))
-		(if (lambda-var-indirect var)
-		    (vop make-value-cell node block src dest)
-		    (emit-move node block src dest)))))
-	(ir2-continuation-locs cont) (lambda-vars fun)))
-  (undefined-value))
-
-
-;;; IR2-Convert-MV-Call  --  Internal
-;;;
-;;;    Emit the appropriate fixed value, unknown value or tail variant of
-;;; Call-Variable.  Note that we only need to pass the values start for the
-;;; first argument: all the other argument continuation TNs are ignored.  This
-;;; is because we require all of the values globs to be contiguous and on stack
-;;; top. 
-;;;
-(defun ir2-convert-mv-call (node block)
-  (declare (type mv-combination node) (type ir2-block block))
-  (assert (basic-combination-args node))
-  (let* ((start-cont (continuation-info (first (basic-combination-args node))))
-	 (start (first (ir2-continuation-locs start-cont)))
-	 (tails (node-tail-p node))
-	 (cont (node-cont node))
-	 (2cont (continuation-info cont)))
-    (multiple-value-bind
-	(fun named)
-	(function-continuation-tn node block (basic-combination-fun node))
-      (assert (and (not named)
-		   (eq (ir2-continuation-kind start-cont) :unknown)))
-      (cond
-       ((and tails
-	     (eq (return-info-kind (tail-set-info tails)) :unknown))
-	(let ((env (environment-info (node-environment node))))
-	  (vop tail-call-variable node block fun
-	       (ir2-environment-old-cont env)
-	       (ir2-environment-return-pc env)
-	       start))
-	(flush-tail-transfer node block))
-       ((and 2cont
-	     (eq (ir2-continuation-kind 2cont) :unknown))
-	(vop* multiple-call-variable node block (fun start nil)
-	      ((reference-tn-list (ir2-continuation-locs 2cont) t))
-	      "<save info>"))
-       (t
-	(let ((locs (standard-result-tns cont)))
-	  (vop* call-variable node block (fun start nil)
-		((reference-tn-list locs t))
-		"<save info>" (length locs))
-	  (move-continuation-result node block locs cont)))))))
-
-
-;;; %Pop-Values IR2 convert  --  Internal
-;;;
-;;;    Reset the stack pointer to the start of the specified unknown-values
-;;; continuation (discarding it and all values globs on top of it.)
-;;;
-(defoptimizer (%pop-values ir2-convert) ((continuation) node block)
-  (let ((2cont (continuation-info (continuation-value continuation))))
-    (assert (eq (ir2-continuation-kind 2cont) :unknown))
-    (vop reset-stack-pointer node block
-	 (first (ir2-continuation-locs 2cont)))))
-
-
-;;; Values IR2 convert  --  Internal
-;;;
-;;;    Deliver the values TNs to Cont using Move-Continuation-Result.
-;;;
-(defoptimizer (values ir2-convert) ((&rest values) node block)
-  (let ((tns (mapcar #'(lambda (x)
-			 (continuation-tn node block x))
-		     values)))
-    (move-continuation-result node block tns (node-cont node))))
-
-
-;;; Values-List IR2 convert  --  Internal
-;;;
-;;;    In the normal case where unknown values are desired, we use the
-;;; Values-List VOP.  If the continuation is :Unused (a TR result
-;;; continuation), then we must compute the values into temporaries and then do
-;;; an Emit-Return-For-Locs and flush the tail control transfer.
-;;;
-;;;    In the relatively unimportant case of Values-List for a fixed number of
-;;; values, we punt by doing a full call to the Values-List function.  This
-;;; gets the full call VOP to deal with defaulting any unsupplied values.  It
-;;; seems unworthwhile to optimize this case.
-;;;
-(defoptimizer (values-list ir2-convert) ((list) node block)
-  (let* ((cont (node-cont node))
-	 (2cont (continuation-info cont)))
-    (when 2cont
-      (let ((kind (ir2-continuation-kind 2cont)))
-	(if (eq kind :fixed)
-	    (ir2-convert-full-call node block)
-	    (let ((locs (ecase kind
-			  (:unknown (ir2-continuation-locs 2cont))
-			  (:unused (make-unknown-values-locations)))))
-	      (vop* values-list node block
-		    ((continuation-tn node block list) nil)
-		    ((reference-tn-list locs t)))
-	      (when (eq kind :unused)
-		(emit-return-for-locs (continuation-dest cont) block :unknown
-				      locs)
-		(flush-tail-transfer node block))))))))
-
-
-;;;; Special binding:
-
-;;; %Special-Bind, %Special-Unbind IR2 convert  --  Internal
-;;;
-;;;    Trivial, given our assumption of a shallow-binding implementation.
-;;;
-(defoptimizer (%special-bind ir2-convert) ((var value) node block)
-  (let ((name (leaf-name (continuation-value var))))
-    (vop bind node block (continuation-tn node block value)
-	 (emit-constant name))))
-;;;
-(defoptimizer (%special-unbind ir2-convert) ((var) node block)
-  (vop unbind node block (emit-constant 1)))
-
-
-;;; PROGV IR1 convert  --  Internal
-;;;
-;;; ### Not clear that this really belongs in this file, or should really be
-;;; done this way, but this is the least violation of abstraction in the
-;;; current setup.  We don't want to wire shallow-binding assumptions into
-;;; IR1tran.
-;;;
-(def-ir1-translator progv ((vars vals &body body) start cont)
-  (ir1-convert
-   start cont
-   (if *converting-for-interpreter*
-       `(%progv ,vars ,vals #'(lambda () ,@body))
-       (once-only ((n-save-bs '(%primitive current-binding-pointer)))
-	 `(unwind-protect
-	      (progn
-		(mapc #'(lambda (var val)
-			  (%primitive bind val var))
-		      ,vars
-		      ,vals)
-		,@body)
-	    (%primitive unbind-to-here ,n-save-bs))))))
-
-
-;;;; Non-local exit:
-
-;;; IR2-Convert-Exit  --  Internal
-;;;
-;;;    Convert a non-local lexical exit.  First find the NLX-Info in our
-;;; environment.  After indirecting the value cell, we invalidate the exit by
-;;; setting the cell to 0.  Note that this is never called on the escape exits
-;;; for Catch and Unwind-Protect, since the escape functions aren't IR2
-;;; converted.
-;;;
-(defun ir2-convert-exit (node block)
-  (declare (type exit node) (type ir2-block block))
-  (let ((loc (find-in-environment (find-nlx-info (exit-entry node)
-						 (node-cont node))
-				  (node-environment node)))
-	(temp (make-normal-tn *any-primitive-type*))
-	(value (exit-value node)))
-    (vop value-cell-ref node block loc temp)
-    (vop value-cell-set node block loc (emit-constant 0))
-    (if value
-	(let ((locs (ir2-continuation-locs (continuation-info value))))
-	  (vop unwind node block temp (first locs) (second locs)))
-	(let ((0-tn (emit-constant 0)))
-	  (vop unwind node block temp 0-tn 0-tn))))
-
-  (undefined-value))
-
-
-;;; This function invalidates a lexical exit on exiting from the dynamic
-;;; extent.  This is done by storing 0 into the indirect value cell that holds
-;;; the closed unwind block.
-;;;
-(defoptimizer (%lexical-exit-breakup ir2-convert) ((info) node block)
-  (vop value-cell-set node block
-       (find-in-environment (continuation-value info) (node-environment node))
-       (emit-constant 0)))
-
-
-;;; IR2-Convert-Throw  --  Internal
-;;;
-;;;    We have to do a spurious move of no values to the result continuation so
-;;; that lifetime analysis won't get confused.
-;;;
-(defun ir2-convert-throw (node block)
-  (declare (type mv-combination node) (type ir2-block block))
-  (let ((args (basic-combination-args node)))
-    (vop* throw node block
-	  ((continuation-tn node block (first args))
-	   (reference-tn-list
-	    (ir2-continuation-locs (continuation-info (second args)))
-	    nil))
-	  (nil)))
-
-  (move-continuation-result node block () (node-cont node))
-  (undefined-value))
-
-
-;;; Emit-NLX-Start  --  Internal
-;;;
-;;;    Emit code to set up a non-local-exit.  Info is the NLX-Info for the
-;;; exit, and Tag is the continuation for the catch tag (if any.)  We get at
-;;; the entry PC by making a :Label load-time constant TN.  This is a
-;;; non-immediate constant TN that is initialized to the offset of the
-;;; specified label.
-;;;
-(defun emit-nlx-start (node block info tag)
-  (declare (type node node) (type ir2-block block) (type nlx-info info)
-	   (type (or continuation null) tag))
-  (let* ((2info (nlx-info-info info))
-	 (kind (cleanup-kind (nlx-info-cleanup info)))
-	 (block-tn (make-environment-tn (primitive-type-or-lose 'catch-block)
-					(node-environment node)))
-	 (res (make-normal-tn *any-primitive-type*))
-	 (target-tn
-	  (make-load-time-constant-tn
-	   :label
-	   (block-label (nlx-info-target info)))))
-
-    (vop* save-dynamic-state node block
-	  (nil)
-	  ((reference-tn-list (ir2-nlx-info-dynamic-state 2info) t)))
-    (vop current-stack-pointer node block (ir2-nlx-info-save-sp 2info))
-
-    (ecase kind
-      (:catch
-       (vop make-catch-block node block block-tn
-	    (continuation-tn node block tag) target-tn res))
-      ((:unwind-protect :entry)
-       (vop make-unwind-block node block block-tn target-tn res)))
-
-    (ecase kind
-      (:entry
-       (vop make-value-cell node block res (ir2-nlx-info-home 2info)))
-      (:unwind-protect
-       (vop set-unwind-protect node block block-tn))
-      (:catch)))
-
-  (undefined-value))
-
-
-;;; IR2-Convert-Entry  --  Internal
-;;;
-;;;    Scan each of Entry's exits, setting up the exit for each lexical exit.
-;;;
-(defun ir2-convert-entry (node block)
-  (declare (type entry node) (type ir2-block block))
-  (dolist (exit (entry-exits node))
-    (let ((info (find-nlx-info node exit)))
-      (when (and info (eq (cleanup-kind (nlx-info-cleanup info)) :entry))
-	(emit-nlx-start node block info nil)
-	(return))))
-  (undefined-value))
-
-
-;;; %Catch, %Unwind-Protect IR2 convert  --  Internal
-;;;
-;;;    Set up the unwind block for these guys.
-;;;
-(defoptimizer (%catch ir2-convert) ((info-cont tag) node block)
-  (emit-nlx-start node block (continuation-value info-cont) tag))
-;;;
-(defoptimizer (%unwind-protect ir2-convert) ((info-cont cleanup) node block)
-  (emit-nlx-start node block (continuation-value info-cont) nil))
-
-
-;;; %NLX-Entry IR2 convert  --  Internal
-;;;
-;;; Emit the entry code for a non-local exit.  We receive values and restore
-;;; dynamic state.
-;;;
-;;; In the case of a lexical exit or Catch, we look at the exit continuation's
-;;; kind to determine which flavor of entry VOP to emit.  If unknown values,
-;;; emit the xxx-MULTIPLE variant to the continuation locs.  If fixed values,
-;;; make the appropriate number of temps in the standard values locations and
-;;; use the other variant, delivering the temps to the continuation using
-;;; Move-Continuation-Result.
-;;;
-;;; In the Unwind-Protect case, we deliver move the first register argument,
-;;; the argument count and the argument pointer to our continuation as multiple
-;;; values.  These values are the block exited to and the values start and
-;;; count.
-;;;
-;;; After receiving values, we restore dynamic state.  Except in the
-;;; Unwind-Protect case, the values receiving restores the stack pointer.  In
-;;; an Unwind-Protect cleanup, we want to leave the stack pointer alone, since
-;;; the thrown values are still out there.
-;;;
-(defoptimizer (%nlx-entry ir2-convert) ((info-cont) node block)
-  (let* ((info (continuation-value info-cont))
-	 (cont (nlx-info-continuation info))
-	 (2cont (continuation-info cont))
-	 (2info (nlx-info-info info))
-	 (top-loc (ir2-nlx-info-save-sp 2info))
-	 (start-loc (make-argument-pointer-location t))
-	 (count-loc (make-argument-count-location)))
-
-    (ecase (cleanup-kind (nlx-info-cleanup info))
-      ((:catch :entry)
-       (if (and 2cont (eq (ir2-continuation-kind 2cont) :unknown))
-	   (vop* nlx-entry-multiple node block
-		 (top-loc start-loc count-loc nil)
-		 ((reference-tn-list (ir2-continuation-locs 2cont) t)))
-	   (let ((locs (standard-result-tns cont)))
-	     (vop* nlx-entry node block
-		   (top-loc start-loc count-loc nil)
-		   ((reference-tn-list locs t))
-		   (length locs))
-	     (move-continuation-result node block locs cont))))
-      (:unwind-protect
-       (let ((block-loc (standard-argument-location 0)))
-	 (vop uwp-entry node block block-loc start-loc count-loc)
-	 (move-continuation-result
-	  node block
-	  (list block-loc start-loc count-loc)
-	  cont))))
-
-    (vop* restore-dynamic-state node block
-	  ((reference-tn-list (ir2-nlx-info-dynamic-state 2info) nil))
-	  (nil))))
-	    
-
-;;;; N-arg functions:
-
-(macrolet ((frob (name)
-	     `(defoptimizer (,name ir2-convert) ((&rest args) node block)
-		(let* ((refs (move-full-call-args node block))
-		       (cont (node-cont node))
-		       (res (continuation-result-tns
-			     cont
-			     (list (primitive-type (specifier-type 'list))))))
-		  (vop* ,name node block
-			(refs)
-			((first res) nil)
-			(length args))
-		  (move-continuation-result node block res cont)))))
-  (frob list)
-  (frob list*))
-
-
-;;;; Structure accessors:
-;;;
-;;;    These guys have to bizarrely determine the slot offset by looking at the
-;;; called function.
-
-(defoptimizer (%slot-accessor ir2-convert) ((str) node block)
-  (let* ((cont (node-cont node))
-	 (res (continuation-result-tns cont (list *any-primitive-type*))))
-    (vop structure-ref node block
-	 (continuation-tn node block str)
-	 (dsd-index
-	  (slot-accessor-slot
-	   (ref-leaf
-	    (continuation-use
-	     (combination-fun node)))))
-	 (first res))
-    (move-continuation-result node block res cont)))
-
-(defoptimizer (%slot-setter ir2-convert) ((str value) node block)
-  (let ((val (continuation-tn node block value)))
-    (vop structure-set node block
-	 (continuation-tn node block str)
-	 val
-	 (dsd-index
-	  (slot-accessor-slot
-	   (ref-leaf
-	    (continuation-use
-	     (combination-fun node))))))
-  
-    (move-continuation-result node block (list val) (node-cont node))))
-
-
-;;; IR2-Convert  --  Interface
-;;;
-;;;    Convert the code in a component into VOPs.
-;;;
-(defun ir2-convert (component)
-  (declare (type component component))
-  (do-blocks (block component)
-    (ir2-convert-block block))
-  (undefined-value))
-
-
-;;; Finish-IR2-Block  --  Internal
-;;;
-;;;    If necessary, emit a terminal unconditional branch to go to the
-;;; successor block.  When there is a deleted tail control transfer, no branch
-;;; is necessary.
-;;;
-(defun finish-ir2-block (block)
-  (declare (type cblock block))
-  (let* ((2block (block-info block))
-	 (last (block-last block))
-	 (succ (block-succ block)))
-    (unless (or (if-p last) (return-p last)
-		(and (null succ)
-		     (or (node-tail-p last)
-			 (exit-p last))))
-      (assert (and succ (null (rest succ))))
-      (let ((target (first succ)))
-	(unless (eq (ir2-block-next 2block) (block-info target))
-	  (vop branch last 2block (block-label target))))))
-  (undefined-value))
-
-
-;;; IR2-Convert-Block  --  Internal
-;;;
-;;;    Convert the code in a block into VOPs.
-;;;
-(defun ir2-convert-block (block)
-  (declare (type cblock block))
-  (let ((2block (block-info block)))
-    (do-nodes (node cont block)
-      (etypecase node
-	(ref
-	 (let ((2cont (continuation-info cont)))
-	   (when (and 2cont
-		      (not (eq (ir2-continuation-kind 2cont) :delayed)))
-	     (ir2-convert-ref node 2block))))
-	(combination
-	 (let ((kind (basic-combination-kind node)))
-	   (case kind
-	     (:local
-	      (ir2-convert-local-call node 2block))
-	     (:full
-	      (ir2-convert-full-call node 2block))
-	     (t
-	      (let ((fun (function-info-ir2-convert kind)))
-		(cond (fun
-		       (funcall fun node 2block))
-		      ((basic-combination-info node)
-		       (ir2-convert-template node 2block))
-		      (t
-		       (ir2-convert-full-call node 2block))))))))
-	(cif
-	 (when (continuation-info (if-test node))
-	   (ir2-convert-if node 2block)))
-	(bind
-	 (let ((fun (bind-lambda node)))
-	   (when (eq (lambda-home fun) fun)
-	     (ir2-convert-bind node 2block))))
-	(creturn
-	 (ir2-convert-return node 2block))
-	(cset
-	 (ir2-convert-set node 2block))
-	(mv-combination
-	 (cond
-	  ((eq (basic-combination-kind node) :local)
-	   (ir2-convert-mv-bind node 2block))
-	  ((eq (continuation-function-name (basic-combination-fun node))
-	       '%throw)
-	   (ir2-convert-throw node 2block))
-	  (t
-	   (ir2-convert-mv-call node 2block))))
-	(exit
-	 (when (exit-entry node)
-	   (ir2-convert-exit node 2block)))
-	(entry
-	 (ir2-convert-entry node 2block)))))
-
-  (finish-ir2-block block)
-
-  (undefined-value))
diff --git a/compiler/knownfun.lisp b/compiler/knownfun.lisp
deleted file mode 100644
index df9b9b5e371d9fe7a40f6eb6ef744e28783a2fd7..0000000000000000000000000000000000000000
--- a/compiler/knownfun.lisp
+++ /dev/null
@@ -1,165 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    This file contains stuff for maintaining a database of special
-;;; information about functions known to the compiler.  This includes semantic
-;;; information such as side-effects and type inference functions as well as
-;;; transforms and IR2 translators.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-
-;;;; IR1 boolean function attributes:
-;;;
-;;;    There are a number of boolean attributes of known functions which we
-;;; like to have in IR1.  This information is mostly side effect information of
-;;; a sort, but it is different from the kind of information we want in IR2.
-;;; We aren't interested in a fine breakdown of side effects, since we do very
-;;; little code motion on IR1.  We are interested in some deeper semantic
-;;; properties such as whether it is safe to pass stack closures to.
-;;;
-(def-boolean-attribute ir1
-  ;;
-  ;; May call functions that are passed as arguments.  In order to determine
-  ;; what other effects are present, we must find the effects of all arguments
-  ;; that may be functions.
-  call
-  ;;
-  ;; May incorporate arguments in the result or somehow pass them upward.
-  unsafe
-  ;;
-  ;; May fail to return during correct execution.  Errors are O.K.
-  unwind
-  ;;
-  ;; The (default) worst case.  Includes all the other bad things, plus any
-  ;; other possible bad thing.  If this is present, the above bad attributes
-  ;; will be explicitly present as well.
-  any
-  ;;
-  ;; May be constant-folded.  The function has no side effects, but may be
-  ;; affected by side effects on the arguments.  e.g. SVREF, MAPC.
-  foldable
-  ;;
-  ;; May be eliminated if value is unused.  The function has no side effects
-  ;; except possibly CONS.  If a function is defined to signal errors, then it
-  ;; is not flushable even if it is movable or foldable.
-  flushable
-  ;;
-  ;; May be moved with impunity.  Has no side effects except possibly CONS, and
-  ;; is affected only by its arguments.
-  movable
-  ;;
-  ;; Function is a true predicate likely to be open-coded.  Convert any
-  ;; non-conditional uses into (IF <pred> T NIL).
-  predicate)
-
-
-(defstruct (function-info
-	    (:print-function %print-function-info))
-  ;;
-  ;; Boolean attributes of this function.
-  (attributes nil :type attributes)
-  ;;
-  ;; The transforms for this function.  An alist of (Function-Type . Function),
-  ;; where Function-Type is the type that the call must have for Function to be
-  ;; an applicable transform.
-  (transforms () :type list)
-  ;;
-  ;; A function which computes the derived type for a call to this function by
-  ;; examining the arguments.  This is null when there is no special method for
-  ;; this function.
-  (derive-type nil :type (or function null))
-  ;;
-  ;; A function that does random unspecified code transformations by directly
-  ;; hacking the IR.  Returns true if further optimizations of the call
-  ;; shouldn't be attempted.
-  (optimizer nil :type (or function null))
-  ;;
-  ;; If true, a special-case LTN annotation method that is used in place of the
-  ;; standard type/policy template selection.  It may use arbitrary code to
-  ;; choose a template, decide to do a full call, or conspire with the
-  ;; IR2-Convert method to do almost anything.  The Combination node is passed
-  ;; as the argument.
-  (ltn-annotate nil :type (or function null))
-  ;;
-  ;; If true, the special-case IR2 conversion method for this function.  This
-  ;; deals with funny functions, and anything else that can't be handled using
-  ;; the template mechanism.  The Combination node and the IR2-Block are passed
-  ;; as arguments.
-  (ir2-convert nil :type (or function null))
-  ;;
-  ;; A list of all the templates that could be used to translate this function
-  ;; into IR2, sorted by increasing cost.
-  (templates nil :type list)
-  ;;
-  ;; If non-null, then this function is a unary type predicate for this type.
-  (predicate-type nil :type (or ctype null)))
-
-(defprinter function-info
-  (transforms :test transforms)
-  (derive-type :test derive-type)
-  (optimizer :test optimizer)
-  (ltn-annotate :test ltn-annotate)
-  (ir2-convert :test ir2-convert)
-  (templates :test templates)
-  (predicate-type :test predicate-type))
-
-
-;;;; Interfaces to defining macros:
-
-;;; %Deftransform  --  Internal
-;;;
-;;;    Grab the Function-Info and enter the function, replacing any old one
-;;; with the same type.
-;;;
-(proclaim '(function %deftransform (t list function)))
-(defun %deftransform (name type fun)
-  (let* ((ctype (specifier-type type))
-	 (info (function-info-or-lose name))
-	 (old (assoc ctype (function-info-transforms info) :test #'type=)))
-    (if old
-	(setf (cdr old) fun)
-	(push (cons ctype fun) (function-info-transforms info)))
-    name))
-
-
-;;; %Defknown  --  Internal
-;;;
-;;;    Make a function-info structure with the specified type, attributes and
-;;; optimizers.
-;;;
-(proclaim '(function %defknown (list list attributes &key (derive-type function)
-				     (optimizer function))))
-(defun %defknown (names type attributes &key derive-type optimizer)
-  (let ((ctype (specifier-type type))
-	(info (make-function-info :attributes attributes
-;				  :derive-type derive-type  Until database is fixed...
-				  :optimizer optimizer)))
-    (dolist (name names)
-      (setf (info function type name) ctype)
-      (setf (info function where-from name) :declared)
-      (setf (info function kind name) :function)
-      (setf (info function info name) info)))
-  names)
-
-
-;;; Function-Info-Or-Lose  --  Internal
-;;;
-;;;    Return the Function-Info for name or die trying.  Since this is used by
-;;; people who want to modify the info, and the info may be shared, we copy it.
-;;; We don't have to copy the lists, since each function that has generators or
-;;; transforms has already been through here.
-;;;
-(proclaim '(function function-info-or-lose (t) function-info))
-(defun function-info-or-lose (name)
-  (let ((old (info function info name)))
-    (unless old (error "~S is not a known function." name))
-    (setf (info function info name) (copy-function-info old))))
diff --git a/compiler/life.lisp b/compiler/life.lisp
deleted file mode 100644
index b1c8ef9d1c71eb73d9060b8f67041862891a0647..0000000000000000000000000000000000000000
--- a/compiler/life.lisp
+++ /dev/null
@@ -1,804 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    This file contains the lifetime analysis phase in the compiler.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-
-;;;; Utilities:
-
-;;; Add-Global-Conflict  --  Internal
-;;;
-;;;    Link in a global-conflicts structure for TN in Block with Number as the
-;;; LTN number.  The conflict is inserted in the per-TN Global-Conflicts thread
-;;; after the TN's Current-Conflict.  We change the Current-Conflict to point
-;;; to the new conflict.  Since we scan the blocks in reverse DFO, this list is
-;;; automatically built in order.  We have to actually scan the current
-;;; Global-TNs for the block in order to keep that thread sorted.
-;;;
-(defun add-global-conflict (kind tn block number)
-  (declare (type (member :read :write :read-only :live) kind)
-	   (type tn tn) (type ir2-block block)
-	   (type (or local-tn-number null) number))
-  (let ((new (make-global-conflicts kind tn block number)))
-    (let ((last (tn-current-conflict tn)))
-      (if last
-	  (shiftf (global-conflicts-tn-next new)
-		  (global-conflicts-tn-next last)
-		  new)
-	  (shiftf (global-conflicts-tn-next new)
-		  (tn-global-conflicts tn)
-		  new)))
-    (setf (tn-current-conflict tn) new)
-
-    (let ((global-num (tn-number tn)))
-      (do ((prev nil conf)
-	   (conf (ir2-block-global-tns block)
-		 (global-conflicts-next conf)))
-	  ((or (null conf)
-	       (> (tn-number (global-conflicts-tn conf)) global-num))
-	   (if prev
-	       (setf (global-conflicts-next prev) new)
-	       (setf (ir2-block-global-tns block) new))
-	   (setf (global-conflicts-next new) conf)))))
-  (undefined-value))
-
-
-;;; Reset-Current-Conflict  --  Internal
-;;;
-;;;    Reset the Current-Conflict slot in all packed TNs to point to the head
-;;; of the Global-Conflicts thread.
-;;;
-(defun reset-current-conflict (component)
-  (do-packed-tns (tn component)
-    (setf (tn-current-conflict tn) (tn-global-conflicts tn))))
-
-
-;;;; Pre-pass:
-
-;;; Convert-To-Global  --  Internal
-;;;
-;;;    Convert TN (currently local) to be a global TN, since we discovered that
-;;; it is referenced in more than one block.  We just add a global-conflicts
-;;; structure with a kind derived from the Kill and Live sets.
-;;;
-(defun convert-to-global (tn)
-  (declare (type tn tn))
-  (let ((block (tn-local tn))
-	(num (tn-local-number tn)))
-    (add-global-conflict
-     (if (zerop (sbit (ir2-block-written block) num))
-	 :read-only
-	 (if (zerop (sbit (ir2-block-live-out block) num))
-	     :write
-	     :read))
-     tn block num))
-  (undefined-value))
-
-
-;;; Find-Local-References  --  Internal
-;;;
-;;;    Scan all references to packed TNs in block.  We assign LTN numbers to
-;;; each referenced TN, and also build the Kill and Live sets that summarize
-;;; the references to each TN for purposes of lifetime analysis.
-;;;
-;;;    It is possible that we will run out of LTN numbers.  If this happens,
-;;; then we return the VOP that we were processing at the time we ran out,
-;;; otherwise we return NIL.
-;;;
-;;;    If a TN is referenced in more than one block, then we must represent
-;;; references using Global-Conflicts structures.  When we first see a TN, we
-;;; assume it will be local.  If we see a reference later on in a different
-;;; block, then we go back and fix the TN to global.
-;;;
-;;;    We must globalize TNs that have a block other than the current one in
-;;; their Local slot and have no Global-Conflicts.  The latter condition is
-;;; necessary because we always set Local and Local-Number when we process a
-;;; reference to a TN, even when the TN is already known to be global.
-;;;
-;;;    When we see reference to global TNs during the scan, we add the
-;;; global-conflict as :Read-Only, since we don't know the corrent kind until
-;;; we are done scanning the block.
-;;;
-(defun find-local-references (block)
-  (declare (type ir2-block block))
-  (let ((kill (ir2-block-written block))
-	(live (ir2-block-live-out block))
-	(tns (ir2-block-local-tns block)))
-    (let ((ltn-num (ir2-block-local-tn-count block)))
-      (do ((vop (ir2-block-last-vop block)
-		(vop-prev vop)))
-	  ((null vop))
-	(do ((ref (vop-refs vop) (tn-ref-next-ref ref)))
-	    ((null ref))
-	  (let* ((tn (tn-ref-tn ref))
-		 (local (tn-local tn))
-		 (kind (tn-kind tn)))
-	    (unless (or (eq kind :constant)
-			(eq kind :environment))
-	      (unless (eq local block)
-		(when (= ltn-num local-tn-limit)
-		  (return-from find-local-references vop))
-		(when local
-		  (unless (tn-global-conflicts tn)
-		    (convert-to-global tn))
-		  (add-global-conflict :read-only tn block ltn-num))
-		
-		(setf (tn-local tn) block)
-		(setf (tn-local-number tn) ltn-num)
-		(setf (svref tns ltn-num) tn)
-		(incf ltn-num))
-	      
-	      (let ((num (tn-local-number tn)))
-		(if (tn-ref-write-p ref)
-		    (setf (sbit kill num) 1  (sbit live num) 0)
-		    (setf (sbit live num) 1)))))))
-      
-      (setf (ir2-block-local-tn-count block) ltn-num)))
-  nil)
-
-
-;;; Init-Global-Conflict-Kind   --  Internal
-;;;
-;;;    Finish up the global conflicts for TNs referenced in Block according to
-;;; the local Kill and Live sets.
-;;;
-;;;    We set the kind for TNs already in the global-TNs.  If not written at
-;;; all, then is :Read-Only, the default.  Must have been referenced somehow,
-;;; or we wouldn't have conflicts for it.
-;;;
-;;;    We also iterate over all the local TNs, looking for TNs local to this
-;;; block that are still live at the block beginning, and thus must be global.
-;;; This case is only important when a TN is read in a block but not written in
-;;; any other, since otherwise the write would promote the TN to global.  But
-;;; this does happen with various passing-location TNs that are magically
-;;; written.  This also serves to propagate the lives of erroneously
-;;; uninitialized TNs so that consistency checks can detect them.
-;;;
-(defun init-global-conflict-kind (block)
-  (declare (type ir2-block block))
-  (let ((live (ir2-block-live-out block)))
-    (let ((kill (ir2-block-written block)))
-      (do ((conf (ir2-block-global-tns block)
-		 (global-conflicts-next conf)))
-	  ((null conf))
-	(let ((num (global-conflicts-number conf)))
-	  (unless (zerop (sbit kill num))
-	    (setf (global-conflicts-kind conf)
-		  (if (zerop (sbit live num))
-		      :write
-		      :read))))))
-    
-    (let ((ltns (ir2-block-local-tns block)))
-      (dotimes (i (ir2-block-local-tn-count block))
-	(let ((tn (svref ltns i)))
-	  (unless (or (eq tn :more)
-		      (tn-global-conflicts tn)
-		      (zerop (sbit live i)))
-	    (convert-to-global tn)))))))
-  
-  (undefined-value))
-
-
-(defevent split-ir2-block "Split an IR2 block to meet Local-TN-Limit.")
-
-;;; Split-IR2-Blocks  --  Internal
-;;;
-;;;    Move the code after the VOP Lose in 2block into its own block.  The
-;;; block is linked into the emit order following 2block.  Number is the block
-;;; number assigned to the new block.  We return the new block.
-;;;
-(defun split-ir2-blocks (2block lose number)
-  (declare (type ir2-block 2block) (type vop lose)
-	   (type unsigned-byte number))
-  (event split-ir2-block (vop-node lose))
-  (let ((new (make-ir2-block (ir2-block-block 2block)))
-	(new-start (vop-next lose)))
-    (setf (ir2-block-number new) number)
-    (add-to-emit-order new 2block)
-
-    (do ((vop new-start (vop-next vop)))
-	((null vop))
-      (setf (vop-block vop) new))
-    
-    (setf (ir2-block-start-vop new) new-start)
-    (shiftf (ir2-block-last-vop new) (ir2-block-last-vop 2block) lose)
-
-    (setf (vop-next lose) nil)
-    (setf (vop-prev new-start) nil)
-
-    new))
-
-
-;;; Clear-Lifetime-Info  --  Internal
-;;;
-;;;    Clear the global and local conflict info in Block so that we can
-;;; recompute it without any old cruft being retained.  It is assumed that all
-;;; LTN numbers are in use.
-;;;
-;;;    First we delete all the global conflicts.  The conflict we are deleting
-;;; must be the last in the TN's global-conflicts, but we must scan for it in
-;;; order to find the previous conflict.
-;;;
-;;;    Next, we scan the local TNs, nulling out the Local slot in all TNs with
-;;; no global conflicts.  This allows these TNs to be treated as local when we
-;;; scan the block again.
-;;;
-;;;    If there are conflicts, then we set Local to one of the conflicting
-;;; blocks.  This ensures that Local doesn't hold over Block as its value,
-;;; causing the subsequent reanalysis to think that the TN has already been
-;;; seen in that block.
-;;;
-;;;    This function must not be called on blocks that have :More TNs.
-;;;
-(defun clear-lifetime-info (block)
-  (declare (type ir2-block block))
-  (setf (ir2-block-local-tn-count block) 0)
-  
-  (do ((conf (ir2-block-global-tns block)
-	     (global-conflicts-next conf)))
-      ((null conf)
-       (setf (ir2-block-global-tns block) nil))
-    (let ((tn (global-conflicts-tn conf)))
-      (assert (eq (tn-current-conflict tn) conf))
-      (assert (null (global-conflicts-tn-next conf)))
-      (do ((current (tn-global-conflicts tn)
-		    (global-conflicts-tn-next current))
-	   (prev nil current))
-	  ((eq current conf)
-	   (if prev
-	       (setf (global-conflicts-tn-next prev) nil)
-	       (setf (tn-global-conflicts tn) nil))
-	   (setf (tn-current-conflict tn) prev)))))
-  
-  (fill (ir2-block-written block) 0)
-  (let ((ltns (ir2-block-local-tns block)))
-    (dotimes (i local-tn-limit)
-      (let ((tn (svref ltns i)))
-	(assert (not (eq tn :more)))
-	(let ((conf (tn-global-conflicts tn)))
-	  (setf (tn-local tn)
-		(if conf
-		    (global-conflicts-block conf)
-		    nil)))))))
-  
-  (undefined-value))
-
-
-;;; Coalesce-More-LTN-Numbers  --  Internal
-;;;
-;;;    This provides a panic mode for assigning LTN numbers when there is a VOP
-;;; with so many more operands that they can't all be assigned distinct
-;;; numbers.  When this happens, we recover by assigning all the more operands
-;;; the same LTN number.  We can get away with this, since all more args (and
-;;; results) are referenced simultaneously as far as conflict analysis is
-;;; concerned.
-;;;
-;;;     Block is the IR2-Block that the more VOP is at the end of.  Ops is the
-;;; full argument or result TN-Ref list.  Fixed is the types of the fixed
-;;; operands (used only to skip those operands.)
-;;;
-;;;     What we do is grab a LTN number, then make a :Read-Only global conflict
-;;; for each more operand TN.  We require that there be no existing global
-;;; conflict in Block for any of the operands.  Since conflicts must be cleared
-;;; before the first call, this only prohibits the same TN being used both as a
-;;; more operand and as any other operand to the same VOP.
-;;;
-;;;     We don't have to worry about getting the correct conflict kind, since
-;;; Init-Global-Conflict-Kind will fix things up.
-;;;
-;;;     We also set the Local and Local-Number slots in each TN.
-;;;
-(defun coalesce-more-ltn-numbers (block ops fixed)
-  (declare (type ir2-block block) (type tn-ref ops) (list fixed))
-  (let ((num (ir2-block-local-tn-count block)))
-    (assert (< num local-tn-limit))
-    (incf (ir2-block-local-tn-count block))
-    (setf (svref (ir2-block-local-tns block) num) :more)
-
-    (do ((op (do ((op ops (tn-ref-across op))
-		  (i 0 (1+ i)))
-		 ((= i (length fixed)) op))
-	     (tn-ref-across op)))
-	((null op))
-      (let ((tn (tn-ref-tn op)))
-	(assert
-	  (flet ((frob (refs)
-		   (do ((ref refs (tn-ref-next ref)))
-		       ((null ref) t)
-		     (when (and (eq (vop-block (tn-ref-vop ref)) block)
-				(not (eq ref op)))
-		       (return nil)))))
-	    (and (frob (tn-reads tn)) (frob (tn-writes tn))))
-	  () "More operand ~S used more than once in its VOP." op)
-	(assert (not (find-in #'global-conflicts-next tn
-			      (ir2-block-global-tns block)
-			      :key #'global-conflicts-tn)))
-
-	(add-global-conflict :read-only tn block num)
-	(setf (tn-local tn) block)
-	(setf (tn-local-number tn) num))))
-  (undefined-value))
-
-
-(defevent coalesce-more-ltn-numbers
-  "Coalesced LTN numbers for a more operand to meet Local-TN-Limit.")
-
-;;; Lifetime-Pre-Pass  --  Internal
-;;;
-;;;    Loop over the blocks in Component, assigning LTN numbers and recording
-;;; TN birth and death.  The only interesting action is when we run out of
-;;; local TN numbers while finding local references.
-;;;
-;;;    If we run out of LTN numbers while processing a VOP within the block,
-;;; then we just split off the VOPs we have successfully processed into their
-;;; own block.
-;;;
-;;;    If we run out of LTN numbers while processing the our first VOP (the
-;;; last in the block), then it must be the case that this VOP has large more
-;;; operands.  We split the VOP into its own block, and then call
-;;; Coalesce-More-Ltn-Numbers to assign all the more args/results the same LTN
-;;; number(s).
-;;;
-;;;    In either case, we clear the lifetime information that we computed so
-;;; far, recomputing it after taking corrective action.
-;;;
-;;;    Whenever we split a block, we finish the pre-pass on the split-off block
-;;; by doing Find-Local-References and Init-Global-Conflict-Kind.  This can't
-;;; run out of LTN numbers.
-;;;
-(defun lifetime-pre-pass (component)
-  (declare (type component component))
-  (let ((counter -1))
-    (do-blocks-backwards (block component)
-      (let ((2block (block-info block)))
-	(do ((lose (find-local-references 2block)
-		   (find-local-references 2block))
-	     (last-lose nil lose)
-	     (coalesced nil))
-	    ((not lose)
-	     (init-global-conflict-kind 2block)
-	     (setf (ir2-block-number 2block) (incf counter)))
-	  
-	  (clear-lifetime-info 2block)
-	  
-	  (cond
-	   ((vop-next lose)
-	    (assert (not (eq last-lose lose)))
-	    (let ((new (split-ir2-blocks 2block lose (incf counter))))
-	      (assert (not (find-local-references new)))
-	      (init-global-conflict-kind new)))
-	   (t
-	    (assert (not (eq lose coalesced)))
-	    (setq coalesced lose)
-	    (event coalesce-more-ltn-numbers (vop-node lose))
-	    (let ((info (vop-info lose))
-		  (new (if (vop-prev lose)
-			   (split-ir2-blocks 2block (vop-prev lose)
-					     (incf counter))
-			   2block)))
-	      (coalesce-more-ltn-numbers new (vop-args lose)
-					 (vop-info-arg-types info))
-	      (coalesce-more-ltn-numbers new (vop-results lose)
-					 (vop-info-result-types info))
-	      (assert (not (find-local-references new)))
-	      (init-global-conflict-kind new))))))))
-		     
-  (undefined-value))
-
-
-;;;; Flow analysis:
-
-;;; Propagate-Live-TNs  --  Internal
-;;;
-;;;    For each Global-TN in Block2 that is :Live, :Read or :Read-Only, ensure
-;;; that there is a corresponding Global-Conflict in Block1.  If there is none,
-;;; make a :Live Global-Conflict.  If there is a :Read-Only conflict, promote
-;;; it to :Live.
-;;;
-;;;    If we did added a new conflict, return true, otherwise false.  We don't
-;;; need to return true when we promote a :Read-Only conflict, since it doesn't
-;;; reveal any new information to predecessors of Block1.
-;;;
-;;;    We use the Tn-Current-Conflict to walk through the global
-;;; conflicts.  Since the global conflicts for a TN are ordered by block, we
-;;; can be sure that the Current-Conflict always points at or before the block
-;;; that we are looking at.  This allows us to quickly determine if there is a
-;;; global conflict for a given TN in Block1.
-;;;
-;;;    When we scan down the conflicts, we know that there must be at least one
-;;; conflict for TN, since we got our hands on TN by picking it out of a
-;;; conflict in Block2.
-;;;
-;;;    We leave the Current-Conflict pointing to the conflict for Block1.  The
-;;; Current-Conflict must be initialized to the head of the Global-Conflicts
-;;; for the TN between each flow analysis iteration.
-;;;
-(defun propagate-live-tns (block1 block2)
-  (declare (type ir2-block block1 block2))
-  (let ((live-in (ir2-block-live-in block1))
-	(did-something nil))
-    (do ((conf2 (ir2-block-global-tns block2)
-		(global-conflicts-next conf2)))
-	((null conf2))
-      (ecase (global-conflicts-kind conf2)
-	((:live :read :read-only)
-	 (let* ((tn (global-conflicts-tn conf2))
-		(tn-conflicts (tn-current-conflict tn))
-		(number1 (ir2-block-number block1)))
-	   (assert tn-conflicts)
-	   (do ((current tn-conflicts (global-conflicts-tn-next current))
-		(prev nil current))
-	       ((or (null current)
-		    (> (ir2-block-number (global-conflicts-block current))
-		       number1))
-		(setf (tn-current-conflict tn) prev)
-		(add-global-conflict :live tn block1 nil)
-		(setq did-something t))
-	     (when (eq (global-conflicts-block current) block1)
-	       (case (global-conflicts-kind current)
-		 (:live)
-		 (:read-only
-		  (setf (global-conflicts-kind current) :live)
-		  (setf (svref (ir2-block-local-tns block1)
-			       (global-conflicts-number current))
-			nil)
-		  (setf (global-conflicts-number current) nil)
-		  (setf (tn-current-conflict tn) current))
-		 (t
-		  (setf (sbit live-in (global-conflicts-number current)) 1)))
-	       (return)))))
-	(:write)))
-    did-something))
-
-		    
-;;; Lifetime-Flow-Analysis  --  Internal
-;;;
-;;;    Do backward global flow analysis to find all TNs live at each block
-;;; boundary.
-;;;
-(defun lifetime-flow-analysis (component)
-  (loop
-    (reset-current-conflict component)
-    (let ((did-something nil))
-      (do-blocks-backwards (block component)
-	(let* ((2block (block-info block))
-	       (last (do ((b (ir2-block-next 2block) (ir2-block-next b))
-			  (prev 2block b))
-			 ((not (eq (ir2-block-block b) block))
-			  prev))))
-
-	  (dolist (b (block-succ block))
-	    (when (and (block-lambda b)
-		       (propagate-live-tns last (block-info b)))
-	      (setq did-something t)))
-
-	  (do ((b (ir2-block-prev last) (ir2-block-prev b))
-	       (prev last b))
-	      ((not (eq (ir2-block-block b) block)))
-	    (when (propagate-live-tns b prev)
-	      (setq did-something t)))))
-
-      (unless did-something (return))))
-
-  (undefined-value))
-
-
-;;;; Post-pass:
-
-;;; Convert-To-Environment-TN  --  Internal
-;;;
-;;;    If TN isn't already a :Environment TN, then make it into one.  This
-;;; requires deleting the existing conflict info.
-;;;
-(defun convert-to-environment-tn (tn)
-  (declare (type tn tn))
-  (ecase (tn-kind tn)
-    (:environment)
-    (:normal
-     (let ((confs (tn-global-conflicts tn)))
-       (if confs
-	   (do ((conf confs (global-conflicts-tn-next conf)))
-	       ((null conf))
-	     (let ((block (global-conflicts-block conf)))
-	       (unless (eq (global-conflicts-kind conf) :live)
-		 (let ((ltns (ir2-block-local-tns block))
-		       (num (global-conflicts-number conf)))
-		   (assert (not (eq (svref ltns num) :more)))
-		   (setf (svref ltns num) nil)))
-	       (deletef-in global-conflicts-next (ir2-block-global-tns block)
-			   conf)))
-	   (setf (svref (ir2-block-local-tns (tn-local tn))
-			(tn-local-number tn))
-		 nil))
-       (setf (tn-local tn) nil)
-       (setf (tn-local-number tn) nil)
-       (setf (tn-global-conflicts tn) nil)
-       (setf (tn-kind tn) :environment)
-       (push tn (ir2-environment-live-tns (tn-environment tn))))))
-  (undefined-value))
-
-
-;;; Note-Conflicts  --  Internal
-;;;
-;;;    Note that TN conflicts with all current live TNs.  Num is TN's LTN
-;;; number.  We bit-ior Live-Bits with TN's Local-Conflicts, and set TN's
-;;; number in the conflicts of all TNs in Live-List.
-;;;
-(defun note-conflicts (live-bits live-list tn num)
-  (declare (type tn tn) (type (or tn null) live-list)
-	   (type local-tn-bit-vector live-bits)
-	   (type local-tn-number num))
-  (let ((lconf (tn-local-conflicts tn)))
-    (bit-ior live-bits lconf lconf))
-  (do ((live live-list (tn-next* live)))
-      ((null live))
-    (setf (sbit (tn-local-conflicts live) num) 1))
-  (undefined-value))
-
-
-;;; Compute-Save-Set  --  Internal
-;;;
-;;;    Compute a bit vector of the TNs live after VOP that aren't results.
-;;;
-(defun compute-save-set (vop block live-bits)
-  (declare (type vop vop) (type ir2-block block)
-	   (type local-tn-bit-vector live-list))
-  (let ((live (bit-vector-copy live-bits)))
-    (do ((r (vop-results vop) (tn-ref-across r)))
-	((null r))
-      (setf (sbit live (tn-local-number (tn-ref-tn r))) 0))
-    live))
-
-
-;;; Compute-Initial-Conflicts  --  Internal
-;;;
-;;;    Return as values, a LTN bit-vector and a list (threaded by TN-Next*)
-;;; representing the TNs live at the end of Block (exclusive of :Live TNs).
-;;;
-;;; We iterate over the TNs in the global conflicts that are live at the block
-;;; end, setting up the TN-Local-Conflicts and TN-Local-Number, and adding the
-;;; TN to the live list.
-;;;
-;;; ### Note: we alias the global-conflicts-conflicts here as the
-;;; tn-local-conflicts.
-;;;
-(defun compute-initial-conflicts (block)
-  (declare (type ir2-block block))
-  (let ((live-bits (copy-seq (ir2-block-live-in block)))
-	(live-list nil))
-
-    (do ((conf (ir2-block-global-tns block)
-	       (global-conflicts-next conf)))
-	((null conf))
-      (let ((bits (global-conflicts-conflicts conf))
-	    (tn (global-conflicts-tn conf))
-	    (num (global-conflicts-number conf)))
-	(setf (tn-local-number tn) num)
-	(unless (eq (global-conflicts-kind conf) :live)
-	  (unless (zerop (sbit live-bits num))
-	    (bit-vector-replace bits live-bits)
-	    (setf (sbit bits num) 0)
-	    (push-in tn-next* tn live-list))
-	  (setf (tn-local-conflicts tn) bits))))
-
-    (values live-bits live-list)))
-
-
-(eval-when (compile eval)
-
-;;; Frob-More-TNs  --  Internal
-;;;
-;;;    Used in the guts of Conflict-Analyze-1-Block to simultaneously do
-;;; something to all of the TNs referenced by a big more arg.  We have to treat
-;;; these TNs specially, since when we set or clear the bit in the live TNs,
-;;; the represents a change in the liveness of all the more TNs.  If we
-;;; iterated as normal, the next more ref would be thought to be not live when
-;;; it was, etc.  We return true if there where more TNs.
-;;;
-(defmacro frob-more-tns (action)
-  `(when (eq (svref ltns num) :more)
-     (do ((mref (tn-ref-next-ref ref) (tn-ref-next-ref mref)))
-	 ((null mref))
-       (let ((mtn (tn-ref-tn mref)))
-	 (unless (eql (tn-local-number mtn) num)
-	   (return))
-	 ,action))
-     t))
-
-); Eval-When (Compile Eval)
-
-
-;;; Conflict-Analyze-1-Block  --  Internal
-;;;
-;;;    Compute the block-local conflict information for Block.  We iterate over
-;;; all the TN-Refs in a block in reference order, maintaining the set of live
-;;; TNs in both a list and a bit-vector representation.
-;;;
-(defun conflict-analyze-1-block (block)
-  (declare (type ir2-block block))
-  (multiple-value-bind
-      (live-bits live-list)
-      (compute-initial-conflicts block)
-    (let ((ltns (ir2-block-local-tns block)))
-      
-      (do ((vop (ir2-block-last-vop block)
-		(vop-prev vop)))
-	  ((null vop))
-	
-	(let ((save-p (vop-info-save-p (vop-info vop))))
-	  (when save-p
-	    (let ((ss (compute-save-set vop block live-bits)))
-	      (setf (vop-save-set vop) ss)
-	      (when (eq save-p :force-to-stack)
-		(do-live-tns (tn ss block)
-		  (force-tn-to-stack tn)
-		  (convert-to-environment-tn tn))))))
-	
-	(do ((ref (vop-refs vop) (tn-ref-next-ref ref)))
-	    ((null ref))
-	  (let* ((tn (tn-ref-tn ref))
-		 (num (tn-local-number tn)))
-	    
-	    (cond
-	     ((not num))
-	     ((not (zerop (sbit live-bits num)))
-	      (when (tn-ref-write-p ref)
-		(setf (sbit live-bits num) 0)
-		(deletef-in tn-next* live-list tn)
-		(when (frob-more-tns (deletef-in tn-next* live-list mtn))
-		  (return))))
-	     ((tn-ref-write-p ref)
-	      (note-conflicts live-bits live-list tn num))
-	     (t
-	      (note-conflicts live-bits live-list tn num)
-	      (frob-more-tns (note-conflicts live-bits live-list mtn num))
-	      (setf (sbit live-bits num) 1)
-	      (push-in tn-next* tn live-list)
-	      (when (frob-more-tns (push-in tn-next* mtn live-list))
-		(return))))))))))
-
-
-;;; Lifetime-Post-Pass  --  Internal
-;;;
-;;;    Conflict analyze each block, and also add it 
-(defun lifetime-post-pass (component)
-  (declare (type component component))
-  (do-ir2-blocks (block component)
-    (conflict-analyze-1-block block)))
-
-
-;;; Lifetime-Analyze  --  Interface
-;;;
-;;;
-(defun lifetime-analyze (component)
-  (lifetime-pre-pass component)
-  (lifetime-flow-analysis component)
-  (lifetime-post-pass component))
-
-
-;;;; Conflict testing:
-
-;;; TNs-Conflict-Local-Global  --  Internal
-;;;
-;;;    Test for a conflict between the local TN X and the global TN Y.  We just
-;;; look for a global conflict of Y in X's block, and then test for conflict in
-;;; that block.
-;;; [### Might be more efficient to scan Y's global conflicts.  This depends on
-;;; whether there are more global TNs than blocks.]
-;;;
-(defun tns-conflict-local-global (x y)
-  (let ((block (tn-local x)))
-    (do ((conf (ir2-block-global-tns block)
-	       (global-conflicts-next conf)))
-	((null conf) nil)
-      (when (eq (global-conflicts-tn conf) y)
-	(let ((num (global-conflicts-number conf)))
-	  (return (or (not num)
-		      (not (zerop (sbit (tn-local-conflicts x)
-					num))))))))))
-
-
-;;; TNs-Conflict-Global-Global  --  Internal
-;;;
-;;;    Test for conflict between two global TNs X and Y.
-;;;
-(defun tns-conflict-global-global (x y)
-  (declare (type tn x y))
-  (let* ((x-conf (tn-global-conflicts x))
-	 (x-num (ir2-block-number (global-conflicts-block x-conf)))
-	 (y-conf (tn-global-conflicts y))
-	 (y-num (ir2-block-number (global-conflicts-block y-conf))))
-
-    (macrolet ((advance (n c)
-		 `(progn
-		    (setq ,c (global-conflicts-tn-next ,c))
-		    (unless ,c (return-from tns-conflict-global-global nil))
-		    (setq ,n (ir2-block-number (global-conflicts-block ,c)))))
-	       (scan (g l lc)
-		 `(do ()
-		      ((>= ,g ,l))
-		    (advance ,l ,lc))))
-
-      (loop
-	;; x-conf, y-conf true, x-num, y-num corresponding block numbers.
-	(scan x-num y-num y-conf)
-	(scan y-num x-num x-conf)
-	(when (= x-num y-num)
-	  (let ((ltn-num-x (global-conflicts-number x-conf)))
-	    (unless (and ltn-num-x
-			 (global-conflicts-number y-conf)
-			 (zerop (sbit (global-conflicts-conflicts y-conf)
-				      ltn-num-x)))
-	      (return t))
-	    (advance x-num x-conf)
-	    (advance y-num y-conf)))))))
-
-
-;;; TNs-Conflict-Environment-Global  --  Interface
-;;;
-;;;    Return true if any of Y's blocks are in X's environment.
-;;;
-(defun tns-conflict-environment-global (x y)
-  (declare (type tn x y))
-  (let ((env (tn-environment x)))
-    (do ((conf (tn-global-conflicts y) (global-conflicts-tn-next conf)))
-	((null conf)
-	 nil)
-      (when (eq (environment-info
-		 (lambda-environment
-		  (block-lambda
-		   (ir2-block-block (global-conflicts-block conf)))))
-		env)
-	(return t)))))
-
-
-;;; TNs-Conflict-Environment-Local  --  Interface
-;;;
-;;;    Return true if Y's block is in X's environment.
-;;;
-(defun tns-conflict-environment-local (x y)
-  (declare (type tn x y))
-  (eq (environment-info
-       (lambda-environment
-	(block-lambda
-	 (ir2-block-block (tn-local y)))))
-      (tn-environment x)))
-
-
-;;; TNs-Conflict  --  Interface
-;;;
-;;;    Return true if the lifetimes of X and Y overlap at any point.
-;;;
-(defun tns-conflict (x y)
-  (declare (type tn x y))
-  (cond ((eq (tn-kind x) :environment)
-	 (cond ((tn-global-conflicts y)
-		(tns-conflict-environment-global x y))
-	       ((eq (tn-kind y) :environment)
-		(eq (tn-environment x) (tn-environment y)))
-	       (t
-		(tns-conflict-environment-local x y))))
-	((eq (tn-kind y) :environment)
-	 (if (tn-global-conflicts x)
-	     (tns-conflict-environment-global y x)
-	     (tns-conflict-environment-local y x)))
-	((tn-global-conflicts x)
-	 (if (tn-global-conflicts y)
-	     (tns-conflict-global-global x y)
-	     (tns-conflict-local-global y x)))
-	((tn-global-conflicts y)
-	 (tns-conflict-local-global x y))
-	(t
-	 (and (eq (tn-local x) (tn-local y))
-	      (not (zerop (sbit (tn-local-conflicts x)
-				(tn-local-number y))))))))
diff --git a/compiler/loadcom.lisp b/compiler/loadcom.lisp
deleted file mode 100644
index 12e140b80b8dc54dbb807d26bdbfe454e409d587..0000000000000000000000000000000000000000
--- a/compiler/loadcom.lisp
+++ /dev/null
@@ -1,131 +0,0 @@
-;;; -*- Package: C -*-
-;;;
-;;;    Load up the compiler.
-;;;
-(in-package "C")
-
-#-new-compiler
-(progn
-  (ext:gc-off)
-
-  (load "ncode:fdefinition" :verbose t)
-  (load "c:globaldb" :verbose t)
-  (globaldb-init)
-
-  (load "c:patch" :verbose t)
-  (load "ncode:macros" :verbose t)
-  (load "ncode:struct" :verbose t)
-  (load "c:proclaim" :verbose t)
-  (load "ncode:extensions" :verbose t)
-  (load "ncode:defmacro" :verbose t)
-  (load "ncode:sysmacs" :verbose t)
-  (load "ncode:defrecord" :verbose t)
-  (load "ncode:error" :verbose t)
-  (load "ncode:debug-info" :verbose t)
-  (load "ncode:defstruct" :verbose t)
-  (load "ncode:c-call" :verbose t)
-  (load "ncode:salterror" :verbose t)
-  (load "ncode:machdef" :verbose t)
-
-  (load "c:boot-globaldb" :verbose t))
-
-(load "c:macros" :verbose t)
-(load "c:type" :verbose t)
-(load "c:vm-type" :verbose t)
-(load "c:type-init" :verbose t)
-(load "c:sset" :verbose t)
-(load "c:node" :verbose t)
-(load "c:ctype" :verbose t)
-(load "c:knownfun" :verbose t)
-(load "c:fndb" :verbose t)
-(load "c:ir1util" :verbose t)
-(load "c:ir1tran" :verbose t)
-(load "c:ir1final" :verbose t)
-(load "c:srctran" :verbose t)
-(load "c:seqtran" :verbose t)
-(load "c:typetran" :verbose t)
-(load "c:vm-tran" :verbose t)
-(load "c:locall" :verbose t)
-(load "c:dfo" :verbose t)
-(load "c:ir1opt" :verbose t)
-;(load "c:loop" :verbose t)
-(load "c:checkgen" :verbose t)
-(load "c:constraint" :verbose t)
-(load "c:envanal" :verbose t)
-(load "c:parms" :verbose t)
-(load "c:vop" :verbose t)
-(load "c:tn" :verbose t)
-(load "c:bit-util" :verbose t)
-(load "c:life" :verbose t)
-(load "c:vmdef" :verbose t)
-(load "c:gtn" :verbose t)
-(load "c:ltn" :verbose t)
-(load "c:stack" :verbose t)
-(load "c:control" :verbose t)
-(load "c:entry" :verbose t)
-(load "c:ir2tran" :verbose t)
-(load "c:pack" :verbose t)
-(load "c:codegen" :verbose t)
-(load "c:main" :verbose t)
-(load "c:assembler" :verbose t)
-(load "c:assem-insts" :verbose t)
-(load "c:assem-macs" :verbose t)
-(load "c:aliencomp" :verbose t)
-(load "c:debug-dump" :verbose t)
-
-#-new-compiler
-(load "ncode:alieneval" :verbose t)
-
-#+rt-target(progn
-#-new-compiler
-(handler-bind ((error #'(lambda (condition)
-			  (format t "~%~A~%Continuing...~%" condition)
-			  (continue))))
-  (progn
-    (load "ncode:constants" :verbose t)
-    (load "assem:rompconst" :verbose t)))
-
-#-new-compiler
-(load "c:fop" :verbose t)
-
-(load "c:dump" :verbose t)
-#+new-compiler
-(load "c:core" :verbose t)
-
-(load "c:vm" :verbose t)
-(load "c:move" :verbose t)
-(load "c:miscop" :verbose t)
-(load "c:subprim" :verbose t)
-(load "c:print" :verbose t)
-(load "c:memory" :verbose t)
-(load "c:cell" :verbose t)
-(load "c:call" :verbose t)
-(load "c:nlx" :verbose t)
-(load "c:values" :verbose t)
-(load "c:array" :verbose t)
-(load "c:pred" :verbose t)
-(load "c:system" :verbose t)
-(load "c:char" :verbose t)
-(load "c:type-vops" :verbose t)
-(load "c:arith" :verbose t)
-); #+RT-TARGET PROGN
-
-(load "c:debug" :verbose t)
-
-#+new-compiler
-(load "c:eval-comp" :verbose t)
-#+new-compiler
-(load "c:eval" :verbose t)
-
-
-#-new-compiler
-(progn
-  #+rt-target
-  (load "assem:assembler" :verbose t)
-  (%proclaim '(optimize (debug-info 0)))
-
-  (setq *info-environment*
-	(list (make-info-environment :name "Working")
-	      (compact-info-environment (car *info-environment*))))
-  (lisp::purify :root-structures '(ncompile-file))
-  (ext:gc-on))
diff --git a/compiler/locall.lisp b/compiler/locall.lisp
deleted file mode 100644
index f5cd3dc08df2bd8d0d6ac62795c065e3bcdbf0bb..0000000000000000000000000000000000000000
--- a/compiler/locall.lisp
+++ /dev/null
@@ -1,692 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    This file implements local call analysis.  A local call is a function
-;;; call between functions being compiled at the same time.  If we can tell at
-;;; compile time that such a call is legal, then we modify the flow graph to
-;;; represent the control transfers previously implicit in the call.  This
-;;; change allows us to do inter-routine flow analysis.
-;;;
-;;;    We cannot always do a local call even when we do have the function being
-;;; called.  Local call can be explicitly disabled by a NOTINLINE declaration.
-;;; Calls that cannot be shown to have legal arg counts are also not converted.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-
-;;; Propagate-To-Args  --  Internal
-;;;
-;;;    This function propagates information from the variables in the function
-;;; Fun to the actual arguments in Call.
-;;;
-;;;    We flush all arguments to Call that correspond to unreferenced variables
-;;; in Fun.  We leave NILs in the Combination-Args so that the remaining args
-;;; still match up with their vars.
-;;;
-;;;    We also apply the declared variable type assertion to the argument
-;;; continuations.
-;;;
-(defun propagate-to-args (call fun)
-  (declare (type combination call) (type clambda fun)) 
-  (do ((args (basic-combination-args call) (cdr args))
-       (vars (lambda-vars fun) (cdr vars)))
-      ((null args))
-    (let ((arg (car args))
-	  (var (car vars)))
-      (cond ((leaf-refs var)
-	     (assert-continuation-type arg (leaf-type var)))
-	    (t
-	     (flush-dest arg)
-	     (setf (car args) nil)))))
-      
-  (undefined-value))
-
-
-;;; Convert-Call  --  Internal
-;;;
-;;;    Convert a combination into a local call.  We Propagate-To-Args, set the
-;;; combination kind to :Local, add Fun to the Calls of the function that the
-;;; call is in, then replace the function in the Ref node with the new
-;;; function.
-;;;
-;;;    We change the Ref last, since changing the reference can trigger let
-;;; conversion of the new function, but will only do so if the call is local.
-;;;
-(defun convert-call (ref call fun)
-  (declare (type ref ref) (type combination call) (type clambda fun))
-  (propagate-to-args call fun)
-  (setf (basic-combination-kind call) :local)
-  (pushnew fun (lambda-calls (lambda-home (block-lambda (node-block call)))))
-  (change-ref-leaf ref fun)
-  (undefined-value))
-
-
-;;;; External entry point creation:
-
-;;; Make-XEP-Lambda  --  Internal
-;;;
-;;;    Return a Lambda form that can be used as the definition of the XEP for
-;;; Fun.
-;;;
-;;;    If Fun is a lambda, then we check the number of arguments (conditional
-;;; on policy) and call Fun with all the arguments.
-;;;
-;;;    If Fun is an Optional-Dispatch, then we dispatch off of the number of
-;;; supplied arguments by doing do an = test for each entry-point, calling the
-;;; entry with the appropriate prefix of the passed arguments.
-;;;
-;;;    If there is a more arg, then there are a couple of optimizations that we
-;;; make (more for space than anything else):
-;;; -- If Min-Args is 0, then we make the more entry a T clause, since no
-;;;    argument count error is possible.
-;;; -- We can omit the = clause for the last entry-point, allowing the case of
-;;;    0 more args to fall through to the more entry.
-;;;
-;;;    We don't bother to policy conditionalize wrong arg errors in optional
-;;; dispatches, since the additional overhead is negligible compared to the
-;;; other hair going down.
-;;;
-;;;    Note that if policy indicates it, argument type declarations in Fun will
-;;; be verified.  Since nothing is known about the type of the XEP arg vars,
-;;; type checks will be emitted when the XEP's arg vars are passed to the
-;;; actual function.
-;;;
-(defun make-xep-lambda (fun)
-  (declare (type functional fun))
-  (etypecase fun
-    (clambda
-     (let ((nargs (length (lambda-vars fun)))
-	   (n-supplied (gensym)))
-       (collect ((temps))
-	 (dotimes (i nargs)
-	   (temps (gensym)))
-	 `(lambda (,n-supplied ,@(temps))
-	    (declare (fixnum ,n-supplied))
-	    ,(if (policy (lambda-bind fun)
-			 (or (> speed safety) (> space safety)))
-		 `(declare (ignore ,n-supplied))
-		 `(%verify-argument-count ,n-supplied ,nargs))
-	    (%funcall ,fun ,@(temps))))))
-    (optional-dispatch
-     (let* ((min (optional-dispatch-min-args fun))
-	    (max (optional-dispatch-max-args fun))
-	    (more (optional-dispatch-more-entry fun))
-	    (n-supplied (gensym)))
-       (collect ((temps)
-		 (entries))
-	 (dotimes (i max)
-	   (temps (gensym)))
-
-	 (do ((eps (optional-dispatch-entry-points fun) (rest eps))
-	      (n min (1+ n)))
-	     ((null eps))
-	   (entries `((= ,n-supplied ,n)
-		      (%funcall ,(first eps) ,@(subseq (temps) 0 n)))))
-
-	 `(lambda (,n-supplied ,@(temps))
-	    (declare (fixnum ,n-supplied))
-	    (cond
-	     ,@(if more (butlast (entries)) (entries))
-	     ,@(when more
-		 `((,(if (zerop min) 't `(>= ,n-supplied ,max))
-		    ,(let ((n-context (gensym))
-			   (n-count (gensym)))
-		       `(multiple-value-bind
-			    (,n-context ,n-count)
-			    (%more-arg-context ,n-supplied ,max)
-			  (%funcall ,more ,@(temps) ,n-context ,n-count))))))
-	     (t
-	      (%argument-count-error ,n-supplied)))))))))
-
-
-;;; Make-External-Entry-Point  --  Internal
-;;;
-;;;    Make an external entry point (XEP) for Fun and return it.  We convert
-;;; the result of Make-XEP-Lambda in the correct environment, then associate
-;;; this lambda with Fun as its XEP.  After the conversion, we iterate over the
-;;; function's associated lambdas, redoing local call analysis so that the XEP
-;;; calls will get converted.
-;;;
-;;;    We set Reanalyze and Reoptimize in the component, just in case we
-;;; discover an XEP after the initial local call analyze pass.
-;;;
-(defun make-external-entry-point (fun)
-  (declare (type functional fun))
-  (assert (not (functional-entry-function fun)))
-  (with-ir1-environment (lambda-bind (main-entry fun))
-    (let ((res (ir1-convert-lambda (make-xep-lambda fun))))
-      (setf (functional-kind res) :external)
-      (setf (functional-entry-function res) fun)
-      (setf (functional-entry-function fun) res)
-      (setf (component-reanalyze *current-component*) t)
-      (setf (component-reoptimize *current-component*) t)
-      (etypecase fun
-	(clambda (local-call-analyze-1 fun))
-	(optional-dispatch
-	 (dolist (ep (optional-dispatch-entry-points fun))
-	   (local-call-analyze-1 ep))
-	 (when (optional-dispatch-more-entry fun)
-	   (local-call-analyze-1 (optional-dispatch-more-entry fun)))))
-      res)))
-
-
-;;; Reference-Entry-Point  --  Internal
-;;;
-;;;    Notice a Ref that is not in a local-call context.  If the Ref is already
-;;; to an XEP, then do nothing, otherwise change it to the XEP, making an XEP
-;;; if necessary.
-;;;
-;;;    If Ref is to a special :Cleanup or :Escape function, then we treat it as
-;;; though it was not an XEP reference (i.e. leave it alone.)
-;;;
-(defun reference-entry-point (ref)
-  (declare (type ref ref))
-  (let ((fun (ref-leaf ref)))
-    (unless (or (external-entry-point-p fun)
-		(member (functional-kind fun) '(:escape :cleanup)))
-      (change-ref-leaf ref (or (functional-entry-function fun)
-			       (make-external-entry-point fun))))))
-
-
-;;; Local-Call-Analyze-1  --  Interface
-;;;
-;;;    Attempt to convert all references to Fun to local calls.  The reference
-;;; cannot be :Notinline, and must be the function for a call.  The function
-;;; continuation must be used only once, since otherwise we cannot be sure what
-;;; function is to be called.  The call continuation would be multiply used if
-;;; there is hairy stuff such as conditionals in the expression that computes
-;;; the function.
-;;;
-;;;    If we cannot convert a reference, then we mark the referenced function
-;;; as an entry-point, creating a new XEP if necessary.
-;;;
-;;;    This is broken off from Local-Call-Analyze so that people can force
-;;; analysis of newly introduced calls.  Note that we don't do let conversion
-;;; here.
-;;;
-(defun local-call-analyze-1 (fun)
-  (declare (type functional fun))
-  (dolist (ref (leaf-refs fun))
-    (let* ((cont (node-cont ref))
-	   (dest (continuation-dest cont)))
-      (cond ((and (basic-combination-p dest)
-		  (eq (basic-combination-fun dest) cont)
-		  (eq (continuation-use cont) ref))
-	     (ecase (ref-inlinep ref)
-	       ((nil :inline)
-		(convert-call-if-possible ref dest))
-	       ((:notinline)))
-
-	     (unless (eq (basic-combination-kind dest) :local)
-	       (reference-entry-point ref)))
-	    (t
-	     (reference-entry-point ref)))))
-
-  (undefined-value))
-
-
-;;; Local-Call-Analyze  --  Interface
-;;;
-;;;    We examine all New-Functions in component, attempting to convert calls
-;;; into local calls when it is legal.  We also attempt to convert each lambda
-;;; to a let.  Let conversion is also triggered by deletion of a function
-;;; reference, but functions that start out eligible for conversion must be
-;;; noticed sometime.
-;;;
-;;;    Note that there is a lot of action going on behind the scenes here,
-;;; triggered by reference deletion.  In particular, the Component-Lambdas are
-;;; being hacked to remove newly deleted and let converted lambdas, so it is
-;;; important that the lambda is added to the Component-Lambdas when it is.
-;;;
-(defun local-call-analyze (component)
-  (declare (type component component))
-  (loop
-    (unless (component-new-functions component) (return))
-    (let ((fun (pop (component-new-functions component))))
-      (unless (eq (functional-kind fun) :deleted)
-	(when (lambda-p fun)
-	  (push fun (component-lambdas component)))
-	(local-call-analyze-1 fun)
-	(when (lambda-p fun)
-	  (maybe-let-convert fun)))))
-
-  (undefined-value))
-
-
-;;; Convert-Call-If-Possible  --  Interface
-;;;
-;;;    Dispatch to the appropriate function to attempt to convert a call.  This
-;;; is called in IR1 optimize as well as in local call analysis.  If the call
-;;; is already :Local, we do nothing.  If the call is in the top-level
-;;; component, also do nothing, since we don't want to join top-level code into
-;;; normal components.
-;;;
-;;;    We bind *Compiler-Error-Context* to the node for the call so that
-;;; warnings will get the right context.
-;;;
-(defun convert-call-if-possible (ref call)
-  (declare (type ref ref) (type basic-combination call))
-  (let ((fun (let ((fun (ref-leaf ref)))
-	       (if (external-entry-point-p fun)
-		   (functional-entry-function fun)
-		   fun)))
-	(*compiler-error-context* call))
-      (cond ((eq (basic-combination-kind call) :local))
-	    ((mv-combination-p call)
-	     (convert-mv-call ref call fun))
-	    ((lambda-p fun)
-	     (convert-lambda-call ref call fun))
-	    (t
-	     (convert-hairy-call ref call fun))))
-  (undefined-value))
-
-
-;;; Convert-MV-Call  --  Internal
-;;;
-;;;    Attempt to convert a multiple-value call.  The only interesting case is
-;;; a call to a function that Looks-Like-An-MV-Bind, has exactly one reference
-;;; and no XEP, and is called with one values continuation.
-;;;
-;;;    We change the call to be to the last optional entry point and change the
-;;; call to be local.  Due to our preconditions, the call should eventually be
-;;; converted to a let, but we can't do that now, since there may be stray
-;;; references to the e-p lambda due to optional defaulting code.
-;;;
-;;;    We also use variable types for the called function to construct an
-;;; assertion for the values continuation.
-;;;
-(defun convert-mv-call (ref call fun)
-  (declare (type ref ref) (type mv-combination call) (type functional fun))
-  (when (and (looks-like-an-mv-bind fun)
-	     (not (functional-entry-function fun))
-	     (= (length (leaf-refs fun)) 1)
-	     (= (length (basic-combination-args call)) 1))
-    (let ((ep (car (last (optional-dispatch-entry-points fun)))))
-      (change-ref-leaf ref ep)
-      (setf (basic-combination-kind call) :local)
-      (pushnew ep
-	       (lambda-calls (lambda-home (block-lambda (node-block call)))))
-
-      (assert-continuation-type
-       (first (basic-combination-args call))
-       (make-values-type :optional (mapcar #'leaf-type (lambda-vars ep))
-			 :rest *universal-type*))))
-  (undefined-value))
-
-
-;;; Convert-Lambda-Call  --  Internal
-;;;
-;;;    Attempt to convert a call to a lambda.  If the number of args is wrong,
-;;; we give a warning and mark the Ref as :Notinline to remove it from future
-;;; consideration.  If the argcount is O.K. then we just convert it.
-;;;
-(proclaim '(function convert-lambda-call (ref combination lambda) void))
-(defun convert-lambda-call (ref call fun)
-  (let ((nargs (length (lambda-vars fun)))
-	(call-args (length (combination-args call))))
-    (cond ((= call-args nargs)
-	   (convert-call ref call fun))
-	  (t
-	   (compiler-warning
-	    "Function called with ~R argument~:P, but wants exactly ~R."
-	    call-args nargs)
-	   (setf (ref-inlinep ref) :notinline)))))
-
-
-
-;;;; Optional, more and keyword calls:
-
-;;; Convert-Hairy-Call  --  Internal
-;;;
-;;;    Similar to Convert-Lambda-Call, but deals with Optional-Dispatches.  If
-;;; only fixed args are supplied, then convert a call to the correct entry
-;;; point.  If keyword args are supplied, then dispatch to a subfunction.  We
-;;; don't convert calls to functions that have a more (or rest) arg.
-;;;
-(defun convert-hairy-call (ref call fun)
-  (declare (type ref ref) (type combination call)
-	   (type optional-dispatch fun))
-  (let ((min-args (optional-dispatch-min-args fun))
-	(max-args (optional-dispatch-max-args fun))
-	(call-args (length (combination-args call))))
-    (cond ((< call-args min-args)
-	   (compiler-warning "Function called with ~R argument~:P, but wants at least ~R."
-			     call-args min-args)
-	   (setf (ref-inlinep ref) :notinline))
-	  ((<= call-args max-args)
-	   (convert-call ref call
-			 (elt (optional-dispatch-entry-points fun)
-			      (- call-args min-args))))
-	  ((not (optional-dispatch-more-entry fun))
-	   (compiler-warning "Function called with ~R argument~:P, but wants at most ~R."
-			     call-args max-args)
-	   (setf (ref-inlinep ref) :notinline))
-	  ((optional-dispatch-keyp fun)
-	   (cond ((oddp (- call-args max-args))
-		  (compiler-warning "Function called with odd number of ~
-				    arguments in keyword portion."))
-		 (t
-		  (convert-keyword-call ref call fun))))))
-
-  (undefined-value))
-
-
-;;; Convert-Hairy-Fun-Entry  --  Internal
-;;;
-;;;     This function is used to convert a call to an entry point when complex
-;;; transformations need to be done on the original arguments.  Entry is the
-;;; entry point function that we are calling.  Vars is a list of variable names
-;;; which are bound to the oringinal call arguments.  Ignores is the subset of
-;;; Vars which are ignored.  Args is the list of arguments to the entry point
-;;; function.
-;;;
-;;;    In order to avoid gruesome graph grovelling, we introduce a new function
-;;; that rearranges the arguments and calls the entry point.  We analyze the
-;;; new function and the entry point immediately so that everything gets
-;;; converted during the single pass.
-;;;
-(proclaim '(function convert-hairy-fun-entry
-		     (ref combination lambda list list list)))
-(defun convert-hairy-fun-entry (ref call entry vars ignores args)
-  (let ((new-fun
-	 (with-ir1-environment call
-	   (ir1-convert-lambda
-	    `(lambda ,vars
-	       (declare (ignore . ,ignores))
-	       (%funcall ,entry . ,args))
-	    (node-source call)))))
-    (convert-call ref call new-fun)
-    (dolist (ref (leaf-refs entry))
-      (convert-call-if-possible ref (continuation-dest (node-cont ref))))))
-
-
-;;; Convert-Keyword-Call  --  Internal
-;;;
-;;;    Use Convert-Hairy-Fun-Entry to convert a keyword call to a known
-;;; functions into a local call to the Main-Entry.
-;;;
-;;;    First we verify that all keywords are constant and legal.  If there
-;;; aren't, then we warn the user and don't attempt to convert the call.
-;;;
-;;;    We massage the supplied keyword arguments into the order expected by the
-;;; main entry.  This is done by binding all the arguments to the keyword call
-;;; to variables in the introduced lambda, then passing these values variables
-;;; in the correct order when calling the main entry.  Unused arguments
-;;; (such as the keywords themselves) are discarded simply by not passing them
-;;; along.
-;;;
-(defun convert-keyword-call (ref call fun)
-  (declare (type ref ref) (type combination call) (type optional-dispatch fun))
-  (let* ((max (optional-dispatch-max-args fun))
-	 (arglist (optional-dispatch-arglist fun))
-	 (args (combination-args call))
-	 (keys (nthcdr max args))
-	 (loser nil))
-    (collect ((temps)
-	      (ignores)
-	      (supplied)
-	      (key-vars))
-
-      (dolist (var arglist)
-	(let ((info (lambda-var-arg-info var)))
-	  (when info
-	    (ecase (arg-info-kind info)
-	      (:rest
-	       (setf (ref-inlinep ref) :notinline)
-	       (return-from convert-keyword-call))
-	      (:keyword
-	       (key-vars var))
-	      (:optional)))))
-
-      (dotimes (i max)
-	(temps (gensym)))
-
-      (do ((key keys (cddr key)))
-	  ((null key))
-	(let ((cont (first key)))
-	  (unless (constant-continuation-p cont)
-	    (when (policy call (or (> speed brevity) (> space brevity)))
-	      (compiler-note "Non-constant keyword in keyword call."))
-	    (setf (ref-inlinep ref) :notinline)
-	    (return-from convert-keyword-call))
-
-	  (let ((name (continuation-value cont)))
-	    (dolist (var (key-vars)
-			 (let ((dummy1 (gensym))
-			       (dummy2 (gensym)))
-			   (temps dummy1 dummy2)
-			   (ignores dummy1 dummy2)
-			   (setq loser name)))
-	      (let ((info (lambda-var-arg-info var)))
-		(when (eq (arg-info-keyword info) name)
-		  (let ((dummy (gensym))
-			(temp (gensym)))
-		    (temps dummy temp)
-		    (ignores dummy)
-		    (supplied (cons var temp)))
-		  (return)))))))
-
-      (when (and loser (not (optional-dispatch-allowp fun)))
-	(compiler-warning "Function called with unknown argument keyword ~S."
-			  loser)
-	(setf (ref-inlinep ref) :notinline)
-	(return-from convert-keyword-call))
-
-      (collect ((call-args))
-	(do ((var arglist (cdr var))
-	     (temp (temps) (cdr temp)))
-	    (())
-	  (let ((info (lambda-var-arg-info (car var))))
-	    (if info
-		(case (arg-info-kind info)
-		  (:optional
-		   (call-args (car temp))
-		   (when (arg-info-supplied-p info)
-		     (call-args t)))
-		  (t
-		   (return)))
-		(call-args (car temp)))))
-
-	(dolist (var (key-vars))
-	  (let ((info (lambda-var-arg-info var))
-		(temp (cdr (assoc var (supplied)))))
-	    (if temp
-		(call-args temp)
-		(call-args (arg-info-default info)))
-	    (when (arg-info-supplied-p info)
-	      (call-args (not (null temp))))))
-
-	(convert-hairy-fun-entry ref call (optional-dispatch-main-entry fun)
-				 (temps) (ignores) (call-args)))))
-
-  (undefined-value))
-
-
-;;;; Let conversion:
-;;;
-;;;    Converting to a let has differing significance to various parts of the
-;;; compiler:
-;;; -- The body of a Let is spliced in immediately after the the corresponding
-;;;    combination node, making the control transfer explicit and allowing lets
-;;;    to mashed together into a single block.  The value of the let is
-;;;    delivered directly to the original continuation for the call,
-;;;    eliminating the need to propagate information from the dummy result
-;;;    continuation. 
-;;; -- As far as IR1 optimization is concerned, it is interesting in that there
-;;;    is only one expression that the variable can be bound to, and this is
-;;;    easily substitited for.
-;;; -- Lets are interesting to environment analysis and the back end because in
-;;;    most ways a let can be considered to be "the same function" as its home
-;;;    function.
-;;; -- Let conversion has dynamic scope implications, since control transfers
-;;;    within the same environment are local.  In a local control transfer,
-;;;    cleanup code must be emitted to remove dynamic bindings that are no
-;;;    longer in effect.
-
-
-;;; Merge-Cleanups-And-Lets  --  Internal
-;;;
-;;;    Handle the environment semantics of let conversion.  We add the lambda
-;;; and its lets to lets for the call's home function and move any cleanups and
-;;; calls to the home function.  We merge the calls for Fun with the calls for
-;;; the home function, removing Fun in the process.  We also merge the Entries.
-;;; This must run after INSERT-LET-BODY, since the call to NODE-ENDS-BLOCK
-;;; figures out the actual cleanup current at the let call (and sets the
-;;; start/end cleanups accordingly.)
-;;;
-(defun merge-cleanups-and-lets (fun call)
-  (declare (type clambda fun) (type basic-combination call))
-  (let* ((prev (node-prev call))
-	 (home (lambda-home (block-lambda (continuation-block prev)))))
-    (push fun (lambda-lets home))
-    (setf (lambda-home fun) home)
-    
-    (let ((cleanup (find-enclosing-cleanup
-		    (block-end-cleanup (continuation-block prev))))
-	  (lets (lambda-lets fun)))
-      (dolist (let lets)
-	(setf (lambda-home let) home))
-      (when cleanup
-	(dolist (let lets)
-	  (unless (lambda-cleanup let)
-	    (setf (lambda-cleanup let) cleanup)))
-	(setf (lambda-cleanup fun) cleanup))
-
-      (setf (lambda-lets home) (nconc lets (lambda-lets home)))
-      (setf (lambda-lets fun) ()))
-
-    (setf (lambda-calls home)
-	  (nunion (lambda-calls fun)
-		  (delete fun (lambda-calls home))))
-    (setf (lambda-calls fun) ())
-
-    (setf (lambda-entries home)
-	  (nconc (lambda-entries fun) (lambda-entries home)))
-    (setf (lambda-entries fun) ()))
-  (undefined-value))
-
-
-;;; Insert-Let-Body  --  Internal
-;;;
-;;;    Handle the control semantics of let conversion.  We split the call block
-;;; immediately after the call, and link the head and tail of Fun to the call
-;;; block and the following block.  We also unlink the function head and tail
-;;; from the component head and tail and flush the function from the
-;;; Component-Lambdas.  We set Component-Reanalyze to true to indicate that the
-;;; DFO should be recomputed.
-;;;
-(defun insert-let-body (fun call)
-  (declare (type clambda fun) (type basic-combination call))
-  (let* ((call-block (node-block call))
-	 (bind-block (node-block (lambda-bind fun)))
-	 (component (block-component call-block)))
-    (let ((*current-component* component))
-      (node-ends-block call))
-    (setf (component-lambdas component)
-	  (delete fun (component-lambdas component)))
-    (assert (= (length (block-succ call-block)) 1))
-    (let ((next-block (first (block-succ call-block))))
-      (unlink-blocks call-block next-block)
-      (unlink-blocks (component-head component) bind-block)
-      (link-blocks call-block bind-block)
-      (let ((return (lambda-return fun)))
-	(when return
-	  (let ((return-block (node-block return)))
-	    (unlink-blocks return-block (component-tail component))
-	    (link-blocks return-block next-block)))))
-    (setf (component-reanalyze component) t))
-  (undefined-value))
-
-
-;;; Move-Return-Uses  --  Internal
-;;;
-;;;    Handle the value semantics of let conversion.  When Fun has a return
-;;; node, we delete it and move all the uses of the result continuation to
-;;; Call's Cont.
-;;;
-;;;    If the actual continuation is only used by the let call, then we
-;;; intersect the type assertion on the dummy continuation with the assertion
-;;; for the actual continuation; in all other cases assertions on the dummy
-;;; continuation are lost.
-;;;
-(defun move-return-uses (fun call)
-  (declare (type clambda fun) (type basic-combination call))
-  (let ((return (lambda-return fun)))
-    (when return
-      (unlink-node return)
-      (delete-return return)
-
-      (let ((result (return-result return))
-	    (cont (node-cont call)))
-	(when (eq (continuation-use cont) call)
-	  (assert-continuation-type cont (continuation-asserted-type result)))
-	(delete-continuation-use call)
-	(add-continuation-use call (node-prev (lambda-bind fun)))
-	(substitute-continuation-uses cont result))))
-
-  (undefined-value))
-
-
-;;; Let-Convert  --  Internal
-;;;
-;;;    Actually do let conversion.  We call subfunctions to do most of the
-;;; work.  We change the Call's cont to be the continuation heading the bind
-;;; block, and also do Reoptimize-Continuation on the args and Cont so that
-;;; let-specific IR1 optimizations get a chance.
-;;;
-(defun let-convert (fun call)
-  (declare (type clambda fun) (type basic-combination call))
-  (insert-let-body fun call)
-  (merge-cleanups-and-lets fun call)
-  (move-return-uses fun call)
-
-  (dolist (arg (basic-combination-args call))
-    (when arg
-      (reoptimize-continuation arg)))
-  (reoptimize-continuation (node-cont call))
-  (undefined-value))
-
-
-;;; Maybe-Let-Convert  --  Interface
-;;;
-;;;    This function is called when there is some reason to believe that
-;;; the lambda Fun might be converted into a let.  This is done after local
-;;; call analysis, and also when a reference is deleted.  We only convert to a
-;;; let when the function is a normal local function, has no XEP, and is
-;;; referenced in exactly one local call.  Conversion is also inhibited if the
-;;; only reference is in a block about to be deleted.
-;;;
-;;;    These rules may seem unnecessarily restrictive, since there are some
-;;; cases where we could do the return with a jump that don't satisfy these
-;;; requirements.  The reason for doing things this way is that it makes the
-;;; concept of a let much more useful at the level of IR1 semantics.  Low-level
-;;; control and environment optimizations can always be done later on.
-;;;
-;;;    We don't attempt to convert calls to functions that have an XEP, since
-;;; we might be embarrassed later when we want to convert a newly discovered
-;;; local call.
-;;;
-(defun maybe-let-convert (fun)
-  (declare (type clambda fun))
-  (let ((refs (leaf-refs fun)))
-    (when (and refs (null (rest refs))
-	       (not (block-delete-p (node-block (first refs))))
-	       (not (functional-kind fun))
-	       (not (functional-entry-function fun)))
-      (let* ((ref-cont (node-cont (first refs)))
-	     (dest (continuation-dest ref-cont)))
-	(when (and (basic-combination-p dest)
-		   (eq (basic-combination-fun dest) ref-cont)
-		   (eq (basic-combination-kind dest) :local))
-	  (let-convert fun dest)
-	  (setf (functional-kind fun)
-		(if (mv-combination-p dest) :mv-let :let))))))
-  (undefined-value))
diff --git a/compiler/ltn.lisp b/compiler/ltn.lisp
deleted file mode 100644
index 77af273b545701e2e83604558875d9e7d4da4a70..0000000000000000000000000000000000000000
--- a/compiler/ltn.lisp
+++ /dev/null
@@ -1,918 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    This file contains the LTN pass in the compiler.  LTN allocates
-;;; expression evaluation TNs, makes nearly all the implementation policy
-;;; decisions, and also does a few other random things.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-
-;;;; Utilities:
-
-;;; Translation-Policy  --  Internal
-;;;
-;;;    Return the policies keyword indicated by the node policy.
-;;;
-(defun translation-policy (node)
-  (declare (type node node))
-  (let* ((cookie (node-cookie node))
-	 (dcookie (node-default-cookie node))
-	 (safety (or (cookie-safety cookie)
-		     (cookie-safety dcookie)))
-	 (space (max (or (cookie-space cookie)
-			 (cookie-space dcookie))
-		     (or (cookie-cspeed cookie)
-			 (cookie-cspeed dcookie))))
-	 (speed (or (cookie-speed cookie)
-		    (cookie-speed dcookie))))
-    (cond ((>= safety speed space) :fast-safe)
-	  ((>= speed (max space safety)) :fast)
-	  ((>= space (max speed safety)) :small)
-	  (t :safe))))
-
-
-;;; Policy-Safe-P  --  Interface
-;;;
-;;;    Return true if Policy is a safe policy.
-;;;
-(proclaim '(inline policy-safe-p))
-(defun policy-safe-p (policy)
-  (declare (type policies policy))
-  (or (eq policy :safe) (eq policy :fast-safe)))
-
-
-;;; FLUSH-TYPE-CHECK  --  Internal
-;;;
-;;;    Called when an unsafe policy indicates that no type check should be done
-;;; on CONT.  We delete the type check unless it is :ERROR (indicating a
-;;; compile-time type error.)
-;;;
-(proclaim '(inline flush-type-check))
-(defun flush-type-check (cont)
-  (declare (type continuation cont))
-  (when (member (continuation-type-check cont) '(t :no-check))
-    (setf (continuation-%type-check cont) :deleted))
-  (undefined-value))
-
-
-;;; Continuation-PType  --  Internal
-;;;
-;;;    A annotated continuation's primitive-type.
-;;;
-(proclaim '(inline continuation-ptype))
-(defun continuation-ptype (cont)
-  (declare (type continuation cont))
-  (ir2-continuation-primitive-type (continuation-info cont)))
-
-
-;;; Continuation-Delayed-Leaf  --  Internal
-;;;
-;;;    If Cont is used only by a Ref to a leaf that can be delayed, then return
-;;; the leaf, otherwise return NIL.  We have to explicitly check for NLX
-;;; continuations, since they are sleazily referenced by IR2 conversion.
-;;;
-(defun continuation-delayed-leaf (cont)
-  (declare (type continuation cont)) 
-  (let ((use (continuation-use cont)))
-    (and (ref-p use)
-	 (not (find cont (environment-nlx-info (node-environment use))
-		    :key #'nlx-info-continuation))
-	 (let ((leaf (ref-leaf use)))
-	   (etypecase leaf
-	     (lambda-var (if (null (lambda-var-sets leaf)) leaf nil))
-	     (constant leaf)
-	     ((or functional global-var) nil))))))
-
-
-;;; Annotate-1-Value-Continuation  --  Internal
-;;;
-;;;    Annotate a normal single-value continuation.  If its only use is a ref
-;;; that we are allowed to delay the evaluation of, then we mark the
-;;; continuation for delayed evaluation, otherwise we assign a TN to hold the
-;;; continuation's value.
-;;;
-(defun annotate-1-value-continuation (cont)
-  (declare (type continuation cont))
-  (let ((info (continuation-info cont)))
-    (assert (eq (ir2-continuation-kind info) :fixed))
-    (if (continuation-delayed-leaf cont)
-	(setf (ir2-continuation-kind info) :delayed)
-	(setf (ir2-continuation-locs info)
-	      (list (make-normal-tn (ir2-continuation-primitive-type info))))))
-  (undefined-value))
-
-
-;;; Annotate-Ordinary-Continuation  --  Internal
-;;;
-;;;    Make an IR2-Continuation corresponding to the continuation type and then
-;;; do Annotate-1-Value-Continuation.  If Policy isn't a safe policy, then we
-;;; clear the type-check flag.
-;;;
-(defun annotate-ordinary-continuation (cont policy)
-  (declare (type continuation cont)
-	   (type policies policy))
-  (let ((info (make-ir2-continuation
-	       (primitive-type (continuation-type cont)))))
-    (setf (continuation-info cont) info)
-    (annotate-1-value-continuation cont)
-    (unless (policy-safe-p policy) (flush-type-check cont)))
-  (undefined-value))
-
-
-;;; Annotate-Full-Call-Continuation  --  Internal
-;;;
-;;;    Annotate a continuation that is an argument to a full call.  Kind of
-;;; like Annotate-Ordinary-Continuation, except that we only delay leaf refs
-;;; when no implicit coercion is required to move the TN to a descriptor
-;;; location.   We also always clear the type-check flag, since it is assumed
-;;; that the callee does appropriate checking.
-;;;
-(defun annotate-full-call-continuation (cont)
-  (declare (type continuation cont))
-  (let ((info (or (continuation-info cont)
-		  (setf (continuation-info cont)
-			(make-ir2-continuation *any-primitive-type*))))
-	(leaf (continuation-delayed-leaf cont)))
-    (flush-type-check cont)
-    (setf (ir2-continuation-primitive-type info) *any-primitive-type*)
-    (if (and leaf
-	     (etypecase leaf
-	       (constant t)
-	       (lambda-var
-		(let ((ptype (tn-primitive-type (leaf-info leaf))))
-		  (or (eq ptype *any-primitive-type*)
-		      (not (primitive-type-coerce-to-t ptype)))))))
-	(setf (ir2-continuation-kind info) :delayed)
-	(setf (ir2-continuation-locs info)
-	      (list (make-normal-tn *any-primitive-type*)))))
-  (undefined-value))
-
-
-;;; Annotate-Function-Continuation  --  Internal
-;;;
-;;;    Annotate the function continuation for a full call.  If the only
-;;; reference is to a global symbol function and Delay is true, then we delay
-;;; the reference, otherwise we annotate for a single value.
-;;;
-;;;   Unlike for an argument, we only clear the type check flag when the policy
-;;; is unsafe, since the check for a valid function object must be done before
-;;; the call.  Note that in the common case of a delayed global function
-;;; reference, the type checking is postponed, letting the call sequence do the
-;;; type checking however it wants.
-;;;
-(defun annotate-function-continuation (cont policy &optional (delay t))
-  (declare (type continuation cont) (type policies policy))
-  (let* ((ptype (primitive-type (continuation-derived-type cont)))
-	 (info (make-ir2-continuation ptype)))
-    (setf (continuation-info cont) info)
-    (unless (policy-safe-p policy) (flush-type-check cont))
-    (let ((name (continuation-function-name cont)))
-      (if (and delay name (symbolp name))
-	  (setf (ir2-continuation-kind info) :delayed)
-	  (setf (ir2-continuation-locs info) (list (make-normal-tn ptype))))))
-  (undefined-value))
-
-
-;;; LTN-Default-Call  --  Internal
-;;;
-;;;    Set up stuff to do a full call for Call.  We assume that that
-;;; IR2-Continuation structures have already been assigned to the args.
-;;;
-(defun ltn-default-call (call policy)
-  (declare (type combination call) (type policies policy))
-  (annotate-function-continuation (basic-combination-fun call) policy)
-  (dolist (arg (basic-combination-args call))
-    (annotate-full-call-continuation arg))
-  (undefined-value))
-
-
-;;; Make-Unknown-Values-Locations  --  Interface
-;;;
-;;;    Return a list of TNs that can be used to represent an unknown-values
-;;; continuation within a function.
-;;;
-(defun make-unknown-values-locations ()
-  (make-n-tns 2 *any-primitive-type*))
-
-
-;;; Annotate-Unknown-Values-Continuation  --  Internal
-;;;
-;;; Annotate a continuation for unknown multiple values:
-;;; -- Delete any type check, regardless of policy, since we IR2 conversion
-;;;    isn't prepared to check unknown-values continuations.  If we delete a
-;;;    type check when the policy is safe, then we emit a warning.
-;;; -- Add the continuation to the IR2-Block-Popped if it is used across a
-;;;    block boundry.
-;;; -- Assign a :Unknown IR2-Continuation.
-;;;
-;;; Note: it is critical that this be called only during LTN analysis of Cont's
-;;; DEST, and called in the order that the continuations are received.
-;;; Otherwise the IR2-Block-Popped and IR2-Component-Values-XXX will get all
-;;; messed up.
-;;;
-(defun annotate-unknown-values-continuation (cont policy)
-  (declare (type continuation cont) (type policies policy))
-  (when (eq (continuation-type-check cont) t)
-    (let* ((dest (continuation-dest cont))
-	   (*compiler-error-context* dest))
-      (when (and (policy-safe-p policy)
-		 (policy dest (>= safety brevity)))
-	(compiler-note "Unable to check type assertion in unknown-values ~
-	                context:~% ~S"
-		       (continuation-asserted-type cont))))
-    (setf (continuation-%type-check cont) :deleted))
-
-  (let* ((block (node-block (continuation-dest cont)))
-	 (use (continuation-use cont))
-	 (2block (block-info block)))
-    (unless (and use (eq (node-block use) block))
-      (setf (ir2-block-popped 2block)
-	    (nconc (ir2-block-popped 2block) (list cont)))))
-
-  (let ((2cont (make-ir2-continuation nil)))
-    (setf (ir2-continuation-kind 2cont) :unknown)
-    (setf (ir2-continuation-locs 2cont) (make-unknown-values-locations))
-    (setf (continuation-info cont) 2cont))
-
-  (undefined-value))
-
-
-;;; Annotate-Fixed-Values-Continuation  --  Internal
-;;;
-;;;    Annotate Cont for a fixed, but arbitrary number of values, to be kept in
-;;; the list of TNs Locs.
-;;;
-(defun annotate-fixed-values-continuation (cont policy locs)
-  (declare (type continuation cont) (type policies policy) (list locs))
-  (unless (policy-safe-p policy) (flush-type-check cont))
-
-  (let ((res (make-ir2-continuation nil)))
-    (setf (ir2-continuation-locs res) locs)
-    (setf (continuation-info cont) res))
-
-  (undefined-value))
-
-
-;;;; Node-specific analysis functions:
-
-;;; LTN-Analyze-Return  --  Internal
-;;;
-;;;    Annotate the result continuation for a function.  We use the Return-Info
-;;; computed by GTN to determine how to represent the return values within the
-;;; function.
-;;;
-;;;    If there is no non-tail use of the continuation within the function,
-;;; then we annotate the continuation as unused.  We never annotate NLX
-;;; continuations as :Unused, simplifying the NLX entry code.
-;;;
-;;;    If the kind is :Fixed, and the function being returned from isn't an
-;;; XEP, then we allocate a fixed number of locations to compute the function
-;;; result in.
-;;;
-;;;    Otherwise, we are going to use the unknown return convention.  If it is
-;;; known that a fixed number of values are always returned, then we annotate
-;;; the continuation for that many values.  Otherwise we must use the
-;;; unknown-values convention.
-;;;
-(defun ltn-analyze-return (node policy)
-  (declare (type creturn node) (type policies policy))
-  (let* ((cont (return-result node))
-	 (fun (return-lambda node))
-	 (returns (tail-set-info (lambda-tail-set fun)))
-	 (types (return-info-types returns)))
-    (cond
-     ((and (do-uses (use cont t)
-	     (unless (node-tail-p use)
-	       (return nil)))
-	   (not (find cont (environment-nlx-info (node-environment node))
-		      :key #'nlx-info-continuation)))
-      (let ((res (make-ir2-continuation nil)))
-	(setf (ir2-continuation-kind res) :unused)
-	(setf (continuation-info cont) res)))
-     ((and (eq (return-info-kind returns) :fixed)
-	   (not (external-entry-point-p fun)))
-      (annotate-fixed-values-continuation cont policy
-					 (mapcar #'make-normal-tn types)))
-     ((not (eq (return-info-count returns) :unknown))
-      (annotate-fixed-values-continuation
-       cont policy
-       (make-n-tns (return-info-count returns) *any-primitive-type*)))
-     (t
-      (annotate-unknown-values-continuation cont policy))))
-
-  (undefined-value))
-
-
-;;; LTN-Analyze-MV-Bind  --  Internal
-;;;
-;;;    Annotate the single argument continuation as a fixed-values
-;;; continuation.  We look at the called lambda to determine number and type of
-;;; return values desired.  It is assumed that only a function that
-;;; Looks-Like-An-MV-Bind will be converted to a local call.
-;;;
-(defun ltn-analyze-mv-bind (call policy)
-  (declare (type mv-combination call)
-	   (type policies policy))
-  (annotate-fixed-values-continuation
-   (first (basic-combination-args call)) policy
-   (mapcar #'(lambda (var)
-	       (make-normal-tn
-		(primitive-type (basic-var-type var))))
-	   (lambda-vars
-	    (ref-leaf
-	     (continuation-use
-	      (basic-combination-fun call))))))
-  (undefined-value))
-
-
-;;; LTN-Analyze-MV-Call  --  Internal
-;;;
-;;;    We force all the argument continuations to use the unknown values
-;;; convention.  The continuations are annotated in reverse order, since the
-;;; last argument is on top, thus must be popped first.  We disallow delayed
-;;; evaluation of the function continuation to simplify IR2 conversion of MV
-;;; call.
-;;;
-;;;    We could be cleverer when we know the number of values returned by the
-;;; continuations, but optimizations of MV-Call are probably unworthwhile.
-;;;
-;;;    We are also responsible for handling THROW, which is represented in IR1
-;;; as an mv-call to the %THROW funny function.  We annotate the tag
-;;; continuation for a single value and the values continuation for unknown
-;;; values.
-;;;
-(defun ltn-analyze-mv-call (call policy)
-  (declare (type mv-combination call))
-  (let ((fun (basic-combination-fun call))
-	(args (basic-combination-args call)))
-    (cond ((eq (continuation-function-name fun) '%throw)
-	   (annotate-ordinary-continuation (first args) policy)
-	   (annotate-unknown-values-continuation (second args) policy))
-	  (t
-	   (annotate-function-continuation (basic-combination-fun call)
-					   policy nil)
-	   (dolist (arg (reverse args))
-	     (annotate-unknown-values-continuation arg policy)))))
-  (undefined-value))
-
-
-;;; LTN-Analyze-Local-Call  --  Internal
-;;;
-;;;    Annotate the arguments as ordinary single-value continuations.
-;;;
-(defun ltn-analyze-local-call (call policy)
-  (declare (type combination call)
-	   (type policies policy))
-  (dolist (arg (basic-combination-args call))
-    (when arg
-      (annotate-ordinary-continuation arg policy)))
-  (undefined-value))
-
-
-;;; LTN-Analyze-Set  --  Internal
-;;;
-;;;    Annotate the value continuation.
-;;;
-(defun ltn-analyze-set (node policy)
-  (declare (type cset node) (type policies policy))
-  (annotate-ordinary-continuation (set-value node) policy)
-  (undefined-value))
-
-
-;;; LTN-Analyze-If  --  Internal  
-;;;
-;;;    If the only use of the Test continuation is a combination annotated with
-;;; a conditional template, then don't annotate the continuation so that IR2
-;;; conversion knows not to emit any code, otherwise annotate as an ordinary
-;;; continuation.  Since we only use a conditional template if the call
-;;; immediately precedes the IF node in the same block, we know that any
-;;; predicate will already be annotated.
-;;;
-(defun ltn-analyze-if (node policy)
-  (declare (type cif node) (type policies policy))
-  (let* ((test (if-test node))
-	 (use (continuation-use test)))
-    (unless (and (combination-p use)
-		 (let ((info (basic-combination-info use)))
-		   (and info
-			(eq (template-result-types info) :conditional))))
-      (annotate-ordinary-continuation test policy)))
-  (undefined-value))
-
-
-;;; LTN-Analyze-Exit  --  Internal
-;;;
-;;;    If there is a value continuation, then annotate it for unknown values.
-;;; In this case, the exit is non-local, since all other exits are deleted or
-;;; degenerate by this point.
-;;;
-(defun ltn-analyze-exit (node policy)
-  (let ((value (exit-value node)))
-    (when value
-      (annotate-unknown-values-continuation value policy)))
-  (undefined-value))
-
-
-;;; LTN annotate %Unwind-Protect  --  Internal
-;;;
-;;;    We need a special method for %Unwind-Protect that ignores the cleanup
-;;; function.  We don't annotate either arg, since we don't need them at
-;;; run-time.
-;;;
-;;; [The default is o.k. for %Catch, since environment analysis converted the
-;;; reference to the escape function into a constant reference to the
-;;; NLX-Info.]
-;;;
-(defoptimizer (%unwind-protect ltn-annotate) ((escape cleanup) node policy)
-  policy ; Ignore...
-  )
-
-
-;;; LTN annotate %Slot-Setter, %Slot-Accessor  --  Internal
-;;;
-;;;    Both of these functions need special LTN-annotate methods, since we
-;;; only want to clear the Type-Check in unsafe policies.  If allowed the call
-;;; to be annotated as a full call, then no type checking would be done.
-;;;
-;;;    We also need a special LTN annotate method for %Slot-Setter so that the
-;;; function is ignored.  This is because the reference to a SETF function
-;;; can't be delayed, so IR2 conversion would have already emitted a call to
-;;; FDEFINITION by the time the IR2 convert method got control.
-;;;
-(defoptimizer (%slot-accessor ltn-annotate) ((struct) node policy)
-  (annotate-ordinary-continuation struct policy))
-;;;
-(defoptimizer (%slot-setter ltn-annotate) ((struct value) node policy)
-  (annotate-ordinary-continuation struct policy)
-  (annotate-ordinary-continuation value policy))
-
-
-;;;; Known call annotation:
-
-;;; Template-Args-OK  --  Internal
-;;;
-;;;    Check that the argument type restriction for Template are satisfied in
-;;; call.  If an argument's TYPE-CHECK is :NO-CHECK and our policy is safe,
-;;; then only :SAFE templates are o.k.
-;;;
-(defun template-args-ok (template call safe-p)
-  (declare (type template template)
-	   (type combination call))
-  (let ((mtype (template-more-args-type template)))
-    (do ((args (basic-combination-args call) (cdr args))
-	 (types (template-arg-types template) (cdr types)))
-	((null types)
-	 (cond ((null args) t)
-	       ((not mtype) nil)
-	       ((eq mtype '*) t)
-	       (t
-		(dolist (arg args t)
-		  (unless (primitive-subtypep (continuation-ptype arg)
-					      mtype)
-		    (return nil))))))
-      (when (null args) (return nil))
-      (let ((arg (car args))
-	    (type (car types)))
-	(when (and (eq (continuation-type-check arg) :no-check)
-		   safe-p
-		   (not (eq (template-policy template) :safe)))
-	  (return nil))
-	(unless (or (eq type '*)
-		    (primitive-subtypep (continuation-ptype arg) type))
-	  (return nil))))))
-
-
-;;; Template-Results-OK  --  Internal
-;;;
-;;;    Check that Template can be used with the specifed Result-Type.   Result
-;;; type checking is pretty different from argument type checking due to the
-;;; relaxed rules for values count.  We suceed if for each required result,
-;;; there is a positional restriction on the value that is at least as good.
-;;; If we run out of result types before we run out of restrictions, then we
-;;; only suceed if the leftover restrictions are unrestrictive (* or T).
-;;; If we run out of restrictions before we run out of result types, then we
-;;; always win.
-;;;
-(defun template-results-ok (template result-type)
-  (declare (type template template)
-	   (type ctype result-type))
-  (let ((types (template-result-types template)))
-    (cond
-     ((values-type-p result-type)
-      (do ((ltypes (append (args-type-required result-type)
-			   (args-type-optional result-type))
-		   (rest ltypes))
-	   (types types (rest types)))
-	  ((null ltypes)
-	   (dolist (type types t)
-	     (unless (or (eq type '*) (eq type *any-primitive-type*))
-	       (return nil))))
-	(when (null types) (return t))
-	(let ((type (first types)))
-	  (unless (or (eq type '*)
-		      (primitive-subtypep (primitive-type (first ltypes))
-					  type))
-	    (return nil)))))
-     (types
-      (let ((type (first types)))
-	(or (eq type '*)
-	    (primitive-subtypep (primitive-type result-type) type))))
-     (t
-      (let ((mtype (template-more-args-type template)))
-	(or (not mtype) (eq mtype '*)
-	    (primitive-subtypep (primitive-type result-type) mtype)))))))
-
-
-;;; Find-Template  --  Internal
-;;;
-;;;    Use operand type information to choose a template from the list
-;;; Templates for a known Call.  We return three values:
-;;; 1] The template we found.
-;;; 2] Some template that we rejected due to unsatisfied type restrictions, or
-;;;    NIL if none.
-;;; 3] The tail of Templates for templates we haven't examined yet.
-;;;
-;;; What we do:
-;;; -- If the template has a Guard that isn't true, then we ignore the
-;;;    template, not even considering it to be rejected.
-;;; -- If the argument type restrictions aren't satisfied, then we reject the
-;;;    template.
-;;; -- If the template is :Conditional, then we accept it only when the
-;;;    destination of the value is an immediately following IF node.
-;;; -- We accept a template if the Node-Derived-Type satisfies the
-;;;    output assertion, since this type has been proven to be statisfied.
-;;; -- Unless the policy is safe and the template is :Fast-Safe, we also accept
-;;;    a template when the continuation derived type satisfies the output
-;;;    assertion.  We only attempt this when TYPE-CHECK is non-null, since when
-;;;    this is NIL, the assertion is a supertype of the node type.
-;;;
-(defun find-template (templates call safe-p)
-  (declare (list templates) (type combination call))
-  (do ((templates templates (rest templates))
-       (rejected nil))
-      ((null templates)
-       (values nil rejected nil))
-    (let* ((template (first templates))
-	   (guard (template-guard template)))
-      (when (and (or (not guard) (funcall guard))
-		 (template-args-ok template call safe-p))
-	(let* ((cont (node-cont call))
-	       (atype (continuation-asserted-type cont))
-	       (dtype (node-derived-type call)))
-	  (when (or (and (eq (template-result-types template) :conditional)
-			 (let ((dest (continuation-dest cont)))
-			   (and (if-p dest)
-				(immediately-used-p (if-test dest) call))))
-		    (template-results-ok template dtype)
-		    (and (not (and (eq (template-policy template) :fast-safe)
-				   safe-p))
-			 (continuation-type-check cont)
-			 (template-results-ok template
-					      (values-type-intersection
-					       dtype atype))))
-	    (return (values template rejected (rest templates))))))
-      (setq rejected template))))
-
-
-;;; Find-Template-For-Policy  --  Internal
-;;;
-;;;    Given a partially annotated known call and a translation policy, return
-;;; the appropriate template, or NIL if none can be found.  We scan the
-;;; templates (ordered by increasing cost) looking for a template whose
-;;; restrictions are satisfied and that has our policy.
-;;;
-;;; If we find a template that doesn't have our policy, but has a legal
-;;; alternate policy, then we also record that to return as a last resort.  If
-;;; our policy is safe, then only safe policies are O.K., otherwise anything
-;;; goes.
-;;;
-;;; If we rejected a template and Speed > Brevity, then we call
-;;; Note-Rejected-Templates to emit any appropriate efficiency notes.
-;;;
-(defun find-template-for-policy (call policy)
-  (declare (type combination call)
-	   (type policies policy))
-  (let ((safe-p (policy-safe-p policy)))
-    (let ((current (function-info-templates (basic-combination-kind call)))
-	  (fallback nil)
-	  (rejected nil))
-      (loop
-	(multiple-value-bind (template this-reject more)
-			     (find-template current call safe-p)
-	  (unless rejected
-	    (setq rejected this-reject))
-	  (setq current more)
-	  (unless template
-	    (return (values fallback rejected)))
-	  
-	  (let ((tpolicy (template-policy template)))
-	    (cond ((eq tpolicy policy)
-		   (return (values template rejected)))
-		  (fallback)
-		  ((or (not safe-p) (policy-safe-p tpolicy))
-		   (setq fallback template)))))))))
-
-
-;;; Template-Description  --  Internal
-;;;
-;;;    Return some short description of template for use in messages.  If there
-;;; is a note, return that, otherwise return the name.
-;;;
-(defun template-description (template)
-  (declare (type template template))
-  (or (template-note template) (template-name template)))
-
-
-;;; Note-Rejected-Templates  --  Internal
-;;;
-;;;    This function emits efficiency notes describing all of the templates
-;;; better (faster) than Template that we might have been able to use if there
-;;; were better type declarations.  Template is null when we didn't find any
-;;; template, and thus must do a full call.
-;;;
-;;; In order to be worth complaining about, a template must:
-;;; -- be allowed by its guard,
-;;; -- be safe if the current policy is safe,
-;;; -- have argument/result type restrictions consistent with the known type
-;;;    information, e.g. we don't consider float templates when an operand is
-;;;    known to be an integer,
-;;; -- be disallowed by the stricter operand subtype test (which resembles, but
-;;;    is not identical to the test done by Find-Template.)
-;;;
-;;; Note that there may not be any possibly applicable templates, since we are
-;;; called whenever any template is rejected.  That template might have the
-;;; wrong policy or be inconsistent with the known type.
-;;;
-;;; We go to some trouble to make the whole multi-line output into a single
-;;; call to Compiler-Note so that repeat messages are suppressed, etc.
-;;;
-(defun note-rejected-templates (call policy template)
-  (declare (type combination call) (type policies policy)
-	   (type (or template null) template))
-
-  (collect ((losers))
-    (let ((safe-p (policy-safe-p policy)))
-      (dolist (try (function-info-templates (basic-combination-kind call)))
-	(when (eq try template) (return))
-	(let ((guard (template-guard try)))
-	  (when (and (or (not guard) (funcall guard))
-		     (or (not safe-p)
-			 (policy-safe-p (template-policy try)))
-		     (valid-function-use
-		      call (template-type try)
-		      :argument-test #'types-intersect
-		      :result-test #'values-types-intersect))
-	    (losers try)))))
-
-    (when (losers)
-      (collect ((messages))
-	(flet ((frob (string &rest stuff)
-		 (messages string)
-		 (messages stuff)))
-	  (dolist (loser (losers))
-	    (let* ((type (template-type loser))
-		   (valid (valid-function-use call type))
-		   (strict-valid (valid-function-use call type
-						     :strict-result t)))
-	      (when (or (not valid) (not strict-valid))
-		(frob "Unable to do ~A (cost ~D) because:"
-		      (template-description loser) (template-cost loser)))
-
-	      (cond ((not valid)
-		     (valid-function-use call type
-					 :error-function #'frob
-					 :warning-function #'frob))
-		    ((not strict-valid)
-		     (assert (policy-safe-p policy))
-		     (frob "Can't trust output type assertion under safe ~
-		            policy."))))))
-
-	(let ((*compiler-error-context* call))
-	  (compiler-note "~{~?~^~&~6T~}"
-			 (if template
-			     `("Forced to do ~A (cost ~D)."
-			       (,(template-description template)
-				,(template-cost template))
-			       . ,(messages))
-			     `("Forced to do full call."
-			       nil
-			       . ,(messages))))))))
-  (undefined-value))
-
-
-;;; Maybe-Restrict-Arg  --  Internal
-;;;
-;;;    Cont is some continuation that is an argument to a template with a T
-;;; type restriction.  If the continuation's ptype has a coerce-to-t template
-;;; (indicating that a conversion is involved), then we set the type to
-;;; *any-primitive-type*.
-;;;
-(defun maybe-restrict-arg (cont)
-  (declare (type continuation cont))
-  (let ((2cont (continuation-info cont)))
-    (when (primitive-type-coerce-to-t (ir2-continuation-primitive-type 2cont))
-      (setf (ir2-continuation-primitive-type 2cont) *any-primitive-type*)))
-  (undefined-value))
-
-
-;;; Restrict-Descriptor-Args  --  Internal
-;;;
-;;;    If any argument to the template is restricted to a descriptor
-;;; representation, then force the corresponding continuation to
-;;; *any-primitive-type* when the current ptype has a 
-;;;
-(defun restrict-descriptor-args (call template)
-  (declare (type combination call)
-	   (type template template))
-  (do ((args (basic-combination-args call) (cdr args))
-       (type (template-arg-types template) (cdr type)))
-      ((null type)
-       (if (eq (template-more-args-type template) *any-primitive-type*)
-	   (dolist (arg args)
-	     (maybe-restrict-arg arg))))
-    (when (eq (car type) *any-primitive-type*)
-      (maybe-restrict-arg (car args))))
-  (undefined-value))
-
-
-;;; Flush-Type-Checks-According-To-Policy  --  Internal
-;;;
-;;;    Flush type checks according to policy.  If the policy is unsafe, then we
-;;; never do any checks.  If our policy is safe, and we are using a safe
-;;; template, then we can also flush arg type checks, but we must make the
-;;; continuation type be *any-primitive-type* so that objects of the incorrect
-;;; type can be represented.
-;;;
-(defun flush-type-checks-according-to-policy (call policy template)
-  (declare (type combination call) (type policies policy)
-	   (type template template))
-  (if (policy-safe-p policy)
-      (when (eq (template-policy template) :safe)
-	(dolist (arg (basic-combination-args call))
-	  (when (continuation-type-check arg)
-	    (flush-type-check arg)
-	    (setf (ir2-continuation-primitive-type (continuation-info arg))
-		  *any-primitive-type*))))
-      (dolist (arg (basic-combination-args call))
-	(flush-type-check arg)))
-  (undefined-value))
-
-
-;;; LTN-Analyze-Known-Call  --  Internal
-;;;
-;;;    If a function has a special-case annotation method use that, otherwise
-;;; annotate the argument continuations and try to find a template
-;;; corresponding to the type signature. If there is none, convert a full
-;;; call.
-;;;
-;;;    If we are unable to use some templates due to unstatisfied operand type
-;;; restrictions and our policy enables efficiency notes, then we call
-;;; Note-Rejected-Templates.
-;;;
-;;;    If we are forced to do a full call, we check to see if the function
-;;; called is the same as the current function.  If so, we give a warning, as
-;;; this is probably a botched interpreter stub.
-;;;
-(defun ltn-analyze-known-call (call policy)
-  (declare (type combination call)
-	   (type policies policy))
-  (let ((method (function-info-ltn-annotate (basic-combination-kind call)))
-	(args (basic-combination-args call)))
-    (when method
-      (funcall method call policy)
-      (return-from ltn-analyze-known-call (undefined-value)))
-    
-    (dolist (arg args)
-      (setf (continuation-info arg)
-	    (make-ir2-continuation (primitive-type (continuation-type arg)))))
-
-    (multiple-value-bind (template rejected)
-			 (find-template-for-policy call policy)
-      (when (and rejected
-		 (policy call (> speed brevity)))
-	(note-rejected-templates call policy template))
-      (unless template
-	(when (and (eq (continuation-function-name (combination-fun call))
-		       (leaf-name
-			(environment-function
-			 (node-environment call))))
-		   (not (function-info-ir2-convert
-			 (basic-combination-kind call))))
-	  (let ((*compiler-error-context* call))
-	    (compiler-warning "Recursive known function definition.")))
-	(ltn-default-call call policy)
-	(return-from ltn-analyze-known-call (undefined-value)))
-      (setf (basic-combination-info call) template)
-      
-      (flush-type-checks-according-to-policy call policy template)
-      (restrict-descriptor-args call template)
-      
-      (dolist (arg args)
-	(annotate-1-value-continuation arg))))
-  
-  (undefined-value))
-
-
-;;;; Interfaces:
-
-(eval-when (compile eval)
-
-;;; LTN-Analyze-Block-Macro  --  Internal
-;;;
-;;;    We make the main per-block code in for LTN into a macro so that it can
-;;; be shared between LTN-Analyze and LTN-Analyze-Block, yet can cache policy
-;;; across blocks in the normal (full component) case.
-;;;
-;;;    This code computes the policy and then dispatches to the appropriate
-;;; node-specific function.
-;;;
-(defmacro ltn-analyze-block-macro ()
-  '(progn
-     (do-nodes (node cont block)
-       (unless (and (eq (node-cookie node) cookie)
-		    (eq (node-default-cookie node) default-cookie))
-	 (setq policy (translation-policy node))
-	 (setq cookie (node-cookie node))
-	 (setq default-cookie (node-default-cookie node)))
-       
-       (etypecase node
-	 (ref)
-	 (combination
-	  (case (basic-combination-kind node)
-	    (:local (ltn-analyze-local-call node policy))
-	    (:full (ltn-default-call node policy))
-	    (t
-	     (ltn-analyze-known-call node policy))))
-	 (cif
-	  (ltn-analyze-if node policy))
-	 (creturn
-	  (ltn-analyze-return node policy))
-	 ((or bind entry))
-	 (exit
-	  (ltn-analyze-exit node policy))
-	 (cset (ltn-analyze-set node policy))
-	 (mv-combination
-	  (ecase (basic-combination-kind node)
-	    (:local (ltn-analyze-mv-bind node policy))
-	    (:full (ltn-analyze-mv-call node policy))))))))
-
-); Eval-When (Compile Eval)
-
-
-;;; LTN-Analyze  --  Interface
-;;;
-;;;    Loop over the blocks in Component, doing stuff to nodes that receive
-;;; values.  In addition to the stuff done by LTN-Analyze-Block-Macro, we also
-;;; see if there are any unknown values receivers, making notations in the
-;;; components Generators and Receivers as appropriate.
-;;;
-;;;    If any unknown-values continations are received by this block (as
-;;; indicated by IR2-Block-Popped, then we add the block to the
-;;; IR2-Component-Values-Receivers.  We also look at each use of the popped
-;;; continuations, adding the use block to the Generators.  Uses by Exit nodes
-;;; are ignored, since they correspond to non-local exits.
-;;;
-(defun ltn-analyze (component)
-  (declare (type component component))
-  (let ((2comp (component-info component))
-	(cookie nil)
-	default-cookie policy)
-    (do-blocks (block component)
-      (ltn-analyze-block-macro)
-      
-      (let* ((2block (block-info block))
-	     (popped (ir2-block-popped 2block)))
-	(when popped
-	  (push block (ir2-component-values-receivers 2comp))
-	  (dolist (pop popped)
-	    (do-uses (use pop)
-	      (unless (exit-p use)
-		(pushnew (node-block use)
-			 (ir2-component-values-generators 2comp)))))))))
-  
-  (undefined-value))
-
-
-;;; LTN-Analyze-Block  --  Interface
-;;;
-;;;    This function is used to analyze blocks that must be added to the flow
-;;; graph after the normal LTN phase runs.  Such code is constrained not to use
-;;; weird unknown values (and probably in lots of other ways).
-;;;
-(defun ltn-analyze-block (block)
-  (declare (type cblock block))
-  (let ((cookie nil)
-	default-cookie policy)
-    (ltn-analyze-block-macro))
-
-  (assert (not (ir2-block-popped (block-info block))))
-  (undefined-value))
diff --git a/compiler/macros.lisp b/compiler/macros.lisp
deleted file mode 100644
index ca793e2f3a78f8c310ab074e26c79703905bfaa8..0000000000000000000000000000000000000000
--- a/compiler/macros.lisp
+++ /dev/null
@@ -1,1146 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    Random types and macros used in writing the compiler.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-(export '(lisp::with-compilation-unit) "LISP")
-
-(proclaim '(special *wild-type* *universal-type* *compiler-error-context*))
-
-
-;;; Undefined-Value  --  Public
-;;;
-;;;    This is here until we figure out what to do with it.
-;;;
-(proclaim '(inline undefined-value))
-(eval-when (#-new-compiler compile load eval)
-(defun undefined-value ()
-  '%undefined%)
-);
-
-;;;; Deftypes:
-
-;;;
-;;; Should be standard:
-(deftype boolean () '(member t nil))
-
-;;;
-;;; Inlinep is used to determine how a function is called.  The values have
-;;; these meanings:
-;;;        Nil	No declaration seen: do whatever you feel like, but don't dump
-;;;		an inline expansion.
-;;;
-;;; :Notinline  Notinline declaration seen: always do full function call.
-;;;
-;;;    :Inline	Inline declaration seen: save expansion, expanding to it if
-;;;		policy favors.
-;;; 
-;;; :Maybe-Inline
-;;;		Retain expansion, but only use it opportunistically.
-;;;
-(deftype inlinep () '(member :inline :maybe-inline :notinline nil))
-
-
-;;;; The Policy macro:
-
-(proclaim '(special *current-cookie* *default-cookie*))
-
-(eval-when (#-new-compiler compile load eval)
-(defconstant policy-parameter-slots
-  '((speed . cookie-speed) (space . cookie-space) (safety . cookie-safety)
-    (cspeed . cookie-cspeed) (brevity . cookie-brevity)
-    (debug . cookie-debug)))
-
-;;; Find-Used-Parameters  --  Internal
-;;;
-;;;    Find all the policy parameters which are actually mentioned in Stuff,
-;;; returning the names in a list.  We assume everything is evaluated.
-;;;
-(defun find-used-parameters (stuff)
-  (if (atom stuff)
-      (if (assoc stuff policy-parameter-slots) (list stuff) ())
-      (collect ((res () nunion))
-	(dolist (arg (cdr stuff) (res))
-	  (res (find-used-parameters arg))))))
-
-); Eval-When (Compile Load Eval)
-
-;;; Policy  --  Public
-;;;
-;;;    This macro provides some syntactic sugar for querying the settings of
-;;; the compiler policy parameters.
-;;;
-(defmacro policy (node &rest conditions)
-  "Policy Node Condition*
-  Test whether some conditions apply to the current compiler policy for Node.
-  Each condition is a predicate form which accesses the policy values by
-  referring to them as the variables SPEED, SPACE, SAFETY, CSPEED, BREVITY and
-  DEBUG.  The results of all the conditions are combined with AND and returned
-  as the result.
-
-  Node is a form which is evaluated to obtain the node which the policy is for.
-  If Node is NIL, then we use the current policy as defined by *default-cookie*
-  and *current-cookie*.  This option is only well defined during IR1
-  conversion."
-  (let* ((form `(and ,@conditions))
-	 (n-current (gensym))
-	 (n-default (gensym))
-	 (binds (mapcar
-		 #'(lambda (name)
-		     (let ((slot (cdr (assoc name policy-parameter-slots))))
-		       `(,name (or (,slot ,n-current) (,slot ,n-default)))))
-		 (find-used-parameters form))))
-    (if node
-	(let ((n-node (gensym)))
-	  `(let* ((,n-node ,node)
-		  (,n-default (node-default-cookie ,n-node))
-		  (,n-current (node-cookie ,n-node))
-		  ,@binds)
-	     ,form))
-	`(let* ((,n-default *default-cookie*)
-		(,n-current *current-cookie*)
-		,@binds)
-	   ,form))))
-
-
-;;;; Source-hacking defining forms:
-
-(eval-when (#-new-compiler compile load eval)
-
-;;; Symbolicate  --  Interface
-;;;
-;;;    Concatenate together the names of some strings and symbols, producing
-;;; a symbol in the current package.
-;;;
-(proclaim '(function symbolicate (&rest (or string symbol)) symbol))
-(defun symbolicate (&rest things)
-  (values (intern (reduce #'(lambda (x y)
-			      (concatenate 'string (string x) (string y)))
-			  things))))
-
-); Eval-When (Compile Load Eval)
-
-  
-;;; Def-IR1-Translator  --  Interface
-;;;
-;;;    Parse defmacro style lambda-list, setting things up so that a compiler
-;;; error happens if the syntax is invalid.
-;;;
-(defmacro def-ir1-translator (name (lambda-list start-var cont-var
-						&key (kind :special-form))
-				   &body body)
-  "Def-IR1-Translator Name (Lambda-List Start-Var Cont-Var {Key Value}*)
-                      [Doc-String] Form*
-  Define a function that converts a Special-Form or other magical thing into
-  IR1.  Lambda-List is a defmacro style lambda list.  Start-Var and Cont-Var
-  are bound to the start and result continuations for the resulting IR1.
-  This keyword is defined:
-      Kind
-          The function kind to associate with Name (default :special-form)."
-  (let ((fn-name (symbolicate "IR1-CONVERT-" name))
-	(n-form (gensym))
-	(n-env (gensym)))
-    (multiple-value-bind (body decls doc)
-			 (lisp::parse-defmacro
-			  lambda-list n-form body name
-			  :error-string "Wrong number of arguments to special form ~S: ~D."
-			  :doc-string-allowed t
-			  :environment n-env)
-      `(progn
-	 (proclaim '(function ,fn-name (continuation continuation t) void))
-	 (defun ,fn-name (,start-var ,cont-var ,n-form)
-	   (let ((,n-env *fenv*))
-	     ,@decls
-	     (macrolet ((error (&rest args)
-			       `(compiler-error ,@args)))
-	       ,body)))
-	 ,@(when doc
-	     `((setf (documentation ',name 'function) ,doc)))
-	 (setf (info function ir1-convert ',name) #',fn-name)
-	 (setf (info function kind ',name) ,kind)))))
-
-
-;;; Def-Source-Transform  --  Interface
-;;;
-;;;    Similar to Def-IR1-Translator, except that we pass if the syntax is
-;;; invalid.
-;;;
-(defmacro def-source-transform (name lambda-list &body body)
-  "Def-Source-Transform Name Lambda-List Form*
-  Define a macro-like source-to-source transformation for the function Name.
-  A source transform may \"pass\" by returning a non-nil second value.  If the
-  transform passes, then the form is converted as a normal function call.  If
-  the supplied arguments are not compatible with the specified lambda-list,
-  then the transform automatically passes.
-  
-  Source-Transforms may only be defined for functions.  Source transformation
-  is not attempted if the function is declared Notinline.  Source transforms
-  should not examine their arguments.  If it matters how the function is used,
-  then Deftransform should be used to define an IR1 transformation.
-  
-  If the desirability of the transformation depends on the current Optimize
-  parameters, then the Policy macro should be used to determine when to pass."
-  (let ((fn-name (symbolicate "SOURCE-TRANSFORM-" name))
-	(n-form (gensym))
-	(n-env (gensym)))
-    (multiple-value-bind (body decls)
-			 (lisp::parse-defmacro lambda-list n-form body name
-					       :error-string "Foo!"
-					       :environment n-env)
-      `(progn
-	 (defun ,fn-name (,n-form)
-	   (let ((,n-env *fenv*))
-	     ,@decls
-	     (macrolet ((error (&rest stuff)
-			       (declare (ignore stuff))
-			       `(return-from ,',fn-name (values nil t))))
-	       ,body)))
-	 (setf (info function source-transform ',name) #',fn-name)))))
-
-
-(defmacro def-primitive-translator (name lambda-list &body body)
-  "Def-Primitive-Translator Name Lambda-List Form*
-  Define a function that converts a use of (%PRIMITIVE Name ...) into Lisp
-  code.  Lambda-List is a defmacro style lambda list."
-  (let ((fn-name (symbolicate "PRIMITIVE-TRANSLATE-" name))
-	(n-form (gensym))
-	(n-env (gensym)))
-    (multiple-value-bind (body decls)
-			 (lisp::parse-defmacro
-			  lambda-list n-form body name
-			  :error-string "Wrong number of arguments to primitive ~S: ~D."
-			  :environment n-env)
-      `(progn
-	 (defun ,fn-name (,n-form)
-	   (let ((,n-env *fenv*))
-	     ,@decls
-	     (macrolet ((error (&rest args)
-			       `(compiler-error ,@args)))
-	       ,body)))
-	 (setf (gethash ',name *primitive-translators*) ',fn-name)))))
-
-
-;;;; Lambda-list parsing utilities:
-;;;
-;;;    IR1 transforms, optimizers and type inferencers need to be able to parse
-;;; the IR1 representation of a function call using a standard function
-;;; lambda-list.
-
-
-(eval-when (#-new-compiler compile load eval)
-
-;;; Parse-Lambda-List  --  Interface
-;;;
-;;;    Break a lambda-list into its component parts.  We return eight values:
-;;;  1] A list of the required args.
-;;;  2] A list of the optional arg specs.
-;;;  3] True if a rest arg was specified.
-;;;  4] The rest arg.
-;;;  5] A boolean indicating whether keywords args are present.
-;;;  6] A list of the keyword arg specs.
-;;;  7] True if &allow-other-keys was specified.
-;;;  8] A list of the &aux specifiers.
-;;;
-;;; The top-level lambda-list syntax is checked for validity, but the arg
-;;; specifiers are just passed through untouched.  If something is wrong, we
-;;; use Compiler-Error, aborting compilation to the last recovery point.
-;;;
-;;; [Eventually this should go into the code sources, since it is used in
-;;; various random places such as the function type parsing.]
-;;;
-(proclaim '(function parse-lambda-list (list)
-		     (values list list boolean t boolean list boolean list)))
-(defun parse-lambda-list (list)
-  (collect ((required)
-	    (optional)
-	    (keys)
-	    (aux))
-    (let ((restp nil)
-	  (rest nil)
-	  (keyp nil)
-	  (allowp nil)
-	  (state :required))
-      (dolist (arg list)
-	(if (and (symbolp arg)
-		 (let ((name (symbol-name arg)))
-		   (and (/= (length name) 0)
-			(char= (char name 0) #\&))))
-	    (case arg
-	      (&optional
-	       (unless (eq state :required)
-		 (compiler-error "Misplaced &optional in lambda-list: ~S." list))
-	       (setq state '&optional))
-	      (&rest
-	       (unless (member state '(:required &optional))
-		 (compiler-error "Misplaced &rest in lambda-list: ~S." list))
-	       (setq state '&rest))
-	      (&key
-	       (unless (member state '(:required &optional :post-rest))
-		 (compiler-error "Misplaced &key in lambda-list: ~S." list))
-	       (setq keyp t)
-	       (setq state '&key))
-	      (&allow-other-keys
-	       (unless (eq state '&key)
-		 (compiler-error "Misplaced &allow-other-keys in lambda-list: ~S." list))
-	       (setq allowp t  state '&allow-other-keys))
-	      (&aux
-	       (when (eq state '&rest)
-		 (compiler-error "Misplaced &aux in lambda-list: ~S." list))
-	       (setq state '&aux))
-	      (t
-	       (compiler-error "Unknown &keyword in lambda-list: ~S." arg)))
-	    (case state
-	      (:required (required arg))
-	      (&optional (optional arg))
-	      (&rest
-	       (setq restp t  rest arg  state :post-rest))
-	      (&key (keys arg))
-	      (&aux (aux arg))
-	      (t
-	       (compiler-error "Found garbage in lambda-list when expecting a keyword: ~S." arg)))))
-    (values (required) (optional) restp rest keyp (keys) allowp (aux)))))
-
-
-;;; Parse-Deftransform  --  Internal
-;;;
-;;;    Given a deftransform style lambda-list, generate code that parses the
-;;; arguments of a combination with respect to that lambda-list.  Body is the
-;;; the list of forms which are to be evaluated within the bindings.  Args is
-;;; the variable that holds list of argument continuations.  Error-Form is a
-;;; form which is evaluated when the syntax of the supplied arguments is
-;;; incorrect or a non-constant argument keyword is supplied.  Defaults and
-;;; other gunk are ignored.  The second value is a list of all the arguments
-;;; bound.  We make the variables IGNORABLE so that we don't have to manually
-;;; declare them Ignore if their only purpose is to make the syntax work.
-;;;
-(proclaim '(function parse-deftransform (list list symbol t) list))
-(defun parse-deftransform (lambda-list body args error-form)
-  (multiple-value-bind (req opt restp rest keyp keys allowp)
-		       (parse-lambda-list lambda-list)
-    (let* ((min-args (length req))
-	   (max-args (+ min-args (length opt)))
-	   (n-keys (gensym)))
-      (collect ((binds)
-		(vars)
-		(pos 0 +)
-		(keywords))
-	(dolist (arg req)
-	  (vars arg)
-	  (binds `(,arg (nth ,(pos) ,args)))
-	  (pos 1))
-
-	(dolist (arg opt)
-	  (let ((var (if (atom arg) arg (first  arg))))
-	    (vars var)
-	    (binds `(,var (nth ,(pos) ,args)))
-	    (pos 1)))
-
-	(when restp
-	  (vars rest)
-	  (binds `(,rest (nthcdr ,(pos) ,args))))
-
-	(dolist (spec keys)
-	  (if (or (atom spec) (atom (first spec)))
-	      (let* ((var (if (atom spec) spec (first spec)))
-		     (key (intern (symbol-name var) "KEYWORD")))
-		(vars var)
-		(binds `(,var (find-keyword-continuation ,n-keys ,key)))
-		(keywords key))
-	      (let* ((head (first spec))
-		     (var (second head))
-		     (key (first head)))
-		(vars var)
-		(binds `(,var (find-keyword-continuation ,n-keys ,key)))
-		(keywords key))))
-
-	(let ((n-length (gensym))
-	      (limited-legal (not (or restp keyp))))
-	  (values
-	   `(let ((,n-length (length ,args))
-		  ,@(when keyp `((,n-keys (nthcdr ,(pos) ,args)))))
-	      (unless (and
-		       ,(if limited-legal
-			    `(<= ,min-args ,n-length ,max-args)
-			    `(<= ,min-args ,n-length))
-		       ,@(when keyp
-			   (if allowp
-			       `((check-keywords-constant ,n-keys))
-			       `((check-transform-keys ,n-keys ',(keywords))))))
-		,error-form)
-	      (let ,(binds)
-		;;; ### Bootstrap hack...
-		#+new-compiler
-		(declare (ignorable ,@(vars)))
-		#-new-compiler
-		(progn ,@(vars))
-		,@body))
-	   (vars)))))))
-
-); Eval-When (Compile Load Eval)
-
-
-;;;; Utilities used at run-time for parsing keyword args in IR1:
-
-;;; Find-Keyword-Continuation  --  Internal
-;;;
-;;;    This function is used by the result of Parse-Deftransform to find the
-;;; continuation for the value of the keyword argument Key in the list of
-;;; continuations Args.  It returns the continuation if the keyword is present,
-;;; or NIL otherwise.  The legality and constantness of the keywords should
-;;; already have been checked. 
-;;;
-(proclaim '(function find-keyword-continuation (list keyword) (or continuation null)))
-(defun find-keyword-continuation (args key)
-  (do ((arg args (cddr arg)))
-      ((null arg) nil)
-    (when (eq (continuation-value (first arg)) key)
-      (return (second arg)))))
-
-
-;;; Check-Keywords-Constant  --  Internal
-;;;
-;;;    This function is used by the result of Parse-Deftransform to verify that
-;;; alternating continuations in Args are constant and that there is an even
-;;; number of args.
-;;;
-(proclaim '(function check-keywords-constant (list) boolean))
-(defun check-keywords-constant (args)
-  (do ((arg args (cddr arg)))
-      ((null arg) t)
-    (unless (and (rest arg)
-		 (constant-continuation-p (first arg)))
-      (return nil))))
-
-
-;;; Check-Transform-Keys  --  Internal
-;;;
-;;;    This function is used by the result of Parse-Deftransform to verify that
-;;; the list of continuations Args is a well-formed keyword arglist and that
-;;; only keywords present in the list Keys are supplied.
-;;;
-(proclaim '(function check-transform-keys (list list) boolean))
-(defun check-transform-keys (args keys)
-  (and (check-keywords-constant args)
-       (do ((arg args (cddr arg)))
-	   ((null arg) t)
-	 (unless (member (continuation-value (first arg)) keys)
-	   (return nil)))))
-
-
-;;;; Deftransform:
-
-;;; Deftransform  --  Interface
-;;;
-;;;    Parse the lambda-list and generate code to test the policy and
-;;; automatically create the result lambda.
-;;;
-(defmacro deftransform (name (lambda-list &optional (arg-types '*) (result-type '*)
-					  &key result policy node defun-only)
-			     &body body)
-  "Deftransform Name (Lambda-List [Arg-Types] [Result-Type] {Key Value}*)
-               Declaration* Form*
-  Define an IR1 transformation for Name.  An IR1 transformation computes a
-  lambda that replaces the function variable reference for the call.  A
-  transform may pass (decide not to transform the call) by calling the Give-Up
-  function.  Lambda-List both determines how the current call is parsed and
-  specifies the Lambda-List for the resulting lambda.
-
-  We parse the call and bind each of the lambda-list variables to the
-  continuation which represents the value of the argument.  When parsing the
-  call, we ignore the defaults, and always bind the variables for unsupplied
-  arguments to NIL.  If a required argument is missing, an unknown keyword is
-  supplied, or an argument keyword is not a constant, then the transform
-  automatically passes.  The Declarations apply to the bindings made by
-  Deftransform at transformation time, rather than to the variables of the
-  resulting lambda.  Bound-but-not-referenced warnings are suppressed for the
-  lambda-list variables.
-
-  Normally, the body evaluates to a form which becomes the body of an
-  automatically constructed lambda.  We make Lambda-List the lambda-list for
-  the lambda, and automatically insert declarations of the argument and result
-  types.  If the second value of the body is non-null, then it is a list of
-  declarations which are to be inserted at the head of the lambda.  Automatic
-  lambda generation may be inhibited by explicitly returning a lambda from the
-  body.
-
-  The Arg-Types and Result-Type are used to create a function type which the
-  call must satisfy before transformation is attempted.  The function type
-  specifier is constructed by wrapping (FUNCTION ...) around these values, so
-  the lack of a restriction may be specified by omitting the argument or
-  supplying *.  The argument syntax specified in the Arg-Types need not be the
-  same as that in the Lambda-List, but the transform will never happen if
-  the syntaxes can't be satisfied simultaneously.  If there is an existing
-  transform for the same function that has the same type, then it is replaced
-  with the new definition.
-
-  These are the legal keyword options:
-    :Result - A variable which is bound to the result continuation.
-    :Node   - A variable which is bound to the combination node for the call.
-    :Policy - A form which is supplied to the Policy macro to determine whether
-              this transformation is appropriate.  If the result is false, then
-              the transform automatically passes.
-    :Defun-Only
-            - Don't actually instantiate a transform, instead just DEFUN
-              Name with the specified transform definition function.  This may
-              be later instantiated with %Deftransform."
-
-  (let ((n-args (gensym))
-	(n-node (or node (gensym)))
-	(n-decls (gensym))
-	(n-lambda (gensym)))
-    (multiple-value-bind (parsed-form vars)
-			 (parse-deftransform
-			  lambda-list
-			  (if policy
-			      `(progn
-				(unless (policy ,n-node ,policy) (give-up))
-				,@body)
-			      body)
-			  n-args '(give-up))
-      (let ((stuff
-	     `((,n-node)
-	       (let* ((,n-args (basic-combination-args ,n-node))
-		      ,@(when result
-			  `((,result (node-cont ,n-node)))))
-		 (multiple-value-bind (,n-lambda ,n-decls)
-				      ,parsed-form
-		   (if (and (consp ,n-lambda) (eq (car ,n-lambda) 'lambda))
-		       ,n-lambda
-		       `(lambda ,',lambda-list
-			  (declare (ignorable ,@',vars))
-			  ,@,n-decls
-			  ,,n-lambda)))))))
-	(if defun-only
-	    `(defun ,name ,@stuff)
-	    `(%deftransform
-	      ',name
-	      '(function ,arg-types ,result-type)
-	      #'(lambda ,@stuff)))))))
-
-;;;; Defknown, Defoptimizer:
-
-;;; Defknown  --  Interface
-;;;
-;;;    This macro should be the way that all implementation independent
-;;; information about functions is made known to the compiler.
-;;;
-(defmacro defknown (name arg-types result-type &optional (attributes '(any))
-			 &rest keys)
-  "Defknown Name Arg-Types Result-Type [Attributes] {Key Value}* 
-  Declare the function Name to be a known function.  We construct a type
-  specifier for the function by wrapping (FUNCTION ...) around the Arg-Types
-  and Result-Type.  Attributes is a an unevaluated list of the boolean
-  attributes that the function has.  These attributes are meaningful here:
-      call
-         May call functions that are passed as arguments.  In order to determine
-         what other effects are present, we must find the effects of all arguments
-         that may be functions.
-        
-      unsafe
-         May incorporate arguments in the result or somehow pass them upward.
-        
-      unwind
-         May fail to return during correct execution.  Errors are O.K.
-        
-      any
-         The (default) worst case.  Includes all the other bad things, plus any
-         other possible bad thing.
-        
-      foldable
-         May be constant-folded.  The function has no side effects, but may be
-         affected by side effects on the arguments.  e.g. SVREF, MAPC.
-        
-      flushable
-         May be eliminated if value is unused.  The function has no side effects
-         except possibly CONS.  If a function is defined to signal errors, then
-         it is not flushable even if it is movable or foldable.
-        
-      movable
-         May be moved with impunity.  Has no side effects except possibly CONS,
-         and is affected only by its arguments.
-
-      predicate
-          A true predicate likely to be open-coded.  This is a hint to IR1
-	  conversion that it should ensure calls always appear as an IF test.
-	  Not usually specified to Defknown, since this is implementation
-	  dependent, and is usually automatically set by the Define-VOP
-	  :Conditional option.
-
-  Name may also be a list of names, in which case the same information is given
-  to all the names.  The keywords specify the initial values for various
-  optimizers that the function might have."
-  (when (and (intersection attributes '(any call unwind))
-	     (intersection attributes '(movable)))
-    (error "Function cannot have both good and bad attributes: ~S" attributes))
-  
-  `(%defknown ',(if (and (consp name)
-			 (not (eq (car name) 'setf)))
-		    name
-		    (list name))
-	      '(function ,arg-types ,result-type)
-	      (ir1-attributes ,@(if (member 'any attributes)
-				    (union '(call unsafe unwind) attributes)
-				    attributes))
-	      ,@keys))
-
-
-;;; Defoptimizer  --  Interface
-;;;
-;;;    Create a function which parses combination args according to a
-;;; Lambda-List, optionally storing it in a function-info slot.
-;;;
-(defmacro defoptimizer (what (lambda-list &optional (n-node (gensym))
-					  &rest vars)
-			     &body body)
-  "Defoptimizer (Function Kind) (Lambda-List [Node-Var] Var*)
-                Declaration* Form*
-  Define some Kind of optimizer for the named Function.  Function must be a
-  known function.  Lambda-List is used to parse the arguments to the
-  combination as in Deftransform.  If the argument syntax is invalid or there
-  are non-constant keys, then we simply return NIL.
-
-  The function is DEFUN'ed as Function-Kind-OPTIMIZER.  Possible kinds are
-  DERIVE-TYPE, OPTIMIZER, LTN-ANNOTATE and IR2-CONVERT.  If a symbol is
-  specified instead of a (Function Kind) list, then we just do a DEFUN with the
-  symbol as its name, and don't do anything with the definition.  This is
-  useful for creating optimizers to be passed by name to DEFKNOWN.
-
-  If supplied, Node-Var is bound to the combination node being optimized.  If
-  additional Vars are supplied, then they are used as the rest of the optimizer
-  function's lambda-list.  LTN-ANNOTATE methods are passed an additional POLICY
-  argument, and IR2-CONVERT methods are passed an additional IR2-BLOCK
-  argument."
-
-  (let ((name (if (symbolp what) what
-		  (symbolicate (first what) "-" (second what) "-OPTIMIZER"))))
-
-    (let ((n-args (gensym)))
-      `(progn
-	(defun ,name (,n-node ,@vars)
-	  (let ((,n-args (basic-combination-args ,n-node)))
-	    ,(parse-deftransform lambda-list body n-args
-				 `(return-from ,name nil))))
-	,@(when (consp what)
-	    `((setf (,(symbolicate "FUNCTION-INFO-" (second what))
-		     (function-info-or-lose ',(first what)))
-		    #',name)))))))
-
- 
-;;;; IR groveling macros:
-
-;;; Do-Blocks, Do-Blocks-Backwards  --  Interface
-;;;    
-(defmacro do-blocks ((block-var component &optional ends result) &body body)
-  "Do-Blocks (Block-Var Component [Ends] [Result-Form]) {Declaration}* {Form}*
-  Iterate over the blocks in a component, binding Block-Var to each block in
-  turn.  The value of Ends determines whether to iterate over dummy head and
-  tail blocks:
-    NIL   -- Skip Head and Tail (the default)
-    :Head -- Do head but skip tail
-    :Tail -- Do tail but skip head
-    :Both -- Do both head and tail
-
-  If supplied, Result-Form is the value to return."
-  (unless (member ends '(nil :head :tail :both))
-    (error "Losing Ends value: ~S." ends))
-  (let ((n-component (gensym))
-	(n-tail (gensym)))
-    `(let* ((,n-component ,component)
-	    (,n-tail ,(if (member ends '(:both :tail))
-			  nil
-			  `(component-tail ,n-component))))
-       (do ((,block-var ,(if (member ends '(:both :head))
-			     `(component-head ,n-component)
-			     `(block-next (component-head ,n-component)))
-	                (block-next ,block-var)))
-	   ((eq ,block-var ,n-tail) ,result)
-	 ,@body))))
-;;;
-(defmacro do-blocks-backwards ((block-var component &optional ends result) &body body)
-  "Do-Blocks-Backwards (Block-Var Component [Ends] [Result-Form]) {Declaration}* {Form}*
-  Like Do-Blocks, only iterate over the blocks in reverse order."
-  (unless (member ends '(nil :head :tail :both))
-    (error "Losing Ends value: ~S." ends))
-  (let ((n-component (gensym))
-	(n-head (gensym)))
-    `(let* ((,n-component ,component)
-	    (,n-head ,(if (member ends '(:both :head))
-			  nil
-			  `(component-head ,n-component))))
-       (do ((,block-var ,(if (member ends '(:both :tail))
-			     `(component-tail ,n-component)
-			     `(block-prev (component-tail ,n-component)))
-	                (block-prev ,block-var)))
-	   ((eq ,block-var ,n-head) ,result)
-	 ,@body))))
-
-
-;;; Do-Uses  --  Interface
-;;;
-;;;    Could change it not to replicate the code someday perhaps...
-;;;
-(defmacro do-uses ((node-var continuation &optional result) &body body)
-  "Do-Uses (Node-Var Continuation [Result]) {Declaration}* {Form}*
-  Iterate over the uses of Continuation, binding Node to each one succesively."
-  (once-only ((n-cont continuation))
-    `(ecase (continuation-kind ,n-cont)
-       (:unused)
-       (:inside-block 
-	(block nil
-	  (let ((,node-var (continuation-use ,n-cont)))
-	    ,@body
-	    ,result)))
-       ((:block-start :deleted-block-start)
-	(dolist (,node-var (block-start-uses (continuation-block ,n-cont))
-			   ,result)
-	  ,@body)))))
-
-
-;;; Do-Nodes, Do-Nodes-Backwards  --  Interface
-;;;
-;;;    In the forward case, we terminate on Last-Cont so that we don't have to
-;;; worry about our termination condition being changed when new code is added
-;;; during the iteration.  In the backward case, we do NODE-PREV before
-;;; evaluating the body so that we can keep going when the current node is
-;;; deleted.
-;;;
-(defmacro do-nodes ((node-var cont-var block &optional result) &body body)
-  "Do-Nodes (Node-Var Cont-Var Block [Result]) {Declaration}* {Form}*
-  Iterate over the nodes in Block, binding Node-Var to the each node and
-  Cont-Var to the node's Cont."
-  (let ((n-block (gensym))
-	(n-last-cont (gensym)))
-    `(let* ((,n-block ,block)
-	    (,n-last-cont (node-cont (block-last ,n-block))))
-       (do* ((,node-var (continuation-next (block-start ,n-block))
-			(continuation-next ,cont-var))
-	     (,cont-var (node-cont ,node-var) (node-cont ,node-var)))
-	    (())
-	 ,@body
-	 (when (eq ,cont-var ,n-last-cont)
-	   (return ,result))))))
-;;;
-(defmacro do-nodes-backwards ((node-var cont-var block &optional result)
-			      &body body)
-  "Do-Nodes-Backwards (Node-Var Cont-Var Block [Result]) {Declaration}* {Form}*
-  Like Do-Nodes, only iterates in reverse order."
-  (let ((n-block (gensym))
-	(n-start (gensym))
-	(n-last (gensym))
-	(n-next (gensym)))
-    `(let* ((,n-block ,block)
-	    (,n-start (block-start ,n-block))
-	    (,n-last (block-last ,n-block)))
-       (do* ((,cont-var (node-cont ,n-last) ,n-next)
-	     (,node-var ,n-last (continuation-use ,cont-var))
-	     (,n-next (node-prev ,node-var) (node-prev ,node-var)))
-	    (())
-	 ,@body
-	 (when (eq ,n-next ,n-start)
-	   (return ,result))))))
-
-
-;;; With-IR1-Environment  --  Interface
-;;;
-;;;    The lexical environment is presumably already null...
-;;;
-(defmacro with-ir1-environment (node &rest forms)
-  "With-IR1-Environment Node Form*
-  Bind the IR1 context variables so that IR1 conversion can be done after the
-  main conversion pass has finished.
-
-  Care must be taken to ensure that blocks have the correct cleanup.  New
-  blocks will initially be created with the End-Cleanup of Node's block.  This
-  is not an issue if newly created blocks are inside a new function -- it is
-  only a problem if IR1 convert or Make-Block is called directly, and not if
-  IR1-Convert-Lambda is called."
-  (let ((n-node (gensym))
-	(n-block (gensym))
-	(n-cont (gensym))
-	(n-component (gensym)))
-    `(let* ((,n-node ,node)
-	    (,n-cont (node-prev ,n-node))
-	    (,n-block (continuation-block ,n-cont))
-	    (,n-component (block-component ,n-block))
-	    (*current-cleanup* (block-end-cleanup ,n-block))
-	    (*current-cookie* (node-cookie ,n-node))
-	    (*default-cookie* (node-default-cookie ,n-node))
-	    (*current-lambda* (block-lambda ,n-block))
-	    (*current-component* ,n-component)
-	    (*current-path* (node-source-path ,n-node))
-	    (*current-form* nil)
-	    (*fenv* ())
-	    (*inlines* ())
-	    (*type-restrictions* ())
-	    (*venv* ())
-	    (*benv* ())
-	    (*tenv* ()))
-       ,@forms)))
-
-
-;;; WITH-IR1-NAMESPACE  --  Interface
-;;;
-;;;    Bind the hashtables used for keeping track of global variables,
-;;; functions, &c.
-;;;
-(defmacro with-ir1-namespace (&body forms)
-  `(let ((*free-variables* (make-hash-table :test #'eq))
-	 (*free-functions* (make-hash-table :test #'equal))
-	 (*constants* (make-hash-table :test #'equal))
-	 (*source-paths* (make-hash-table :test #'eq)))
-     ,@forms))
-
-
-;;;; The Defprinter macro:
-
-(defvar *defprint-pretty* nil
-  "If true, defprinter print functions print each slot on a separate line.")
-
-
-;;; Defprinter-Prin1, Defprinter-Princ  --  Internal
-;;;
-;;;    These functions are called by the expansion of the Defprinter
-;;; macro to do the actual printing.
-;;;
-(proclaim '(ftype (function (symbol t stream fixnum) void)
-		  defprinter-prin1 defprinter-princ))
-(defun defprinter-prin1 (name value stream indent)
-  (if *defprint-pretty*
-      (format stream "~&~VT  ~A:~%~VT    ~S" indent name indent value)
-      (format stream "  ~A= ~S" name value)))
-;;;
-(defun defprinter-princ (name value stream indent)
-  (if *defprint-pretty*
-      (format stream "~&~VT  ~A:~%~VT    ~A" indent name indent value)
-      (format stream "  ~A= ~A" name value)))
-
-;;; Start-Defprinter, Finish-Defprinter  --  Internal
-;;;
-;;;    Start and finish the the printing of a defprinter function.
-;;;
-(proclaim '(ftype (function (symbol stream fixnum t) void)
-		  start-defprinter finish-defprinter))
-(defun start-defprinter (name stream indent object)
-  (declare (ignore indent))
-  (format stream "#<~S ~X" name (system:%primitive make-fixnum object)))
-;;;
-(defun finish-defprinter (name stream indent)
-  (declare (ignore name))
-  (if *defprint-pretty*
-      (format stream ">~%~VT" indent)
-      (format stream ">")))
-
-(defmacro defprinter (name &rest slots)
-  "Defprinter Name Slot-Desc*
-  Define some kind of reasonable defstruct structure-print function.  Name
-  is the name of the structure.  We define a function %PRINT-name which
-  prints the slots in the structure in the way described by the Slot-Descs.
-  Each Slot-Desc can be a slot name, indicating that the slot should simply
-  be printed.  A Slot-Desc may also be a list of a slot name and other stuff.
-  The other stuff is composed of keywords followed by expressions.  The
-  expressions are evaluated with the variable which is the slot name bound
-  to the value of the slot.  These keywords are defined:
-  
-  :PRIN1    Print the value of the expression instead of the slot value.
-  :PRINC    Like :PRIN1, only princ the value
-  :TEST     Only print something if the test is true.
-  
-  If no printing thing is specified then the slot value is printed as PRIN1.
-  
-  The structure being printed is bound to Structure and the stream is bound to
-  Stream."
-  
-  (let ((n-indent (gensym)))
-    (flet ((sref (slot) `(,(symbolicate name "-" slot) structure)))
-      (collect ((prints))
-	(dolist (slot slots)
-	  (if (atom slot)
-	      (prints `(defprinter-prin1 ',slot ,(sref slot) stream ,n-indent))
-	      (let ((sname (first slot))
-		    (test t))
-		(collect ((stuff))
-		  (do ((option (rest slot) (cddr option)))
-		      ((null option)
-		       (prints		
-			`(let ((,sname ,(sref sname)))
-			   (when ,test
-			     ,@(or (stuff)
-				   `((defprinter-prin1 ',sname ,sname
-				       stream ,n-indent)))))))
-		    (case (first option)
-		      (:prin1
-		       (stuff `(defprinter-prin1 ',sname ,(second option)
-				 stream ,n-indent)))
-		      (:princ
-		       (stuff `(defprinter-princ ',sname ,(second option)
-				 stream ,n-indent)))
-		      (:test (setq test (second option)))
-		      (t
-		       (error "Losing Defprinter option: ~S." (first option)))))))))
-	
-	`(defun ,(symbolicate "%PRINT-" name) (structure stream depth)
-	   (let ((,n-indent (lisp::charpos stream)))
-	     (start-defprinter ',name stream ,n-indent structure)
-	     (let ((*print-level* (if *print-level* (- *print-level* depth 1))))
-	       (unless (and *print-level* (<= *print-level* 0))
-		 ,@(prints))
-	     (finish-defprinter ',name stream ,n-indent)
-	     nil)))))))
-
-
-;;;; Boolean attribute utilities:
-;;;
-;;;    We need to maintain various sets of boolean attributes for known
-;;; functions and VOPs.  To save space and allow for quick set operations, we
-;;; represent them as bits in a fixnum.
-;;;
-
-(deftype attributes () 'fixnum)
-
-(eval-when (#-new-compiler compile load eval)
-;;; Compute-Attribute-Mask  --  Internal
-;;;
-;;;    Given a list of attribute names and an alist that translates them to
-;;; masks, return the OR of the masks.
-;;;
-(defun compute-attribute-mask (names alist)
-  (collect ((res 0 logior))
-    (dolist (name names)
-      (let ((mask (cdr (assoc name alist))))
-	(unless mask
-	  (error "Unknown attribute name: ~S." name))
-	(res mask)))
-    (res)))
-
-); Eval-When (Compile Load Eval)
-
-;;; Def-Boolean-Attribute  --  Interface
-;;;
-;;;    Parse the specification and generate some accessor macros.
-;;;
-(defmacro def-boolean-attribute (name &rest attribute-names)
-  "Def-Boolean-Attribute Name Attribute-Name*
-  Define a new class of boolean attributes, with the attributes havin the
-  specified Attribute-Names.  Name is the name of the class, which is used to
-  generate some macros to manipulate sets of the attributes: 
-
-    NAME-attributep attributes attribute-name*
-      Return true if one of the named attributes is present, false otherwise.
-
-    NAME-attributes attribute-name*
-      Return a set of the named attributes."
-
-  (let ((const-name (symbolicate name "-ATTRIBUTE-TRANSLATIONS")))
-    (collect ((alist))
-      (do ((mask 1 (ash mask 1))
-	   (names attribute-names (cdr names)))
-	  ((null names))
-	(alist (cons (car names) mask)))
-	 
-      `(progn
-	(eval-when (compile load eval)
-	  (defconstant ,const-name ',(alist)))
-
-	(defmacro ,(symbolicate name "-ATTRIBUTEP")
-		  (attributes &rest attribute-names)
-	  "Automagically generated boolean attribute test function.  See
-	  Def-Boolean-Attribute."
-	  `(logtest ,(compute-attribute-mask attribute-names ,const-name)
-		    (the attributes ,attributes)))
-
-	(defmacro ,(symbolicate name "-ATTRIBUTES") (&rest attribute-names)
-	  "Automagically generated boolean attribute creation function.  See
-	  Def-Boolean-Attribute."
-	  (compute-attribute-mask attribute-names ,const-name))))))
-
-
-;;; Attributes-Union, Attributes-Intersection, Attributes=  --  Interface
-;;;
-;;;    And now for some gratuitous pseudo-abstraction...
-;;;
-(defmacro attributes-union (&rest attributes)
-  "Returns the union of all the sets of boolean attributes which are its
-  arguments." 
-  `(the attributes
-	(logior ,@(mapcar #'(lambda (x) `(the attributes ,x)) attributes))))
-;;;
-(defmacro attributes-intersection (&rest attributes)
-  "Returns the intersection of all the sets of boolean attributes which are its
-  arguments." 
-  `(the attributes
-	(logand ,@(mapcar #'(lambda (x) `(the attributes ,x)) attributes))))
-;;;
-(proclaim '(inline attributes=))
-(proclaim '(function attributes= (attributes attributes) boolean))
-(defun attributes= (attr1 attr2)
-  "Returns true if the attributes present in Attr1 are indentical to those in
-  Attr2."
-  (eql attr1 attr2))
-
-
-;;;; The Event statistics/trace utility:
-
-(eval-when (#-new-compiler compile load eval)
-
-(defstruct event-info
-  ;;
-  ;; The name of this event.
-  (name nil :type symbol)
-  ;;
-  ;; The string rescribing this event.
-  (description nil :type string)
-  ;;
-  ;; The name of the variable we stash this in.
-  (var nil :type symbol)
-  ;;
-  ;; The number of times this event has happened.
-  (count 0 :type fixnum)
-  ;;
-  ;; The level of significance of this event.
-  (level nil :type unsigned-byte)
-  ;;
-  ;; If true, a function that gets called with the node that the event happened
-  ;; to.
-  (action nil :type (or function null)))
-
-
-;;; A hashtable from event names to event-info structures.
-;;;
-(defvar *event-info* (make-hash-table :test #'eq))
-
-
-;;; Event-Info-Or-Lose  --  Internal
-;;;
-;;;    Return the event info for Name or die trying.
-;;;
-(proclaim '(function event-info-or-lose (t) event-info))
-(defun event-info-or-lose (name)
-  (let ((res (gethash name *event-info*)))
-    (unless res
-      (error "~S is not the name of an event." name))
-    res))
-
-); Eval-When (Compile Load Eval)
-
-
-;;; Event-Count, Event-Action, Event-Level  --  Interface
-;;;
-(proclaim '(function event-count (symbol) fixnum))
-(defun event-count (name)
-  "Return the number of times that Event has happened."
-  (event-info-count (event-info-or-lose name)))
-;;;
-(proclaim '(function event-action (symbol) (or function null)))
-(defun event-action (name)
-  "Return the function that is called when Event happens.  If this is null,
-  there is no action.  The function is passed the node to which the event
-  happened, or NIL if there is no relevant node.  This may be set with SETF."
-  (event-info-action (event-info-or-lose name)))
-;;;
-(proclaim '(function %set-event-action (symbol (or function null)) (or function null)))
-(defun %set-event-action (name new-value)
-  (setf (event-info-action (event-info-or-lose name))
-	new-value))
-;;;
-(defsetf event-action %set-event-action)
-;;;
-(proclaim '(function event-level (symbol) unsigned-byte))
-(defun event-level (name)
-  "Return the non-negative integer which represents the level of significance
-  of the event Name.  This is used to determine whether to print a message when
-  the event happens.  This may be set with SETF."
-  (event-info-level (event-info-or-lose name)))
-;;;
-(proclaim '(function %set-event-level (symbol unsigned-byte) unsigned-byte))
-(defun %set-event-level (name new-value)
-  (setf (event-info-level (event-info-or-lose name))
-	new-value))
-;;;
-(defsetf event-level %set-event-level)
-
-
-;;; Defevent  --  Interface
-;;;
-;;;    Make an event-info structure and stash it in a variable so we can get at
-;;; it quickly.
-;;;
-(defmacro defevent (name description &optional (level 0))
-  "Defevent Name Description
-  Define a new kind of event.  Name is a symbol which names the event and
-  Description is a string which describes the event.  Level (default 0) is the
-  level of significance associated with this event; it is used to determine
-  whether to print a Note when the event happens."
-  (let ((var-name (symbolicate "*" name "-EVENT-INFO*")))
-    `(eval-when (compile load eval)
-       (defvar ,var-name
-	 (make-event-info :name ',name :description ',description :var ',var-name
-			  :level ,level))
-       (setf (gethash ',name *event-info*) ,var-name)
-       ',name)))
-
-(proclaim '(type unsigned-byte *event-note-threshold*))
-(defvar *event-note-threshold* 1
-  "This variable is a non-negative integer specifying the lowest level of
-  event that will print a Note when it occurs.")
-
-;;; Event  --  Interface
-;;;
-;;;    Increment the counter and do any action.  Mumble about the event if
-;;; policy indicates.
-;;;
-(defmacro event (name &optional node)
-  "Event Name Node
-  Note that the event with the specified Name has happened.  Node is evaluated
-  to determine the node to which the event happened."
-  `(%event ,(event-info-var (event-info-or-lose name)) ,node))
-;;;
-(proclaim '(function %event (event-info (or node null))))
-(defun %event (info node)
-  (incf (event-info-count info))
-  (when (and (>= (event-info-level info) *event-note-threshold*)
-	     (if node
-		 (policy node (= brevity 0))
-		 (policy nil (= brevity 0))))
-    (let ((*compiler-error-context* node))
-      (compiler-note (event-info-description info))))
-
-  (let ((action (event-info-action info)))
-    (when action (funcall action node))))
-
-
-;;; Event-Statistics, Clear-Statistics  --  Interface
-;;;
-(proclaim '(function event-statistics (&optional unsigned-byte stream) void))
-(defun event-statistics (&optional (min-count 1) (stream *standard-output*))
-  "Print a listing of events and their counts, sorted by the count.  Events
-  that happened fewer than Min-Count times will not be printed.  Stream is the
-  stream to write to."
-  (collect ((info))
-    (maphash #'(lambda (k v)
-		 (declare (ignore k))
-		 (when (>= (event-info-count v) min-count)
-		   (info v)))
-	     *event-info*)
-    (dolist (event (sort (info) #'> :key #'event-info-count))
-      (format stream "~6D: ~A~%" (event-info-count event)
-	      (event-info-description event)))
-    (values)))
-;;;
-(proclaim '(function clear-statistics () void))
-(defun clear-statistics ()
-  (maphash #'(lambda (k v)
-	       (declare (ignore k))
-	       (setf (event-info-count v) 0))
-	   *event-info*)
-  (values))
-
diff --git a/compiler/main.lisp b/compiler/main.lisp
deleted file mode 100644
index b0812f4dafce4dcc91c1130a3a2f3fcf6b3e6006..0000000000000000000000000000000000000000
--- a/compiler/main.lisp
+++ /dev/null
@@ -1,1130 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    This file contains the top-level interfaces to the compiler.
-;;; 
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-(proclaim '(special *constants* *free-variables* *compile-component*
-		    *code-vector* *next-location* *result-fixups*
-		    *free-functions* *source-paths* *failed-optimizations*
-		    *seen-blocks* *seen-functions* *list-conflicts-table*
-		    *continuation-number* *continuation-numbers*
-		    *number-continuations* *tn-id* *tn-ids* *id-tns*
-		    *label-ids* *label-id* *id-labels* *sb-list*
-		    *unknown-functions* *compiler-error-count*
-		    *compiler-warning-count* *compiler-note-count*
-		    *compiler-error-output* *compiler-error-bailout*
-		    *compiler-trace-output*
-		    *last-source-context* *last-original-source*
-		    *last-source-form* *last-format-string* *last-format-args*
-		    *last-message-count* *fenv*))
-
-(defparameter compiler-version "0.0")
-
-(defvar *check-consistency* t)
-(defvar *all-components*)
-
-;;; The value of the :Block-Compile argument that Compile-File was called with.
-;;;
-(defvar *block-compile*)
-
-;;; When block compiling, used by PROCESS-FORM to accumulate top-level lambdas
-;;; resulting from compiling subforms.  (In reverse order.)
-;;;
-(defvar *top-level-lambdas*)
-
-;;; Used to control compiler verbosity.
-;;;
-(defvar *compile-verbose* nil)
-
-;;; The values of *Package* and *Default-Cookie* when compilation started.
-;;;
-(defvar *initial-package*)
-(defvar *initial-cookie*)
-
-;;; The source-info structure for the current compilation.  This is null
-;;; globally to indicate that we aren't currently in any identifiable
-;;; compilation.
-;;;
-(defvar *source-info* nil)
-
-
-;;; Maybe-Mumble  --  Internal
-;;;
-;;;    Mumble conditional on *Compile-Verbose*.
-;;;
-(defun maybe-mumble (&rest foo)
-  (when *compile-verbose*
-    (apply #'compiler-mumble foo)))
-
-(deftype object () '(or fasl-file core-object null))
-
-
-;;;; Component compilation:
-
-(defparameter max-optimize-iterations 3
-  "The upper limit on the number of times that we will consecutively do IR1
-  optimization that doesn't introduce any new code.  A finite limit is
-  necessary, since type inference may take arbitrarily long to converge.")
-
-(defevent ir1-optimize-until-done "IR1-OPTIMIZE-UNTIL-DONE called.")
-(defevent ir1-optimize-maxed-out "Hit MAX-OPTIMIZE-ITERATIONS limit.")
-
-;;; IR1-Optimize-Until-Done  --  Internal
-;;;
-;;;    Repeatedly optimize Component until no further optimizations can be
-;;; found or we hit our iteration limit.  When we hit the limit, we clear the
-;;; component and block REOPTIMIZE flags to discourage following the next
-;;; optimization attempt from pounding on the same code.
-;;;
-(defun ir1-optimize-until-done (component)
-  (declare (type component component))
-  (maybe-mumble "Opt")
-  (event ir1-optimize-until-done)
-  (let ((count 0)
-	(cleared-reanalyze nil))
-    (loop
-      (when (component-reanalyze component)
-	(setq count 0)
-	(setq cleared-reanalyze t)
-	(setf (component-reanalyze component) nil))
-      (setf (component-reoptimize component) nil)
-      (ir1-optimize component)
-      (unless (component-reoptimize component)
-	(maybe-mumble " ")
-	(return))
-      (incf count)
-      (when (= count max-optimize-iterations)
-	(event ir1-optimize-maxed-out)
-	(maybe-mumble "* ")
-	(setf (component-reoptimize component) nil)
-	(do-blocks (block component)
-	  (setf (block-reoptimize block) nil))
-	(return))
-      (maybe-mumble "."))
-    (when cleared-reanalyze
-      (setf (component-reanalyze component) t)))
-  (undefined-value))
-
-(defvar *constraint-propagate* t)
-
-;;; IR1-Phases  --  Internal
-;;;
-;;;    Do all the IR1 phases for a non-top-level component.
-;;;
-(defun ir1-phases (component)
-  (declare (type component component))
-  (let ((*constraint-number* 0))
-    (declare (special *constraint-number*))
-    (tagbody
-     TOP
-      (ir1-optimize-until-done component)
-      (when (component-reanalyze component) (go DFO))
-      (when *constraint-propagate*
-	(maybe-mumble "Constraint ")
-	(constraint-propagate component))
-      (maybe-mumble "Type ")
-      (generate-type-checks component)
-      (unless (or (component-reoptimize component)
-		  (component-reanalyze component))
-	(go DONE))
-      
-      (go TOP)
-     DFO
-      (maybe-mumble "DFO ")
-      (find-dfo component)
-      (go TOP)
-     DONE)
-    (undefined-value)))
-
-
-;;; Compile-Component  --  Internal
-;;;
-(defun compile-component (component object)
-  (compiler-mumble "Compiling ~A: " (component-name component))
-  
-  (ir1-phases component)
-  
-  #|
-  (maybe-mumble "Dom ")
-  (find-dominators component)
-  (maybe-mumble "Loop ")
-  (loop-analyze component)
-  |#
-
-  (let ((*compile-component* component))
-    (maybe-mumble "Env ")
-    (environment-analyze component)
-    (maybe-mumble "GTN ")
-    (gtn-analyze component)
-    (maybe-mumble "Control ")
-    (control-analyze component)
-    (maybe-mumble "LTN ")
-    (ltn-analyze component)
-
-    (when (ir2-component-values-receivers (component-info component))
-      (maybe-mumble "Stack ")
-      (stack-analyze component))
-
-    (when (component-reanalyze component)
-      (find-dfo component))
-
-    (maybe-mumble "IR2Tran ")
-    (init-assembler)
-    (entry-analyze component)
-    (ir2-convert component)
-
-    (when *check-consistency*
-      (maybe-mumble "Check2 ")
-      (check-ir2-consistency component))
-    
-    (maybe-mumble "Life ")
-    (lifetime-analyze component)
-
-    (when *compile-verbose*
-      (compiler-mumble "") ; Sync before doing random output.
-      (pre-pack-tn-stats component *compiler-error-output*))
-
-    (delete-unreferenced-tns component)
-
-    (when *check-consistency*
-      (maybe-mumble "CheckL ")
-      (check-life-consistency component))
-
-    (maybe-mumble "Pack ")
-    (pack component)
-
-    (when *compiler-trace-output*
-      (describe-component component *compiler-trace-output*))
-    
-    (maybe-mumble "Code ")
-    (generate-code component))
-
-  (etypecase object
-    (fasl-file
-     (maybe-mumble "FASL")
-     (fasl-dump-component component *code-vector* *next-location*
-			  *assembler-nodes* (1+ *current-assembler-node*)
-			  *result-fixups* object))
-    (core-object
-     (maybe-mumble "Core"
-     (make-core-component component *code-vector* *next-location*
-			  *assembler-nodes* (1+ *current-assembler-node*)
-			  *result-fixups* object)))
-    (null))
-
-  (compiler-mumble "~%")
-  (undefined-value))
-
-
-;;;; Clearing global data structures:
-
-;;; CLEAR-IR2-INFO  --  Internal
-;;;
-;;;    Clear all the INFO slots in sight in Component to allow the IR2 data
-;;; structures to be reclaimed.  We also clear the INFO in constants in the
-;;; *FREE-VARIABLES*, etc.  The latter is required for correct assignment of
-;;; costant TNs, in addition to allowing stuff to be reclaimed.
-;;;
-;;;    We don't clear the FUNCTIONAL-INFO slots, since they are used to keep
-;;; track of functions across component boundaries.
-;;;
-(defun clear-ir2-info (component)
-  (declare (type component component))
-  (setf (component-info component) nil)
-
-  (do-blocks (block component)
-    (setf (block-info block) nil)
-    (do-nodes (node cont block)
-      (setf (continuation-info cont) nil)
-      (when (basic-combination-p node)
-	(setf (basic-combination-info node) nil))))
-
-  (dolist (fun (component-lambdas component))
-    (let ((tails (lambda-tail-set fun)))
-      (when tails
-	(setf (tail-set-info tails) nil)))
-    (let ((env (lambda-environment fun)))
-      (setf (environment-info env) nil)
-      (dolist (nlx (environment-nlx-info env))
-	(setf (nlx-info-info nlx) nil)))
-    (dolist (var (lambda-vars fun))
-      (setf (leaf-info var) nil)))
-
-  (maphash #'(lambda (k v)
-	       (declare (ignore k))
-	       (setf (leaf-info v) nil))
-	   *constants*)
-
-  (maphash #'(lambda (k v)
-	       (declare (ignore k))
-	       (when (constant-p v)
-		 (setf (leaf-info v) nil)))
-	   *free-variables*)
-
-  (undefined-value))
-
-
-;;;
-(defun clear-stuff ()
-  ;;
-  ;; Clear global tables.
-  (clrhash *free-functions*)
-  (clrhash *free-variables*)
-  (clrhash *constants*)
-  (clrhash *source-paths*)
-  (clrhash *failed-optimizations*)
-  ;;
-  ;; Clear debug counters and tables.
-  (clrhash *seen-blocks*)
-  (clrhash *seen-functions*)
-  (clrhash *list-conflicts-table*)
-  (clrhash *continuation-numbers*)
-  (clrhash *number-continuations*)
-  (setq *continuation-number* 0)
-  (clrhash *tn-ids*)
-  (clrhash *id-tns*)
-  (setq *tn-id* 0)
-  (clrhash *label-ids*)
-  (clrhash *id-labels*)
-  (setq *label-id* 0)
-  ;;
-  ;; Clear some Pack data structures (for GC purposes only.)
-  (dolist (sb *sb-list*)
-    (when (finite-sb-p sb)
-      (fill (finite-sb-live-tns sb) nil)))
-  ;;
-  ;; Reset Gensym.
-  (setq lisp:*gensym-counter* 0))
-
-
-;;; PRINT-SUMMARY  --  Interface
-;;;
-;;;    This function is called by WITH-COMPILATION-UNIT at the end of a
-;;; compilation unit.  It prints out any residual unknown function warnings and
-;;; the total error counts.  Abort-P should be true when the compilation unit
-;;; was aborted by throwing out.  Abort-Count is the number of dynamically
-;;; enclosed nested compilation units that were aborted.
-;;;
-(defun print-summary (abort-p abort-count)
-  (unless abort-p
-    (let ((funs (sort *unknown-functions* #'string<
-		      :key #'(lambda (x)
-			       (let ((x (unknown-function-name x)))
-				 (if (symbolp x)
-				     (symbol-name x)
-				     (symbol-name (cadr x))))))))
-      (dolist (fun funs)
-	(let ((name (unknown-function-name fun))
-	      (warnings (unknown-function-warnings fun))
-	      (count (unknown-function-count fun)))
-	  (dolist (*compiler-error-context* warnings)
-	    (compiler-warning "Call to unknown function."))
-	  
-	  (let ((warn-count (length warnings)))
-	    (when (> count warn-count)
-	      (let ((more (- count warn-count)))
-		(compiler-warning
-		 "~D ~:[~;more ~]call~P to unknown function ~S."
-		 more warnings more name))))))))
-
-  (compiler-mumble
-   "~2&Compilation unit ~:[finished~;aborted~].~
-    ~[~:;~:*~&  ~D fatal error~:P~]~
-    ~[~:;~:*~&  ~D error~:P~]~
-    ~[~:;~:*~&  ~D warning~:P~]~
-    ~[~:;~:*~&  ~D note~:P~]~2%"
-   abort-p
-   abort-count
-   *compiler-error-count*
-   *compiler-warning-count*
-   *compiler-note-count*))
-   
-   
-;;; Describe-Component  --  Internal
-;;;
-;;;    Print out some useful info about Component to Stream.
-;;;
-(defun describe-component (component &optional
-				     (*standard-output* *standard-output*))
-  (declare (type component component) (type stream stream))
-  (format t "~|~%;;;; Component: ~S~2%" (component-name component))
-  (print-blocks component)
-  
-  (format t "~%~|~%;;;; IR2 component: ~S~2%" (component-name component))
-  
-  (format t "Entries:~%")
-  (dolist (entry (ir2-component-entries (component-info component)))
-    (format t "~4TL~D: ~S~:[~; [Closure]~]~%"
-	    (label-id (entry-info-offset entry))
-	    (entry-info-name entry)
-	    (entry-info-closure-p entry)))
-  
-  (terpri)
-  (pre-pack-tn-stats component *standard-output*)
-  (terpri)
-  (print-ir2-blocks component)
-  (terpri)
-  
-  (undefined-value))
-
-
-;;; Compile-Top-Level  --  Internal
-;;;
-;;;    Compile Lambdas (a list of the lambdas for top-level forms) into the
-;;; Object file.
-;;;
-(defun compile-top-level (lambdas object)
-  (declare (list lambdas) (type object object))
-  (maybe-mumble "Local call analyze")
-  (dolist (lambda lambdas)
-    (let* ((component (block-component (node-block (lambda-bind lambda))))
-	   (*all-components* (list component)))
-      (local-call-analyze component)))
-  (maybe-mumble ".~%")
-  
-  (maybe-mumble "Find components")
-  (let* ((components (find-initial-dfo lambdas))
-	 (*all-components* components))
-    
-    (when *check-consistency*
-      (maybe-mumble "[Check]~%")
-      (check-ir1-consistency components))
-    
-    (dolist (component components)
-      (compile-component component object)
-      (clear-ir2-info component))
-
-    (etypecase object
-      (fasl-file
-       (dolist (lambda lambdas)
-	 (fasl-dump-top-level-lambda-call lambda object)))
-      (core-object
-       (dolist (lambda lambdas)
-	 (core-call-top-level-lambda lambda object)))
-      (null))
-    
-    (when *check-consistency*
-      (maybe-mumble "[Check]~%")
-      (check-ir1-consistency components))
-    
-    (ir1-finalize)
-    (undefined-value)))
-
-
-;;;; File reading:
-;;;
-;;;    When reading from a file, we have to keep track of some source
-;;; information.  We also exploit our ability to back up for printing the error
-;;; context and for recovering from errors.
-;;;
-;;; The interface we provide to this stuff is the stream-oid Source-Info
-;;; structure.  The bookkeeping is done as a side-effect of getting the next
-;;; source form.
-
-
-;;; The File-Info structure holds all the source information for a given file.
-;;;
-(defstruct file-info
-  ;;
-  ;; If a file, the truename of the corresponding source file.  If from a Lisp
-  ;; form, :LISP, if from a stream, :STREAM.
-  (name nil :type (or pathname (member :lisp :stream)))
-  ;;
-  ;; The file's write date (if relevant.)
-  (write-date nil :type (or unsigned-byte null))
-  ;;
-  ;; The source path root number of the first form in this file (i.e. the
-  ;; total number of forms converted previously in this compilation.)
-  (source-root 0 :type unsigned-byte)
-  ;;
-  ;; Parallel vectors containing the forms read out of the file and the file
-  ;; positions that reading of each form started at (i.e. the end of the
-  ;; previous form.)
-  (forms (make-array 10 :fill-pointer 0 :adjustable t) (vector t))
-  (positions (make-array 10 :fill-pointer 0 :adjustable t) (vector t)))
-
-
-;;; The Source-Info structure provides a handle on all the source information
-;;; for an entire compilation.
-;;;
-(defstruct (source-info
-	    (:print-function
-	     (lambda (s stream d)
-	       (declare (ignore s d))
-	       (format stream "#<Source-Info>"))))
-  ;;
-  ;; The UT that compilation started at.
-  (start-time (get-universal-time) :type unsigned-byte)
-  ;;
-  ;; A list of the file-info structures for this compilation.
-  (files nil :type list)
-  ;;
-  ;; The tail of the Files for the file we are currently reading.
-  (current-file nil :type list)
-  ;;
-  ;; The stream that we are using to read the Current-File.  Null if no stream
-  ;; has been opened yet.
-  (stream nil :type (or stream null)))
-
-
-;;; Make-File-Source-Info  --  Internal
-;;;
-;;;    Given a list of pathnames, return a Source-Info structure.
-;;;
-(defun make-file-source-info (files)
-  (declare (list files))
-  (let ((file-info
-	 (mapcar #'(lambda (x)
-		     (make-file-info :name x
-				     :write-date (file-write-date x)))
-		 files)))
-
-    (make-source-info :files file-info
-		      :current-file file-info)))
-
-
-;;; MAKE-LISP-SOURCE-INFO  --  Interface
-;;;
-;;;    Return a SOURCE-INFO to describe the incremental compilation of Form.
-;;; Also used by EVAL:INTERNAL-EVAL.
-;;;
-(defun make-lisp-source-info (form)
-  (make-source-info
-   :start-time (get-universal-time)
-   :files (list (make-file-info :name :lisp
-				:forms (vector form)
-				:positions '#(0)))))
-
-
-;;; MAKE-STREAM-SOURCE-INFO  --  Internal
-;;;
-;;;    Return a SOURCE-INFO which will read from Stream.
-;;;
-(defun make-stream-source-info (stream)
-  (let ((files (list (make-file-info :name :stream))))
-    (make-source-info
-     :files files
-     :current-file files
-     :stream stream)))
-
-
-;;; Normal-Read-Error  --  Internal
-;;;
-;;;    Print an error message for a non-EOF error on Stream.  Old-Pos is a
-;;; preceding file position that hopefully comes before the beginning of the
-;;; line.  Of course, this only works on streams that support the file-position
-;;; operation.
-;;;
-(defun normal-read-error (stream old-pos condition)
-  (declare (type stream stream) (type unsigned-byte old-pos pos))
-  (let ((pos (file-position stream)))
-    (file-position stream old-pos)
-    (let ((start old-pos))
-      (loop
-	(let ((line (read-line stream nil))
-	      (end (file-position stream)))
-	  (when (>= end pos)
-	    (compiler-error-message
-	     "Read error at ~D:~% \"~A/\\~A\"~%~A"
-	     pos
-	     (string-left-trim " 	"
-			       (subseq line 0 (- pos start)))
-	     (subseq line (- pos start))
-	     condition)
-	    (return))
-	  (setq start end)))))
-  (undefined-value))
-
-
-;;; Ignore-Error-Form  --  Internal
-;;;
-;;;    Back Stream up to the position Pos, then read a form with
-;;; *Read-Suppress* on, discarding the result.  If an error happens during this
-;;; read, then bail out using Compiler-Error (fatal in this context).
-;;;
-(defun ignore-error-form (stream pos)
-  (declare (type stream stream) (type unsigned-byte pos))
-  (file-position stream pos)
-  (handler-case (let ((*read-suppress* t))
-		  (read stream))
-    (error (condition)
-      (declare (ignore condition))
-      (compiler-error "Unable to recover from read error."))))
-
-
-;;; Unexpected-EOF-Error  --  Internal
-;;;
-;;;    Print an error message giving some context for an EOF error.  We print
-;;; the first line after Pos that contains #\" or #\(, or lacking that, the
-;;; first non-empty line.
-;;;
-(defun unexpected-eof-error (stream pos condition)
-  (declare (type stream stream) (type unsigned-byte pos))
-  (let ((res nil))
-    (file-position stream pos)
-    (loop
-      (let ((line (read-line stream nil nil))) 
-	(unless line (return))
-	(when (or (find #\" line) (find #\( line))
-	  (setq res line)
-	  (return))
-	(unless (or res (zerop (length line)))
-	  (setq res line))))
-
-    (compiler-error-message
-     "Read error in form starting at ~D:~%~@[ \"~A\"~%~]~A"
-     pos res condition))
-
-  (file-position stream (file-length stream))
-  (undefined-value))
-
-
-;;; Careful-Read  --  Internal
-;;;
-;;;    Read a form from Stream, returning EOF at EOF.  If a read error happens,
-;;; then attempt to recover if possible, returing a proxy error form.
-;;;
-(defun careful-read (stream eof pos)
-  (handler-case (read stream nil eof)
-    (error (condition)
-      (let ((new-pos (file-position stream)))
-	(cond ((= new-pos (file-length stream))
-	       (unexpected-eof-error stream pos condition))
-	      (t
-	       (normal-read-error stream pos condition)
-	       (ignore-error-form stream pos))))
-      '(error "Attempt to load a file having a compile-time read error."))))
-
-
-;;; Get-Source-Stream  --  Internal
-;;;
-;;;    If Stream is present, return it, otherwise open a stream to the current
-;;; file.  There must be a current file.  When we open a new file, we also
-;;; reset *Package* and *Default-Cookie*.  This gives the effect of rebinding
-;;; around each file.
-;;;
-(defun get-source-stream (info)
-  (declare (type source-info info))
-  (cond ((source-info-stream info))
-	(t
-	 (setq *package* *initial-package*)
-	 (setq *default-cookie* (copy-cookie *initial-cookie*))
-	 (setf (source-info-stream info)
-	       (open (file-info-name (first (source-info-current-file info)))
-		     :direction :input)))))
-
-
-;;; CLOSE-SOURCE-INFO  --  Internal
-;;;
-;;;    Close the stream in Info if it is open.
-;;;
-(defun close-source-info (info)
-  (declare (type source-info info))
-  (let ((stream (source-info-stream info)))
-    (when stream (close stream)))
-  (setf (source-info-stream info) nil)
-  (undefined-value))
-
-
-;;; Advance-Source-File  --  Internal
-;;;
-;;;    Advance Info to the next source file.  If none, return NIL, otherwise T.
-;;;
-(defun advance-source-file (info)
-  (declare (type source-info info))
-  (close-source-info info)
-  (let ((prev (pop (source-info-current-file info))))
-    (if (source-info-current-file info)
-	(let ((current (first (source-info-current-file info))))
-	  (setf (file-info-source-root current)
-		(+ (file-info-source-root prev)
-		   (length (file-info-forms prev))))
-	  t)
-	nil)))
-
-
-;;; Read-Source-Form  --  Internal
-;;;
-;;;    Read the next form from the source designated by Info.  The second value
-;;; is the top-level form number of the read form.  The third value is true
-;;; when at EOF.
-;;;
-;;;   We carefully read from the current source file.  If it is at EOF, we
-;;; advance to the next file and try again.  When we get a form, we enter it
-;;; into the per-file Forms and Positions vectors.
-;;;
-(defun read-source-form (info) 
-  (declare (type source-info info))
-  (let ((eof '(*eof*)))
-    (loop
-      (let* ((file (first (source-info-current-file info)))
-	     (stream (get-source-stream info))
-	     (pos (file-position stream))
-	     (res (careful-read stream eof pos)))
-	(unless (eq res eof)
-	  (let* ((forms (file-info-forms file))
-		 (current-idx (+ (fill-pointer forms)
-				 (file-info-source-root file))))
-	    (vector-push-extend res forms)
-	    (vector-push-extend pos (file-info-positions file))
-	    (return (values res current-idx nil))))
-
-	(unless (advance-source-file info)
-	  (return (values nil nil t)))))))
-
-
-;;; Find-Source-Root  --  Interface
-;;;
-;;;    Return the Index'th source form read from Info and the position that it
-;;; was read at.
-;;;
-(defun find-source-root (index info)
-  (declare (type unsigned-byte index) (type source-info info))
-  (dolist (file (source-info-files info))
-    (let ((root (file-info-source-root file))
-	  (forms (file-info-forms file)))
-      (when (> (+ (length forms) root) index)
-	(let ((idx (- index root)))
-	  (return (values (aref forms idx)
-			  (aref (file-info-positions file) idx))))))))
-
-
-;;;; Top-level form processing:
-
-;;; CONVERT-AND-MAYBE-COMPILE  --  Internal
-;;;
-;;;    Called by top-level form processing when we are ready to actually
-;;; compile something.  If *BLOCK-COMPILE* is true, then we still convert the
-;;; form, but delay compilation, pushing the result on *TOP-LEVEL-LAMBDAS*
-;;; instead.
-;;; 
-(defun convert-and-maybe-compile (form tlf-num object)
-  (declare (type index tlf-num) (type object object))
-  (let ((tll (ir1-top-level form tlf-num nil)))
-    (cond (*block-compile* (push tll *top-level-lambdas*))
-	  (t
-	   (compile-top-level (list tll) object)
-	   (clear-stuff)))))
-
-
-;;; PROCESS-PROGN  --  Internal
-;;;
-;;;    Process a PROGN-like portion of a top-level form.  Forms is a list of
-;;; the forms, and TLF-Num is the top-level form number of the form they came
-;;; out of.
-;;;
-(defun process-progn (forms tlf-num object)
-  (declare (list forms) (type index tlf-num) (type object object))
-  (dolist (form forms)
-    (process-form form tlf-num object)))
-
-
-;;; PREPROCESSOR-MACROEXPAND  --  Internal
-;;;
-;;;    Macroexpand form in the current environment with an error handler.
-;;;
-(defun preprocessor-macroexpand (form)
-  (handler-case #+new-compiler (macroexpand form *fenv*)
-                #-new-compiler
-                (if (consp form)
-		    (let* ((name (car form))
-			   (exp (or (cddr (assoc name *fenv*))
-				    (info function macro-function name))))
-		      (if exp
-			  (funcall exp form *fenv*)
-			  form))
-		    form)
-    (error (condition)
-	   (compiler-error "(during macroexpansion)~%~A"
-			   condition))))
-
-
-(proclaim '(special *compiler-error-bailout*))
-
-;;; PROCESS-FORM  --  Internal
-;;;
-;;;    Process a top-level Form with the specified source Path and output to
-;;; Object.  If this is a magic top-level form, then do stuff, otherwise just
-;;; compile it.
-;;;
-;;; ### At least for now, always dump package frobbing as interpreted cold load
-;;; forms.  This might want to be on a switch someday.
-;;;
-(defun process-form (form tlf-num object)
-  (declare (type index tlf-num) (type object object))
-  (catch 'process-form-error-abort
-    (let* ((*compiler-error-bailout*
-	    #'(lambda ()
-		(convert-and-maybe-compile
-		 `(error "Execution of a form compiled with errors:~% ~S"
-			 ',form)
-		 tlf-num object)
-		(throw 'process-form-error-abort nil)))
-	   (form (preprocessor-macroexpand form)))
-      (if (atom form)
-	  (convert-and-maybe-compile form tlf-num object)
-	  (case (car form)
-	    ((make-package in-package shadow shadowing-import export
-			   unexport use-package unuse-package import)
-	     (eval form)
-	     (etypecase object
-	       (fasl-file (fasl-dump-cold-load-form form object))
-	       ((or null core-object))))
-	    ((eval-when)
-	     (unless (>= (length form) 2)
-	       (compiler-error "EVAL-WHEN form is too short: ~S." form))
-	     (do-eval-when-stuff
-	      (cadr form) (cddr form)
-	      #'(lambda (forms)
-		  (process-progn forms tlf-num object))))
-	    ((macrolet)
-	     (unless (>= (length form) 2)
-	       (compiler-error "MACROLET form is too short: ~S." form))
-	     (do-macrolet-stuff
-	      (cadr form)
-	      #'(lambda ()
-		  (process-progn (cddr form) tlf-num object))))
-	    (progn (process-progn (cdr form) tlf-num object))
-	    (t
-	     (convert-and-maybe-compile form tlf-num object))))))
-      
-  (undefined-value))
-
-
-;;;; COMPILE-FILE and COMPILE-FROM-STREAM: 
-
-;;; Sub-Compile-File  --  Internal
-;;;
-;;;    Read all forms from Info and compile them, with output to Object.  If
-;;; *Block-Compile* is true, we combine all the forms and compile as a unit,
-;;; otherwise we compile each one separately.  We return :ERROR, :WARNING,
-;;; :NOTE or NIL to indicate the most severe kind of compiler diagnostic
-;;; emitted.
-;;;
-(defun sub-compile-file (info object)
-  (declare (type source-info info) (type object object))
-  (with-compilation-unit ()
-    (let ((start-errors *compiler-error-count*)
-	  (start-warnings *compiler-warning-count*)
-	  (start-notes *compiler-note-count*))
-      (with-ir1-namespace
-	(clear-stuff)
-	(let* ((*package* *package*)
-	       (*initial-package* *package*)
-	       (*initial-cookie* *default-cookie*)
-	       (*default-cookie* (copy-cookie *initial-cookie*))
-	       (*current-cookie* (make-cookie))
-	       (*fenv* ())
-	       (*source-info* info)
-	       (*top-level-lambdas* ())
-	       (*compiler-error-bailout*
-		#'(lambda ()
-		    (compiler-mumble
-		     "~2&Fatal error, aborting compilation...~%")
-		    (return-from sub-compile-file :error)))
-	       (*last-source-context* nil)
-	       (*last-original-source* nil)
-	       (*last-source-form* nil)
-	       (*last-format-string* nil)
-	       (*last-format-args* nil)
-	       (*last-message-count* 0))
-	  (loop
-	    (multiple-value-bind (form tlf eof-p)
-				 (read-source-form info)
-	      (when eof-p (return))
-	      (clrhash *source-paths*)
-	      (find-source-paths form tlf)
-	      (process-form form tlf object)))
-	  
-	  (when *block-compile*
-	    (compile-top-level (nreverse *top-level-lambdas*) object)
-	    (clear-stuff))
-	  
-	  (etypecase object
-	    (fasl-file (fasl-dump-source-info info object))
-	    (core-object (fix-core-source-info info object))
-	    (null))))
-      
-      (cond ((> *compiler-error-count* start-errors) :error)
-	    ((> *compiler-warning-count* start-warnings) :warning)
-	    ((> *compiler-note-count* start-notes) :note)
-	    (t nil)))))
-
-
-;;; Verify-Source-Files  --  Internal
-;;;
-;;;    Return a list of pathnames that are the truenames of all the named
-;;; files.
-;;;
-(defun verify-source-files (stuff)
-  (unless stuff
-    (error "Can't compile with no source files."))
-  (mapcar #'(lambda (x)
-	      (or (probe-file x)
-		  (truename
-		   (merge-pathnames x (make-pathname :type "lisp")))))
-	  (if (listp stuff) stuff (list stuff))))
-
-
-#+new-compiler
-;;; COMPILE-FROM-STREAM  --  Public
-;;;
-;;;    Just call SUB-COMPILE-FILE on the on a stream source info for the
-;;; stream, sending output to core.
-;;;
-(defun compile-from-stream (stream
-			    &key
-			    ((:error-stream *compiler-error-output*)
-			     *error-output*)
-			    ((:trace-stream *compiler-trace-output*) nil)
-			    (defined-from-pathname nil)
-			    ((:block-compile *block-compile*) nil))
-  (declare (ignore defined-from-pathname))
-  "Similar to COMPILE-FILE, but compiles text from Stream into the current lisp
-  environment.  Stream is closed when compilation is complete.  These keywords
-  are supported:
-
-  :Error-Stream
-      The stream to write compiler error output to (default *ERROR-OUTPUT*.)
-  :Trace-Stream
-      The stream that we write compiler trace output to, or NIL (the default)
-      to inhibit trace output.
-  :Block-Compile
-        If true, then function names will be resolved at compile time."
-  (let ((info (make-stream-source-info stream)))
-    (unwind-protect
-	(let ((won (sub-compile-file info (make-core-object))))
-	  (values (not (null won))
-		  (if (member won '(:error :warning)) t nil)))
-      (close-source-info info))))
-
-
-;;; COMPILE-FILE  --  Public
-;;;
-;;;    Open some files and call SUB-COMPILE-FILE.  If the compile is unwound
-;;; out of, then abort the writing of the output file, so we don't overwrite it
-;;; with known garbage.
-;;;
-(defun #-new-compiler ncompile-file #+new-compiler compile-file
-  (source &key
-	  (output-file t)
-	  (error-file t)
-	  (trace-file nil) 
-	  (error-output t)
-	  (load nil)
-	  ((:block-compile *block-compile*) nil))
-  "Compiles Source, producing a corresponding .FASL file.  Source may be a list
-  of files, in which case the files are compiled as a unit, producing a single
-  .FASL file.  The output file names are defaulted from the first (or only)
-  input file name.  Other options available via keywords:
-  :Output-File
-        The name of the fasl to output, NIL for none, T for the default.
-  :Error-File
-        The name of the error listing file, NIL for none, T for the .ERR
-        default.
-  :Trace-File
-        If specified, internal data structures are dumped to this file.  T for
-        the .TRACE default.
-  :Error-Output
-        If a stream, then error output is sent there as well as to the listing
-        file.  NIL suppresses this additional error output.  The default is T,
-        which means use *ERROR-OUTPUT*.
-  :Block-Compile
-        If true, then function names will be resolved at compile time."
-  
-  (let* ((fasl-file nil)
-	 (error-file-stream nil)
-	 (output-file-name nil)
-	 (*compiler-error-output* nil)
-	 (*compiler-trace-output* nil)
-	 (compile-won nil)
-	 (error-severity nil)
-	 (source (verify-source-files source))
-	 (source-info (make-file-source-info source))
-	 (default (pathname (first source))))
-    (unwind-protect
-	(progn
-	  #-new-compiler
-	  (pushnew :new-compiler *features*)
-	  (flet ((frob (file type)
-		   (if (eq file t)
-		       (make-pathname :type type  :defaults default)
-		       (pathname file))))
-	    
-	    (when output-file
-	      (setq output-file-name (frob output-file "nfasl"))
-	      (setq fasl-file (open-fasl-file output-file-name
-					      (namestring (first source)))))
-	    
-	    (when trace-file
-	      (setq *compiler-trace-output*
-		    (open (frob trace-file "trace")
-			  :if-exists :supersede
-			  :direction :output)))
-	    
-	    (when error-file
-	      (setq error-file-stream
-		    (open (frob error-file "err")
-			  :if-exists :supersede
-			  :direction :output))))
-	  
-	  (setq *compiler-error-output*
-		(apply #'make-broadcast-stream
-		       (remove nil
-			       (list (if (eq error-output t)
-					 *error-output*
-					 error-output)
-				     error-file-stream))))
-	  (setq error-severity
-		(sub-compile-file source-info fasl-file))
-	  (setq compile-won t))
-
-      #-new-compiler
-      (setq *features* (remove :new-compiler *features*))
-
-      (close-source-info source-info)
-
-      (when fasl-file
-	(close-fasl-file fasl-file (not compile-won)))
-
-      (when error-file-stream
-	(let ((name (pathname error-file-stream)))
-	  (close error-file-stream)
-	  (unless error-severity
-	    (delete-file name))))
-
-      (when *compiler-trace-output*
-	(close *compiler-trace-output*)))
-
-    (when load
-      (unless output-file
-	(error "Can't :LOAD with no output file."))
-      (load output-file-name :verbose t))
-
-    (values (if output-file (truename output-file-name) nil)
-	    (not (null error-severity))
-	    (if (member error-severity '(:warning :error)) t nil))))
-
-
-;;;; COMPILE and UNCOMPILE:
-
-;;; GET-LAMBDA-TO-COMPILE  --  Internal
-;;;
-(defun get-lambda-to-compile (definition)
-  (if (consp definition)
-      definition
-      (multiple-value-bind (def env-p)
-			   (function-lambda-expression definition)
-	(when env-p
-	  (error "~S was defined in a non-null environment." definition))
-	(unless def
-	  (error "Can't find a definition for ~S." definition))
-	def)))
-
-
-;;; COMPILE-FIX-FUNCTION-NAME  --  Internal
-;;;
-;;;    Find the function that is being compiled by COMPILE and bash its name to
-;;; NAME.  We also substitute for any references to name so that recursive
-;;; calls will be compiled direct.  Lambda is the top-level lambda for the
-;;; compilation.  A REF for the real function is the only thing in the
-;;; top-level lambda other than the bind and return, so it isn't too hard to
-;;; find.
-;;;
-(defun compile-fix-function-name (lambda name)
-  (declare (type clambda lambda) (type (or symbol cons) name))
-  (when name
-    (let ((fun (ref-leaf
-		(continuation-next
-		 (node-cont (lambda-bind lambda))))))
-      (setf (leaf-name fun) name)
-      (let ((old (gethash name *free-functions*)))
-	(when old (substitute-leaf fun old)))
-      name)))
-
-
-;;; COMPILE  --  Public
-;;;
-#+new-compiler
-(defun compile (name &optional (definition (fdefinition name)))
-  "Compiles the function whose name is Name.  If Definition is supplied,
-  it should be a lambda expression that is compiled and then placed in the
-  function cell of Name.  If Name is Nil, the compiled code object is
-  returned."
-  (with-compilation-unit ()
-    (with-ir1-namespace
-      (clear-stuff)
-      (let* ((start-errors *compiler-error-count*)
-	     (start-warnings *compiler-warning-count*)
-	     (start-notes *compiler-note-count*)
-	     (*current-cookie* (make-cookie))
-	     (*fenv* ())
-	     (form `#',(get-lambda-to-compile definition))
-	     (*source-info* (make-lisp-source-info form))
-	     (*top-level-lambdas* ())
-	     (*compiler-error-bailout*
-	      #'(lambda ()
-		  (compiler-mumble
-		   "~2&Fatal error, aborting compilation...~%")
-		  (return-from compile (values nil t nil))))
-	     (*compiler-error-output* *error-output*)
-	     (*compiler-trace-output* nil)
-	     (*last-source-context* nil)
-	     (*last-original-source* nil)
-	     (*last-source-form* nil)
-	     (*last-format-string* nil)
-	     (*last-format-args* nil)
-	     (*last-message-count* 0)
-	     (object (make-core-object)))
-	(find-source-paths form 0)
-	(let ((lambda (ir1-top-level form 0 t)))
-	  
-	  (compile-fix-function-name lambda name)
-	  (let* ((component
-		  (block-component (node-block (lambda-bind lambda))))
-		 (*all-components* (list component)))
-	    (local-call-analyze component))
-	  
-	  (let* ((components (find-initial-dfo (list lambda)))
-		 (*all-components* components))
-	    (dolist (component components)
-	      (compile-component component object)
-	      (clear-ir2-info component)))
-	  
-	  (fix-core-source-info *source-info* object)
-	  (let* ((res (core-call-top-level-lambda lambda object))
-		 (return (or name res)))
-	    (when name
-	      (setf (fdefinition name) res))
-	    
-	    (cond ((or (> *compiler-error-count* start-errors)
-		       (> *compiler-warning-count* start-warnings))
-		   (values return t t))
-		  ((> *compiler-note-count* start-notes)
-		   (values return t nil))
-		  (t
-		   (values return nil nil)))))))))
-
-#+new-compiler
-;;; UNCOMPILE  --  Public
-;;;
-(defun uncompile (name)
-  "Attempt to replace Name's definition with an interpreted version of that
-  definition.  If no interpreted definition is to be found, then signal an
-  error."
-  (let ((def (fdefinition name)))
-    (if (eval:interpreted-function-p def)
-	(warn "~S is already interpreted." name)
-	(setf (fdefinition name)
-	      (coerce (get-lambda-to-compile def) 'function))))
-  name)
diff --git a/compiler/mips/alloc.lisp b/compiler/mips/alloc.lisp
deleted file mode 100644
index 8ba8c4bbcffaa2188d37f7160186c3d0a8d0d971..0000000000000000000000000000000000000000
--- a/compiler/mips/alloc.lisp
+++ /dev/null
@@ -1,75 +0,0 @@
-;;; -*- Package: C -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/alloc.lisp,v 1.3 1990/02/28 18:23:33 wlott Exp $
-;;;
-;;; Allocation VOPs for the MIPS port.
-;;;
-;;; Written by William Lott.
-;;; 
-
-(in-package "C")
-
-
-(define-vop (list-or-list*)
-  (:args (things :more t))
-  (:temporary (:scs (descriptor-reg) :type list) ptr)
-  (:temporary (:scs (descriptor-reg)) temp)
-  (:temporary (:scs (descriptor-reg) :type list :to (:result 0) :target result)
-	      res)
-  (:temporary (:scs (non-descriptor-reg) :type random) ndescr)
-  (:info num)
-  (:results (result :scs (descriptor-reg)))
-  (:variant-vars star)
-  (:policy :safe)
-  (:generator 0
-    (cond ((zerop num)
-	   (move result null-tn))
-	  ((and star (= num 1))
-	   (move result (tn-ref-tn things)))
-	  (t
-	   (macrolet
-	       ((store-car (tn list &optional (slot vm:cons-car-slot))
-		  `(let ((reg
-			  (sc-case ,tn
-			    ((any-reg descriptor-reg) ,tn)
-			    (zero zero-tn)
-			    (null null-tn)
-			    (control-stack
-			     (load-stack-tn temp ,tn)
-			     temp))))
-		     (storew reg ,list ,slot vm:list-pointer-type))))
-	     (let ((cons-cells (if star (1- num) num)))
-	       (pseudo-atomic (ndescr)
-		 (inst addiu res alloc-tn vm:list-pointer-type)
-		 (inst addiu alloc-tn alloc-tn
-		       (* (vm:pad-data-block vm:cons-size) cons-cells))
-		 (move ptr res)
-		 (dotimes (i (1- cons-cells))
-		   (store-car (tn-ref-tn things) ptr)
-		   (setf things (tn-ref-across things))
-		   (inst addiu ptr ptr (vm:pad-data-block vm:cons-size))
-		   (storew ptr ptr
-			   (- vm:cons-cdr-slot vm:cons-size)
-			   vm:list-pointer-type))
-		 (store-car (tn-ref-tn things) ptr)
-		 (cond (star
-			(setf things (tn-ref-across things))
-			(store-car (tn-ref-tn things) ptr vm:cons-cdr-slot))
-		       (t
-			(storew null-tn ptr
-				vm:cons-cdr-slot vm:list-pointer-type)))
-		 (assert (null (tn-ref-across things)))
-		 (move result res))))))))
-
-(define-vop (list list-or-list*)
-  (:variant nil))
-
-(define-vop (list* list-or-list*)
-  (:variant t))
diff --git a/compiler/mips/arith.lisp b/compiler/mips/arith.lisp
deleted file mode 100644
index 8833807960e30a6d73ecb950b082fbbbc0b54446..0000000000000000000000000000000000000000
--- a/compiler/mips/arith.lisp
+++ /dev/null
@@ -1,184 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    This file contains the VM definition arithmetic VOPs for the MIPS.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-;;; Converted by William Lott.
-;;; 
-
-(in-package "C")
-
-
-
-;;;; Unary operations.
-
-(define-vop (fixnum-unop)
-  (:args (x :scs (any-reg descriptor-reg)))
-  (:results (res :scs (any-reg descriptor-reg)))
-  (:note "inline fixnum arithmetic")
-  (:arg-types fixnum)
-  (:result-types fixnum)
-  (:policy :fast-safe))
-
-(define-vop (fast-negate/fixnum fixnum-unop)
-  (:translate %negate)
-  (:generator 1
-    (inst sub res zero-tn x)))
-
-(define-vop (fast-lognot/fixnum fixnum-unop)
-  (:temporary (:scs (any-reg) :type fixnum :to (:result 0))
-	      temp)
-  (:translate lognot)
-  (:generator 1
-    (loadi temp (fixnum -1))
-    (inst xor res x temp)))
-
-
-
-;;;; Binary operations.
-
-;;; Assume that any constant operand is the second arg...
-
-(defmacro define-fixnum-binop (name inherits translate op
-				    &key unsigned immed-op function)
-  `(define-vop (,name ,inherits)
-     (:translate ,translate)
-     (:generator 1
-       (sc-case y
-	 ((any-reg descriptor-reg)
-	  (inst ,op r x y))
-	 (zero
-	  (inst ,op r x zero-tn))
-	 ,@(when immed-op
-	     `(((immediate
-		 ,(if unsigned 'unsigned-immediate 'negative-immediate))
-		(inst ,immed-op r x
-		      (fixnum ,(if function
-				   `(,function (tn-value y))
-				   '(tn-value y)))))))))))
-
-;;;; Arithmetic:
-
-(define-vop (fast-binop/fixnum)
-  (:args (x :target r
-	    :scs (any-reg descriptor-reg))
-	 (y :target r
-	    :scs (any-reg descriptor-reg negative-immediate immediate zero)))
-  (:results (r :scs (any-reg descriptor-reg)))
-  (:arg-types fixnum fixnum)
-  (:result-types fixnum)
-  (:effects)
-  (:affected)
-  (:note "inline fixnum arithmetic")
-  (:policy :fast-safe))
-
-(define-fixnum-binop fast-+/fixnum fast-binop/fixnum + add
-  :immed-op addi)
-
-(define-fixnum-binop fast--/fixnum fast-binop/fixnum - sub
-  :immed-op addi :function -)
-
-
-;;;; Logic operations:
-
-;;; Like fast-binop/fixnum, except the immediate operand is unsigned, and
-;;; a fixnum result assertion isn't needed.
-;;;
-(define-vop (fast-logic-binop/fixnum fast-binop/fixnum)
-  (:args (x :target r
-	    :scs (any-reg descriptor-reg))
-	 (y :target r
-	    :scs (any-reg descriptor-reg immediate unsigned-immediate zero)))
-  (:result-types t))
-
-(define-fixnum-binop fast-logior/fixnum fast-logic-binop/fixnum logior or
-  :immed-op ori :unsigned t)
-
-(define-fixnum-binop fast-logand/fixnum fast-logic-binop/fixnum logand and
-  :immed-op andi :unsigned t)
-
-(define-fixnum-binop fast-logxor/fixnum fast-logic-binop/fixnum logxor xor
-  :immed-op xori :unsigned t)
-
-
-
-;;;; Binary conditional VOPs:
-
-(define-vop (fast-conditional/fixnum)
-  (:args (x :scs (any-reg descriptor-reg))
-	 (y :scs (any-reg descriptor-reg negative-immediate immediate zero)))
-  (:arg-types fixnum fixnum)
-  (:conditional)
-  (:info target not-p)
-  (:effects)
-  (:affected)
-  (:policy :fast-safe)
-  (:note "inline fixnum comparison"))
-
-
-(define-vop (fast-if-</fixnum fast-conditional/fixnum)
-  (:temporary (:type fixnum :scs (any-reg descriptor-reg)
-	       :from (:argument 0))
-	      temp)
-  (:translate <)
-  (:generator 3
-    (sc-case y
-      (zero
-       (if not-p
-	   (inst bgez x target)
-	   (inst bltz x target)))
-      ((negative-immediate immediate)
-       (inst slti temp x (fixnum (tn-value y)))
-       (if not-p
-	   (inst beq temp zero-tn target)
-	   (inst bne temp zero-tn target)))
-      ((any-reg descriptor-reg)
-       (inst slt temp x y)
-       (if not-p
-	   (inst beq temp zero-tn target)
-	   (inst bne temp zero-tn target))))
-    (nop)))
-
-(define-vop (fast-if->/fixnum fast-conditional/fixnum)
-  (:temporary (:type fixnum :scs (any-reg descriptor-reg)
-	       :from (:argument 0))
-	      temp)
-  (:translate >)
-  (:generator 3
-    (sc-case y
-      (zero
-       (if not-p
-	   (inst blez x target)
-	   (inst bgtz x target)))
-      ((negative-immediate immediate)
-       (inst slti temp x (fixnum (1+ (tn-value y))))
-       (if not-p
-	   (inst bne temp zero-tn target)
-	   (inst beq temp zero-tn target)))
-      ((any-reg descriptor-reg)
-       (inst slt temp y x)
-       (if not-p
-	   (inst beq temp zero-tn target)
-	   (inst bne temp zero-tn target))))
-    (nop)))
-
-(define-vop (fast-if-=/fixnum fast-conditional/fixnum)
-  (:args (x :scs (any-reg descriptor-reg))
-	 (y :scs (any-reg descriptor-reg zero)))
-  (:translate =)
-  (:generator 2
-    (let ((foo (sc-case y
-		 (zero zero-tn)
-		 ((any-reg descriptor-reg) y))))
-      (if not-p
-	  (inst bne x foo target)
-	  (inst beq x foo target)))
-    (nop)))
diff --git a/compiler/mips/array.lisp b/compiler/mips/array.lisp
deleted file mode 100644
index f492c56cfacc87ce2efa1e2ec94e016408eba251..0000000000000000000000000000000000000000
--- a/compiler/mips/array.lisp
+++ /dev/null
@@ -1,109 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    This file contains the RT definitions for array operations.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-(define-miscop aref1 (a i) :translate aref)
-(define-miscop caref2 (a i j) :translate aref)
-(define-miscop caref3 (a i j k) :translate aref)
-(define-miscop aset1 (a i val) :translate %aset)
-(define-miscop caset2 (a i j val) :translate %aset)
-(define-miscop caset3 (a i j k val) :translate %aset)
-(define-miscop svref (v i) :translate aref
-  :arg-types (simple-vector t))
-(define-miscop svset (v i val) :translate %aset
-  :arg-types (simple-vector t t))
-(define-miscop schar (v i) :translate aref
-  :arg-types (simple-string t))
-(define-miscop scharset (v i val) :translate %aset
-  :arg-types (simple-string t t))
-(define-miscop sbit (v i) :translate aref
-  :arg-types (simple-bit-vector t))
-(define-miscop sbitset (v i val) :translate %aset
-  :arg-types (simple-bit-vector t t))
-(define-miscop g-vector-length (v) :translate length
-  :arg-types (simple-vector))
-(define-miscop simple-string-length (s) :translate length
-  :arg-types (simple-string))
-(define-miscop simple-bit-vector-length (b) :translate length
-  :arg-types (simple-bit-vector))
-(define-miscop length (s) :translate length :cost 50)
-
-(define-vop (fast-length/simple-string)
-  (:args (vec :scs (descriptor-reg)))
-  (:results (res :scs (any-reg descriptor-reg)))
-  (:translate length)
-  (:arg-types simple-string)
-  (:policy :fast-safe)
-  #+nil
-  (:generator 6
-    (loadw res vec (/ clc::string-header-entries 4))
-    (inst niuo res res clc::i-vector-entries-mask-16)))
-
-(define-vop (fast-schar byte-index-ref)
-  (:results (value :scs (string-char-reg)))
-  (:variant clc::i-vector-header-size)
-  (:translate aref)
-  (:policy :fast)
-  (:arg-types simple-string *)
-  (:result-types string-char))
-
-(define-vop (fast-scharset byte-index-set)
-  (:args (object :scs (descriptor-reg))
-	 (index :scs (any-reg descriptor-reg short-immediate
-			      unsigned-immediate))
-	 (value :scs (string-char-reg)))
-  (:results (result :scs (string-char-reg)))
-  (:variant clc::i-vector-header-size)
-  (:translate %aset)
-  (:policy :fast)
-  (:arg-types simple-string * string-char)
-  (:result-types string-char))
-
-(define-vop (header-length)
-  (:args (vec :scs (descriptor-reg)))
-  (:results (res :scs (any-reg descriptor-reg)))
-  #+nil
-  (:generator 6
-    (loadw res vec (/ clc::g-vector-header-words 4))
-    (inst dec res clc::g-vector-header-size-in-words)
-    (inst niuo res res clc::g-vector-words-mask-16)))
-
-(define-vop (fast-length/simple-vector header-length)
-  (:translate length)
-  (:policy :fast-safe)
-  (:arg-types simple-vector))
-
-(define-vop (get-vector-subtype)
-  (:args (x :scs (descriptor-reg)))
-  (:results (res :scs (any-reg descriptor-reg)))
-  #+nil
-  (:generator 6
-    (loadc res x clc::vector-subtype-byte)
-    (inst nilz res res clc::right-shifted-subtype-mask-16)))
-	 
-(define-vop (header-ref word-index-ref)
-  (:variant clc::g-vector-header-size-in-words))
-
-(define-vop (fast-svref header-ref)
-  (:translate aref)
-  (:arg-types simple-vector *)
-  (:policy :fast))
-
-(define-vop (header-set word-index-set)
-  (:variant clc::g-vector-header-size-in-words))
-
-(define-vop (fast-svset header-set)
-  (:translate %aset)
-  (:arg-types simple-vector * *)
-  (:policy :fast))
diff --git a/compiler/mips/cell.lisp b/compiler/mips/cell.lisp
deleted file mode 100644
index 9d7d4813dce2c25b875207a6069213302cefe4e0..0000000000000000000000000000000000000000
--- a/compiler/mips/cell.lisp
+++ /dev/null
@@ -1,474 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/cell.lisp,v 1.16 1990/02/27 00:03:24 wlott Exp $
-;;;
-;;;    This file contains the VM definition of various primitive memory access
-;;; VOPs for the MIPS.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-;;; Converted by William Lott.
-;;; 
-
-(in-package "VM")
-
-(export '(cons-structure cons-size cons-car-slot cons-cdr-slot
-
-	  bignum-structure bignum-size bignum-digits-offset
-
-	  ratio-structure ratio-size ratio-numerator-slot
-	  ratio-denominator-slot
-
-	  single-float-structure single-float-size single-float-value-slot
-
-	  double-float-structure double-float-size double-float-value-slot
-
-	  complex-structure complex-size complex-real-slot complex-imag-slot
-
-	  array-structure array-fill-pointer-slot array-elements-slot
-	  array-data-slot array-displacement-slot array-displaced-p-slot
-	  array-dimensions-offset
-
-	  vector-structure vector-length-slot vector-data-offset
-
-	  code-structure code-code-size-slot code-entry-points-slot
-	  code-debug-info-slot code-constants-offset
-
-	  function-header-structure function-header-self-slot
-	  function-header-next-slot function-header-name-slot
-	  function-header-arglist-slot function-header-type-slot
-	  function-header-code-offset
-
-	  return-pc-structure return-pc-return-point-offset
-
-	  closure-structure closure-function-slot closure-info-offset
-
-	  value-cell-structure value-cell-size value-cell-value-slot
-
-	  symbol-structure symbol-size symbol-value-slot
-	  symbol-function-slot symbol-plist-slot symbol-name-slot
-	  symbol-package-slot
-
-	  sap-structure sap-size sap-pointer-slot
-
-	  binding-structure binding-size binding-symbol-slot binding-value-slot
-
-	  unwind-block-structure unwind-block-size
-	  unwind-block-current-uwp-slot unwind-block-current-cont-slot
-	  unwind-block-current-code-slot unwind-block-entry-pc-slot
-
-	  catch-block-structure catch-block-size
-	  catch-block-current-uwp-slot catch-block-current-cont-slot
-	  catch-block-current-code-slot catch-block-entry-pc-slot
-	  catch-block-tag-slot catch-block-previous-catch-slot
-	  catch-block-size-slot
-
-	  ))
-
-
-(in-package "C")
-
-
-;;;; Data object definition macros.
-
-(eval-when (compile eval load)
-  (defun parse-slot (slot)
-    (multiple-value-bind
-	(name props)
-	(if (atom slot)
-	    (values slot nil)
-	    (values (car slot) (cdr slot)))
-      (values name
-	      (getf props :rest)
-	      (getf props :c-type "lispobj")
-	      (getf props :length 1)
-	      (getf props :ref-vop)
-	      (getf props :ref-trans)
-	      (getf props :set-vop)
-	      (getf props :setf-vop)
-	      (getf props :set-trans)
-	      (getf props :docs)
-	      (getf props :init :zero)))))
-
-(defmacro defslots ((name &key header (lowtag 0) alloc-vop alloc-trans)
-		    &rest slots)
-  (let ((compile-time nil)
-	(load-time nil)
-	(index (if header 1 0))
-	(slot-names (if header '((header :c-type "lispobj"))))
-	(did-rest nil)
-	(init-forms nil)
-	(init-args nil)
-	(need-unbound-marker nil))
-    (dolist (slot slots)
-      (when did-rest
-	(error "Rest slot ~S in defslots of ~S is not the last one."
-	       did-rest name))
-      (multiple-value-bind
-	  (slot-name rest c-type length ref-vop ref-trans
-		     set-vop setf-vop set-trans docs init)
-	  (parse-slot slot)
-	(let ((const (intern (concatenate 'simple-string
-					  (string name)
-					  "-"
-					  (string slot-name)
-					  (if rest "-OFFSET" "-SLOT")))))
-	  (push `(defconstant ,const
-		   ,index
-		   ,@(if docs (list docs)))
-		compile-time)
-	  (when (or set-vop setf-vop)
-	    (push `(define-vop ,(cond (rest `(,set-vop slot-set))
-				      (set-vop `(,set-vop cell-set))
-				      (t `(,setf-vop cell-setf)))
-		     (:variant ,const ,lowtag)
-		     ,@(when set-trans
-			 `((:translate ,set-trans))))
-		  load-time))
-	  (when ref-vop
-	    (push `(define-vop (,ref-vop ,(if rest 'slot-ref 'cell-ref))
-		     (:variant ,const ,lowtag)
-		     ,@(when ref-trans
-			 `((:translate ,ref-trans))))
-		  load-time))
-	  (case init
-	    (:zero)
-	    (:null
-	     (push `(storew null-tn result ,const ,lowtag) init-forms))
-	    (:unbound
-	     (setf need-unbound-marker t)
-	     (push `(storew temp result ,const ,lowtag) init-forms))
-	    (:arg
-	     (push slot-name init-args)
-	     (push `(storew ,slot-name result ,const ,lowtag) init-forms))))
-	(push `(,slot-name :c-type ,c-type
-			   ,@(if rest '(:rest t)))
-	      slot-names)
-	(if rest
-	    (setf did-rest slot-name)
-	    (incf index length))))
-    (let ((size (intern (concatenate 'simple-string
-				     (string name)
-				     (if did-rest "-BASE-SIZE" "-SIZE")))))
-      (push `(defconstant ,size ,index
-	       ,(format nil
-			"Number of slots used by each ~S~
-			~@[~* including the header~]~
-			~@[~* excluding any data~]."
-			name header did-rest))
-	    compile-time)
-      (when alloc-vop
-	(push `(define-vop (,alloc-vop)
-		 (:args ,@(when did-rest
-			    `((extra-words :scs (any-reg descriptor-reg))))
-			,@(mapcar #'(lambda (name)
-				      `(,name :scs (any-reg descriptor-reg)))
-				  (nreverse init-args)))
-		 (:temporary (:scs (non-descriptor-reg) :type random)
-			     ndescr
-			     ,@(when (or need-unbound-marker header did-rest)
-				 '(temp)))
-		 (:temporary (:scs (descriptor-reg) :to (:result 0)
-				   :target real-result) result)
-		 (:results (real-result :scs (descriptor-reg)))
-		 (:policy :fast-safe)
-		 ,@(when alloc-trans
-		     `((:translate ,alloc-trans)))
-		 (:generator 37
-		   (pseudo-atomic (ndescr)
-		     (inst addiu result alloc-tn ,lowtag)
-		     ,@(cond ((and header did-rest)
-			      `((inst addiu temp extra-words
-				      (fixnum (1- ,size)))
-				(inst addu alloc-tn alloc-tn temp)
-				(inst sll temp temp
-				      (- vm:type-bits vm:word-bits))
-				(inst ori temp temp ,header)
-				(storew temp result 0 ,lowtag)
-				(inst addiu alloc-tn alloc-tn
-				      (+ (fixnum 1) vm:lowtag-mask))
-				(loadi temp (lognot vm:lowtag-mask))
-				(inst and alloc-tn alloc-tn temp)))
-			     (did-rest
-			      (error ":REST T with no header in ~S?" name))
-			     (header
-			      `((inst addiu alloc-tn alloc-tn
-				      (vm:pad-data-block ,size))
-				(loadi temp
-				       (logior (ash (1- ,size) vm:type-bits)
-					       ,header))
-				(storew temp result 0 ,lowtag)))
-			     (t
-			      `((inst addiu alloc-tn alloc-tn
-				      (vm:pad-data-block ,size)))))
-		     ,@(when need-unbound-marker
-			 `((loadi temp vm:unbound-marker-type)))
-		     ,@(nreverse init-forms)
-		     (move real-result result))))
-	      load-time)))
-    `(progn
-       (eval-when (compile load eval)
-	 ,@(nreverse compile-time))
-       ,@(nreverse load-time)
-       (defconstant ,(intern (concatenate 'simple-string
-					  (string name)
-					  "-STRUCTURE"))
-	 ',(reverse slot-names)))))
-
-
-(defslots (cons :lowtag list-pointer-type
-		:alloc-vop cons-vop :alloc-trans cons)
-  (car :ref-vop car :ref-trans car
-       :setf-vop set-car :set-trans %rplaca
-       :init :arg)
-  (cdr :ref-vop cdr :ref-trans cdr
-       :setf-vop set-cdr :set-trans %rplacd
-       :init :arg))
-
-
-(defslots (bignum :lowtag other-pointer-type :header bignum-type)
-  (digits :rest t :c-type "long"))
-
-(defslots (ratio :lowtag other-pointer-type :header ratio-type)
-  numerator
-  denominator)
-
-(defslots (single-float :lowtag other-pointer-type :header single-float-type)
-  (value :c-type "float"))
-
-(defslots (double-float :lowtag other-pointer-type :header double-float-type)
-  (value :c-type "double" :length 2))
-
-(defslots (complex :lowtag other-pointer-type :header complex-type)
-  real
-  imag)
-
-(defslots (array :lowtag other-pointer-type :header t)
-  fill-pointer
-  elements
-  data
-  displacement
-  displaced-p
-  (dimensions :rest t))
-
-(defslots (vector :lowtag other-pointer-type :header t)
-  length
-  (data :rest t :c-type "unsigned long"))
-
-(defslots (code :lowtag other-pointer-type :header t)
-  code-size
-  entry-points
-  debug-info
-  (constants :rest t))
-
-(defslots (function-header :lowtag function-pointer-type
-			   :header function-header-type)
-  self
-  next
-  name
-  arglist
-  type
-  (code :rest t :c-type "unsigned char"))
-
-(defslots (return-pc :lowtag other-pointer-type :header t)
-  (return-point :c-type "unsigned char" :rest t))
-
-(defslots (closure :lowtag function-pointer-type :header closure-header-type
-		   :alloc-vop make-closure)
-  (function :init :arg)
-  (info :rest t :set-vop closure-init :ref-vop closure-ref))
-
-(defslots (value-cell :lowtag other-pointer-type :header value-cell-header-type
-		      :alloc-vop make-value-cell)
-  (value :set-vop value-cell-set :ref-vop value-cell-ref :init :arg))
-
-(defslots (symbol :lowtag other-pointer-type :header symbol-header-type
-		  :alloc-vop make-symbol-vop :alloc-trans make-symbol)
-  (value :setf-vop set :set-trans set :init :unbound)
-  (function :setf-vop set-symbol-function :set-trans %sp-set-definition
-	    :init :unbound)
-  (plist :ref-vop symbol-plist :ref-trans symbol-plist
-	 :setf-vop set-symbol-plist :set-trans %sp-set-plist
-	 :init :null)
-  (name :ref-vop symbol-name :ref-trans symbol-name :init :arg)
-  (package :ref-vop symbol-package :ref-trans symbol-package
-	   :setf-vop set-package :init :null))
-
-(defslots (sap :lowtag other-pointer-type :header sap-header-type)
-  (pointer :c-type "char *"))
-
-
-;;; Other non-heap data blocks.
-
-(defslots (binding)
-  value
-  symbol)
-
-(defslots (unwind-block)
-  current-uwp
-  current-cont
-  current-code
-  entry-pc)
-
-(defslots (catch-block)
-  current-uwp
-  current-cont
-  current-code
-  entry-pc
-  tag
-  previous-catch
-  size)
-
-
-
-
-;;;; Symbol hacking VOPs:
-
-;;; Do a cell ref with an error check for being unbound.
-;;;
-(define-vop (checked-cell-ref)
-  (:args (object :scs (descriptor-reg) :target obj-temp))
-  (:results (value :scs (descriptor-reg any-reg)))
-  (:policy :fast-safe)
-  (:node-var node)
-  (:temporary (:type random  :scs (non-descriptor-reg)) temp)
-  (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp))
-
-;;; With Symbol-Value, we check that the value isn't the trap object.  So
-;;; Symbol-Value of NIL is NIL.
-;;;
-(define-vop (symbol-value checked-cell-ref)
-  (:translate symbol-value)
-  (:generator 9
-    (move obj-temp object)
-    (loadw value obj-temp vm:symbol-value-slot vm:other-pointer-type)
-    (let ((err-lab (generate-error-code node di:unbound-symbol-error obj-temp)))
-      (inst xori temp value vm:unbound-marker-type)
-      (inst beq temp zero-tn err-lab)
-      (nop))))
-
-;;; With Symbol-Function, we check that the result is a function, so NIL is
-;;; always un-fbound.
-;;;
-(define-vop (symbol-function checked-cell-ref)
-  (:translate symbol-function)
-  (:generator 10
-    (move obj-temp object)
-    (loadw value obj-temp symbol-function-slot)
-    (let ((err-lab (generate-error-code node di:undefined-symbol-error
-					obj-temp)))
-      (test-simple-type value temp err-lab t vm:function-pointer-type))))
-
-
-;;; Like CHECKED-CELL-REF, only we are a predicate to see if the cell is bound.
-(define-vop (boundp-frob)
-  (:args (object :scs (descriptor-reg)))
-  (:conditional)
-  (:info target not-p)
-  (:policy :fast-safe)
-  (:temporary (:scs (descriptor-reg)) value)
-  (:temporary (:type random  :scs (non-descriptor-reg)) temp))
-
-(define-vop (boundp boundp-frob)
-  (:translate boundp)
-  (:generator 9
-    (loadw value object vm:symbol-value-slot vm:other-pointer-type)
-    (inst xori temp value vm:unbound-marker-type)
-    (if not-p
-	(inst beq temp zero-tn target)
-	(inst bne temp zero-tn target))
-    (nop)))
-
-
-;;; SYMBOL isn't a primitive type, so we can't use it for the arg restriction
-;;; on the symbol case of fboundp.  Instead, we transform to a funny function.
-
-(defknown fboundp/symbol (t) boolean (flushable))
-;;;
-(deftransform fboundp ((x) (symbol))
-  '(fboundp/symbol x))
-;;;
-(define-vop (fboundp/symbol boundp-frob)
-  (:translate fboundp/symbol)
-  (:generator 10
-    (loadw value object vm:symbol-function-slot vm:other-pointer-type)
-    (test-simple-type value temp target not-p vm:function-pointer-type)))
-
-#+nil
-(def-source-transform makunbound (x)
-  `(set ,x (%primitive make-immediate-type 0 system:%trap-type)))
-
-
-(define-vop (fast-symbol-value cell-ref)
-  (:variant vm:symbol-value-slot vm:other-pointer-type)
-  (:policy :fast)
-  (:translate symbol-value))
-
-(define-vop (fast-symbol-function cell-ref)
-  (:variant vm:symbol-function-slot vm:other-pointer-type)
-  (:policy :fast)
-  (:translate symbol-function))
-
-
-;;; Binding and Unbinding.
-
-;;; BIND -- Establish VAL as a binding for SYMBOL.  Save the old value and
-;;; the symbol on the binding stack and stuff the new value into the
-;;; symbol.
-
-(define-vop (bind)
-  (:args (val :scs (any-reg descriptor-reg))
-	 (symbol :scs (descriptor-reg)))
-  (:temporary (:scs (descriptor-reg)) temp)
-  (:generator 5
-    (loadw temp symbol vm:symbol-value-slot vm:other-pointer-type)
-    (inst addiu bsp-tn bsp-tn (* 2 vm:word-bytes))
-    (storew temp bsp-tn (- binding-symbol-slot binding-size))
-    (storew symbol bsp-tn (- binding-symbol-slot binding-size))
-    (storew val symbol vm:symbol-value-slot vm:other-pointer-type)))
-
-
-(define-vop (unbind)
-  (:args (num-arg :scs (any-reg descriptor-reg) :target num))
-  (:temporary (:scs (any-reg) :type fixnum :from (:argument 0)) num)
-  (:temporary (:scs (descriptor-reg)) symbol value)
-  (:generator 0
-    (let ((done (gen-label))
-	  (skip (gen-label))
-	  (loop (gen-label)))
-      (move num num-arg)
-      (inst beq num zero-tn done)
-      (nop)
-
-      (emit-label loop)
-
-      (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
-      (inst beq symbol zero-tn skip)
-      (loadw value bsp-tn (- binding-symbol-slot binding-size))
-      (storew value symbol vm:symbol-value-slot vm:other-pointer-type)
-      (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
-      (emit-label skip)
-      (inst addiu num num (fixnum -1))
-      (inst bne num zero-tn loop)
-      (inst addiu bsp-tn bsp-tn (* -2 vm:word-bytes))
-
-      (emit-label done))))
-      
-
-
-;;;; Structure hackery:
-
-;;; ### This is only necessary until we get real structures up and running.
-
-(define-vop (structure-ref slot-ref)
-  (:variant vm:vector-data-offset vm:other-pointer-type))
-
-(define-vop (structure-set slot-set)
-  (:variant vm:vector-data-offset vm:other-pointer-type))
diff --git a/compiler/mips/char.lisp b/compiler/mips/char.lisp
deleted file mode 100644
index c36dbe8fb07c21e9c11b03b8a8f81dfe86acaf5b..0000000000000000000000000000000000000000
--- a/compiler/mips/char.lisp
+++ /dev/null
@@ -1,127 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    This file contains the RT VM definition of character operations.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-(define-vop (string-char-move)
-  (:args (x :target y
-	    :scs (string-char-reg)
-	    :load nil))
-  (:results (y :scs (string-char-reg)
-	       :load nil))
-  (:temporary (:scs (string-char-reg) :type string-char
-	       :from :argument  :to :result)
-	      temp)
-  (:effects)
-  (:affected)
-  #+nil
-  (:generator 0
-    (sc-case x ((string-char-reg string-char-stack immediate-string-char
-				 descriptor-reg any-reg stack)))
-    (sc-case y ((string-char-reg string-char-stack
-				 descriptor-reg any-reg stack)))
-
-    (let* ((x-char (sc-is x string-char-reg string-char-stack
-			  immediate-string-char))
-	   (y-char (sc-is y string-char-reg string-char-stack))
-	   (same-rep (if x-char y-char (not y-char)))
-	   (src (if (sc-is x stack string-char-stack immediate-string-char)
-		    temp x))
-	   (dest (if (sc-is y stack string-char-stack) temp y)))
-
-      (unless (and same-rep (location= x y))
-
-	(unless (eq x src)
-	  (sc-case x
-	    ((string-char-stack stack)
-	     (load-stack-tn src x))
-	    (immediate-string-char
-	     (loadi src (char-code (tn-value x))))))
-
-	(if same-rep
-	    (unless (location= src dest)
-	      (inst lr dest src))
-	    (if x-char
-		(inst oiu dest src (ash system:%string-char-type
-					clc::type-shift-16))
-		(inst nilz dest src system:%character-code-mask)))
-
-	(unless (eq y dest)
-	  (store-stack-tn y dest)))))) 
-
-(primitive-type-vop string-char-move (:coerce-to-t :coerce-from-t :move)
-  string-char)
-
-(define-vop (char-code)
-  (:args (ch :scs (string-char-reg) :target res))
-  (:results (res :scs (any-reg descriptor-reg)))
-  (:arg-types string-char)
-  (:translate char-code)
-  (:policy :fast-safe)
-  #+nil
-  (:generator 0
-    (unless (location= ch res)
-      (inst lr res ch))))
-
-(define-vop (code-char)
-  (:args (code :scs (any-reg descriptor-reg) :target res))
-  (:results (res :scs (string-char-reg)))
-  (:result-types string-char)
-  (:translate code-char)
-  (:policy :fast-safe)
-  #+nil
-  (:generator 0
-    (unless (location= code res)
-      (inst lr res code))))
-
-;;; For comparison of string-chars, we require both operands to be in the
-;;; untagged string-char-reg representation.  This will be a pessimization if
-;;; both operands are tagged, but this won't happen often, and not in
-;;; performance-critical cases.
-;;;
-(define-vop (string-char-compare pointer-compare)
-  (:args (x :scs (string-char-reg))
-	 (y :scs (string-char-reg)))
-  (:arg-types string-char string-char))
-
-(define-vop (fast-char=/string-char string-char-compare)
-  (:translate char=)
-  (:variant :eq))
-
-(define-vop (fast-char</string-char string-char-compare)
-  (:translate char<)
-  (:variant :lt))
-
-(define-vop (fast-char>/string-char string-char-compare)
-  (:translate char>)
-  (:variant :gt))
-
-;;; If we don't know that both operands are string-chars, then we just compare
-;;; the whole boxed object.  This assume that the hairy character type code is
-;;; greater than the string-char type, since a string-char must always be less
-;;; than a hairy char.
-;;;
-(define-vop (char-compare pointer-compare)
-  (:variant-cost 5))
-
-(define-vop (fast-char= char-compare)
-  (:translate char=)
-  (:variant :eq))
-
-(define-vop (fast-char< char-compare)
-  (:translate char<)
-  (:variant :lt))
-
-(define-vop (fast-char> char-compare)
-  (:translate char>)
-  (:variant :gt))
diff --git a/compiler/mips/insts.lisp b/compiler/mips/insts.lisp
deleted file mode 100644
index 444bc2b90a0754daf53148aa9173ae2eaa858ecf..0000000000000000000000000000000000000000
--- a/compiler/mips/insts.lisp
+++ /dev/null
@@ -1,464 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the CMU Common Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of CMU Common Lisp, please
-;;; contact Scott Fahlman (Scott.Fahlman@CS.CMU.EDU).
-;;; **********************************************************************
-;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/insts.lisp,v 1.10 1990/02/26 23:45:28 wlott Exp $
-;;; 
-;;; Assembler instruction definitions for the MIPS R2000.
-;;;
-;;; Written by Christopher Hoover
-;;;
-
-(in-package "C")
-
-;;; Clear out any old definitions.
-;;; 
-(clrhash *instructions*)
-(clrhash *instruction-formats*)
-
-
-;;;; Formats
-
-(eval-when (compile load eval)
-
-(defconstant special-op #b000000)
-(defconstant bcond-op #b0000001)
-(defconstant cop0-op #b010000)
-(defconstant cop1-op #b010001)
-(defconstant cop2-op #b010010)
-(defconstant cop3-op #b010011)
-
-) ; eval-when
-
-;;;
-;;; Load Store Format
-;;; 
-(def-instruction-format (load-store 4) (rt base &optional (offset 0))
-  (op :unsigned 6 :instruction-constant)
-  (base :unsigned 5 :register)
-  (rt :unsigned 5 :register)
-  (offset :signed 16 :immediate))
-
-;;;
-;;; Signed Immediate Format
-;;; 
-(def-instruction-format (signed-immed 4) (rt rs immed)
-  (op :unsigned 6 :instruction-constant)
-  (rs :unsigned 5 :register)
-  (rt :unsigned 5 :register)
-  (immed :signed 16 :immediate))
-
-;;;
-;;; Unsigned Immediate Format
-;;; 
-(def-instruction-format (unsigned-immed 4) (rt rs immed)
-  (op :unsigned 6 :instruction-constant)
-  (rs :unsigned 5 :register)
-  (rt :unsigned 5 :register)
-  (immed :unsigned 16 :immediate))
-
-;;;
-;;; LUI Special Format
-;;;
-(def-instruction-format (lui-special 4) (rt immed)
-  (op :unsigned 6 :instruction-constant)
-  (rt :unsigned 5 :constant 0)
-  (rt :unsigned 5 :register)
-  (immed :unsigned 16 :immediate))
-
-;;;
-;;; Jump (J) Format
-;;;
-(def-instruction-format (jump 4) (target)
-  (op :unsigned 6 :instruction-constant)
-  (target :unsigned 26 :branch #'(lambda (x) (ash x -2)))) ; This isn't right
-
-;;;
-;;; JR Special Format
-;;; 
-(def-instruction-format (jr-special 4) (rs)
-  (special :unsigned 6 :constant special-op)
-  (rs :unsigned 5 :register)
-  (zero :unsigned 15 :constant 0)
-  (op :unsigned 6 :instruction-constant))
-
-;;;
-;;; JALR Special Format
-;;;
-(def-instruction-format (jalr-special 4) (rd rs)
-  (special :unsigned 6 :constant special-op)
-  (rs :unsigned 5 :register)
-  (zero-1 :unsigned 5 :constant 0)
-  (rd :unsigned 5 :register)
-  (zero-2 :unsigned 5 :constant 0)
-  (op :unsigned 6 :instruction-constant))
-
-;;; 
-;;; Branch Format
-;;;
-(def-instruction-format (branch 4) (rs offset)
-  (op :unsigned 6 :instruction-constant)
-  (rs :unsigned 5 :register)
-  (zero :unsigned 5 :constant 0)
-  (offset :signed 16 :branch #'(lambda (x) (ash (- x 4) -2))))
-
-;;;
-;;; Branch-2 Format
-;;;
-(def-instruction-format (branch-2 4) (rs rt offset)
-  (op :unsigned 6 :instruction-constant)
-  (rs :unsigned 5 :register)
-  (rt :unsigned 5 :register)
-  (offset :signed 16 :branch #'(lambda (x) (ash (- x 4) -2))))
-
-;;;
-;;; Branch-Z Format
-;;;
-(def-instruction-format (branch-z 4) (rs offset)
-  (bcond :unsigned 6 :constant bcond-op)
-  (rs :unsigned 5 :register)
-  (op :unsigned 5 :instruction-constant)
-  (offset :signed 16 :branch #'(lambda (x) (ash (- x 4) -2))))
-
-;;;
-;;; R3 Format
-;;; 
-(def-instruction-format (r3 4) (rd rs rt)
-  (special :unsigned 6 :constant special-op)
-  (rs :unsigned 5 :register)
-  (rt :unsigned 5 :register)
-  (rd :unsigned 5 :register)
-  (zero :unsgined 5 :constant 0)
-  (op :unsigned 6 :instruction-constant))
-
-;;;
-;;; MF Format
-;;;
-(def-instruction-format (mf 4) (rd)
-  (special :unsigned 6 :constant special-op)
-  (zero-1 :unsigned 10 :constant 0)
-  (rd :unsigned 5 :register)
-  (zero-2 :unsigned 5 :constant 0)
-  (op :unsigned 6 :instruction-constant))
-
-;;; 
-;;; MT Format
-;;;
-(def-instruction-format (mt 4) (rs)
-  (special :unsigned 6 :constant special-op)
-  (rs :unsigned 5 :register)
-  (zero :unsigned 15 :constant 0)
-  (op :unsigned 6 :instruction-constant))
-
-;;;
-;;; Mult Format
-;;;
-(def-instruction-format (mult 4) (rs rt)
-  (special :unsigned 6 :constant special-op)
-  (rs :unsigned 5 :register)
-  (rt :unsigned 5 :register)
-  (zero :unsigned 10 :constant 0)
-  (op :unsigned 6 :instruction-constant))
-
-;;;
-;;; Shift Format
-;;;
-(def-instruction-format (shift 4) (rd rt shamt)
-  (special :unsigned 6 :constant special-op)
-  (zero :unsgined 5 :constant 0)
-  (rt :unsigned 5 :register)
-  (rd :unsigned 5 :register)
-  (shamt :unsigned 5 :immediate)
-  (op :unsigned 6 :instruction-constant))
-
-;;;
-;;; Shift-Var Format
-;;;
-(def-instruction-format (shift-var 4) (rd rt rs)
-  (special :unsigned 6 :constant special-op)
-  (rs :unsigned 5 :register)
-  (rt :unsigned 5 :register)
-  (rd :unsigned 5 :register)
-  (zero :unsigned 5 :constant 0)
-  (op :unsigned 6 :instruction-constant))
-
-;;;
-;;; BREAK-Special Format
-;;;
-(def-instruction-format (break-special 4) (code)
-  (special :unsigned 6 :constant special-op)
-  (code :unsigned 10 :immediate) ; The MIPS assembler only uses half the bits.
-  (unused :unsigned 10 :constant 0)
-  (op :unsigned 6 :instruction-constant))
-
-;;;
-;;; SYSCALL-Special Format
-;;;
-(def-instruction-format (syscall-special 4) ()
-  (special :unsigned 6 :constant special-op)
-  (zero :unsigned 20 :constant 0)
-  (op :unsigned 6 :instruction-constant))
-
-
-;;;; Instructions
-
-(def-instruction j-inst jump :op #b00010)
-(def-instruction jal-inst jump :op #b00011)
-(def-instruction jr jr-special :op #b001000)
-(def-instruction jalr jalr-special :op #b001001)
-(def-instruction beq-inst branch-2 :op #b000100)
-(def-instruction bne-inst branch-2 :op #b000101)
-(def-instruction blez-inst branch :op #b000110)
-(def-instruction bgtz-inst branch :op #b000111)
-
-(def-instruction addi signed-immed :op #b001000)
-(def-instruction addiu signed-immed :op #b001001)
-(def-instruction slti signed-immed :op #b001010)
-(def-instruction sltiu signed-immed :op #b001011)
-(def-instruction andi unsigned-immed :op #b001100)
-(def-instruction ori unsigned-immed :op #b001101)
-(def-instruction xori unsigned-immed :op #b001110)
-(def-instruction lui lui-special :op #b001111)
-
-(def-instruction lb load-store :op #b100000)
-(def-instruction lh load-store :op #b100001)
-(def-instruction lwl load-store :op #b100010)
-(def-instruction lw load-store :op #b100011)
-(def-instruction lbu load-store :op #b100100)
-(def-instruction lhu load-store :op #b100101)
-(def-instruction lwr load-store :op #b100110)
-
-(def-instruction sb load-store :op #b101000)
-(def-instruction sh load-store :op #b101001)
-(def-instruction swl load-store :op #b101010)
-(def-instruction sw load-store :op #b101011)
-(def-instruction swr load-store :op #b101110)
-
-(def-instruction sll shift :op #b000000)
-(def-instruction srl shift :op #b000010)
-(def-instruction sra shift :op #b000011)
-(def-instruction sllv shift-var :op #b000100)
-(def-instruction srlv shift-var :op #b000110)
-(def-instruction srav shift-var :op #b000111)
-
-(def-instruction syscall syscall-special :op #b001100)
-(def-instruction break break-special :op #b001101)
-
-(def-instruction mfhi mf :op #b010000)
-(def-instruction mthi mt :op #b010001)
-(def-instruction mflo mf :op #b010010)
-(def-instruction mtlo mt :op #b010011)
-
-(def-instruction mult mult :op #b011000)
-(def-instruction multu mult :op #b011001)
-(def-instruction div mult :op #b011010)
-(def-instruction divu mult :op #b011011)
-
-(def-instruction add r3 :op #b100000)
-(def-instruction addu r3 :op #b100001)
-(def-instruction sub r3 :op #b100010)
-(def-instruction subu r3 :op #b100011)
-(def-instruction and r3 :op #b100100)
-(def-instruction or r3 :op #b100101)
-(def-instruction xor r3 :op #b100110)
-(def-instruction nor r3 :op #b100111)
-
-(def-instruction slt r3 :op #b101010)
-(def-instruction sltu r3 :op #b101011)
-
-(def-instruction bltz-inst branch-z :op #b00000)
-(def-instruction bltzal-inst branch-z :op #b10000)
-
-(def-instruction bgez-inst branch-z :op #b00001)
-(def-instruction bgezal-inst branch-z :op #b10001)
-
-
-;;;; Branches
-
-(defmacro most-positive-twos-complement-number (n-bits)
-  `(1- (ash 1 (1- ,n-bits))))
-
-(defmacro most-negative-twos-complement-number (n-bits)
-  `(- (ash 1 (1- ,n-bits))))
-
-
-;;;
-;;; ### These two aren't right
-;;; 
-(def-branch j (label) label
-  (0 (ash 1 28) (j-inst label)))
-;;; 
-(def-branch jal (label) label
-  (0 (ash 1 28) (jal-inst label)))
-
-
-(def-branch beq (rs rt label) label
-  ((most-negative-twos-complement-number 18)
-   (most-positive-twos-complement-number 18)
-   (beq-inst rs rt label)))
-
-(def-branch bne (rs rt label) label
-  ((most-negative-twos-complement-number 18)
-   (most-positive-twos-complement-number 18)
-   (bne-inst rs rt label)))
-
-(def-branch blez (rs label) label
-  ((most-negative-twos-complement-number 18)
-   (most-positive-twos-complement-number 18)
-   (blez-inst rs label)))
-
-(def-branch bgtz (rs label) label
-  ((most-negative-twos-complement-number 18)
-   (most-positive-twos-complement-number 18)
-   (bgtz-inst rs label)))
-
-(def-branch bltz (rs label) label
-  ((most-negative-twos-complement-number 18)
-   (most-positive-twos-complement-number 18)
-   (bltz-inst rs label)))
-
-(def-branch bltzal (rs label) label
-  ((most-negative-twos-complement-number 18)
-   (most-positive-twos-complement-number 18)
-   (bltzal-inst rs label)))
-
-(def-branch bgez (rs label) label
-  ((most-negative-twos-complement-number 18)
-   (most-positive-twos-complement-number 18)
-   (bgez-inst rs label)))
-
-(def-branch bgezal (rs label) label
-  ((most-negative-twos-complement-number 18)
-   (most-positive-twos-complement-number 18)
-   (bgezal-inst rs label)))
-
-
-;;;; Pseduo Instructions to Support Component Dumping
-
-(defun component-header-length (&optional (component *compile-component*))
-  (let* ((2comp (component-info component))
-	 (constants (ir2-component-constants 2comp))
-	 (num-consts (length constants)))
-    (ash (logandc2 (1+ num-consts) 1) word-shift)))
-
-
-;;; COMPUTE-CODE-FROM-FN
-;;;
-;;; code = fn - fn-tag - header - label-offset + other-pointer-tag
-;;; 
-(def-instruction-format (compute-code-from-fn-format 4) (rt rs label)
-  (op :unsigned 6 :instruction-constant)
-  (rs :unsigned 5 :register)
-  (rt :unsigned 5 :register)
-  (label :signed 16
-	 :label #'(lambda (label-offset instr-offset)
-		    (declare (ignore instr-offset))
-		    (- other-pointer-type function-pointer-type label-offset
-		       (component-header-length)))))
-
-(def-instruction compute-code-from-fn compute-code-from-fn-format
-  :op #b001001)
-
-
-;;; COMPUTE-CODE-FROM-LRA
-;;;
-;;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag
-;;; 
-(def-instruction-format (compute-code-from-lra-format 4) (rt rs label)
-  (op :unsigned 6 :instruction-constant)
-  (rs :unsigned 5 :register)
-  (rt :unsigned 5 :register)
-  (label :signed 16
-	 :label #'(lambda (label-offset instr-offset)
-		    (declare (ignore instr-offset))
-		    (- (+ label-offset (component-header-length))))))
-
-(def-instruction compute-code-from-lra compute-code-from-lra-format
-  :op #b001001)
-
-
-;;; COMPUTE-LRA-FROM-CODE
-;;;
-;;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag
-;;; 
-(def-instruction-format (compute-lra-from-code-format 4) (rt rs label)
-  (op :unsigned 6 :instruction-constant)
-  (rs :unsigned 5 :register)
-  (rt :unsigned 5 :register)
-  (label :signed 16
-	 :label #'(lambda (label-offset instr-offset)
-		    (declare (ignore instr-offset))
-		    (+ label-offset (component-header-length)))))
-
-(def-instruction compute-lra-from-code compute-lra-from-code-format
-  :op #b001001)
-
-
-;;;
-;;; LRA-HEADER-WORD, FUNCTION-HEADER-WORD
-;;; 
-
-(def-instruction-format (header-word-format 4) ()
-  (data :unsigned 24 :calculation #'(lambda (posn)
-				      (ash (+ posn (component-header-length))
-					   (- vm:word-shift))))
-  (type :unsigned 8 :instruction-constant))
-
-(def-instruction lra-header-word header-word-format
-  :type vm:return-pc-header-type)
-
-(def-instruction function-header-word header-word-format
-  :type vm:function-header-type)
-
-
-
-;;; LOAD-FOREIGN-ADDRESS and LOAD-FOREIGN-VALUE
-;;; 
-;;; This ``instruction'' emits a LUI followed by either an ADDIU, LW, or SW
-;;;
-(def-instruction-format (load-foreign-format 8) (rt symbol)
-  ;; We need to switch the order of the two instructions because the MIPS
-  ;; is little-endian.
-  (op2 :unsigned 6 :instruction-constant)
-  (rt :unsigned 5 :register)
-  (rt :unsigned 5 :register)
-  (filler :unsigned 16 :constant 0)
-  (op1 :unsigned 6 :constant #b001111)
-  (rt :unsigned 5 :register)
-  (rt :unsigned 5 :register)
-  (symbol :unsigned 16 :fixup :foreign))
-
-(def-instruction load-foreign-address load-foreign-format
-  :op2 #b001001)
-
-(def-instruction load-foreign-value load-foreign-format
-  :op2 #b100011)
-
-(def-instruction store-foreign-value load-foreign-format
-  :op2 #b101011)
-
-
-
-;;; BYTE, SHORT, and WORD instructions.
-;;;
-;;; These instructions emit a byte, short, or word in the instruction
-;;; stream.  If you use them, be sure to use (align 2) afterwords to
-;;; assure that additional code gets properly aligned.
-
-(def-instruction-format (byte-format 1) (value)
-  (value :unsigned 8 :immediate))
-(def-instruction byte byte-format)
-
-(def-instruction-format (short-format 2) (value)
-  (value :unsigned 16 :immediate))
-(def-instruction short short-format)
-
-(def-instruction-format (word-format 4) (value)
-  (value :unsigned 32 :immediate))
-(def-instruction word word-format)
-
diff --git a/compiler/mips/macros.lisp b/compiler/mips/macros.lisp
deleted file mode 100644
index 549131cfcc8036230c4621383214e61028174138..0000000000000000000000000000000000000000
--- a/compiler/mips/macros.lisp
+++ /dev/null
@@ -1,471 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/macros.lisp,v 1.20 1990/02/28 18:25:17 wlott Exp $
-;;;
-;;;    This file contains various useful macros for generating MIPS code.
-;;;
-;;; Written by William Lott and Christopher Hoover.
-;;; 
-
-(in-package "C")
-
-;;; Handy macro for defining top-level forms that depend on the compile
-;;; environment.
-
-(defmacro expand (expr)
-  (let ((gensym (gensym)))
-    `(macrolet
-	 ((,gensym ()
-	    ,expr))
-       (,gensym))))
-
-
-;;; Instruction-like macros.
-
-
-(defmacro nop ()
-  "Emit a nop."
-  '(inst sll zero-tn zero-tn 0))
-
-(defmacro move (dst src &optional (always-emit-code-p nil))
-  "Move SRC into DST (unless they are location= and ALWAYS-EMIT-CODE-P
-  is nil)."
-  (once-only ((n-dst dst)
-	      (n-src src))
-    (if always-emit-code-p
-	`(inst addu ,n-dst ,n-src zero-tn)
-	`(unless (location= ,n-dst ,n-src)
-	   (inst addu ,n-dst ,n-src zero-tn)))))
-
-(defmacro b (label)
-  "Unconditional branch"
-  `(inst beq zero-tn zero-tn ,label))
-
-
-(defmacro def-mem-op (op inst shift load)
-  `(defmacro ,op (object base &optional (offset 0) (lowtag 0))
-     `(progn
-	(inst ,',inst ,object ,base (- (ash ,offset ,,shift) ,lowtag))
-	,,@(when load '('(nop))))))
-;;; 
-(def-mem-op loadw lw word-shift t)
-(def-mem-op storew sw word-shift nil)
-
-
-(defmacro loadi (reg const)
-  (once-only ((n-reg reg)
-	      (n-const const))
-    `(cond ((<= #x-8000 ,n-const #x7fff)
-	    (inst addi ,n-reg zero-tn ,n-const))
-	   ((<= #x8000 ,n-const #xffff)
-	    (inst ori ,n-reg zero-tn ,n-const))
-	   ((<= #x-80000000 ,n-const #xffffffff)
-	    (inst lui ,n-reg (ldb (byte 16 16) ,n-const))
-	    (let ((low (ldb (byte 16 0) ,n-const)))
-	      (unless (zerop low)
-		(inst ori ,n-reg ,n-reg low))))
-	   (t
-	    (error "Constant ~D cannot be loaded." ,n-const)))))
-
-(defmacro load-symbol (reg symbol)
-  `(inst addi ,reg null-tn (vm:static-symbol-offset ,symbol)))
-
-(macrolet
-    ((frob (slot)
-       (let ((loader (intern (concatenate 'simple-string
-					  "LOAD-SYMBOL-"
-					  (string slot))))
-	     (storer (intern (concatenate 'simple-string
-					  "STORE-SYMBOL-"
-					  (string slot))))
-	     (offset (intern (concatenate 'simple-string
-					  "SYMBOL-"
-					  (string slot)
-					  "-SLOT")
-			     (find-package "VM"))))
-	 `(progn
-	    (defmacro ,loader (reg symbol)
-	      `(progn
-		 (inst lw ,reg null-tn
-		       (+ (vm:static-symbol-offset ',symbol)
-			  (ash ,',offset vm:word-shift)
-			  (- vm:other-pointer-type)))
-		 (nop)))
-	    (defmacro ,storer (reg symbol)
-	      `(inst sw ,reg null-tn
-		     (+ (vm:static-symbol-offset ',symbol)
-			(ash ,',offset vm:word-shift)
-			(- vm:other-pointer-type))))))))
-  (frob value)
-  (frob function))
-
-(defmacro load-type (target source &optional (offset 0))
-  "Loads the type bits of a pointer into target independent of
-  byte-ordering issues."
-  (once-only ((n-target target)
-	      (n-source source)
-	      (n-offset offset))
-    (ecase vm:target-byte-order
-      (:little-endian
-       `(inst lb ,n-target ,n-source ,n-offset ))
-      (:big-endian
-       `(inst lb ,n-target ,n-source (+ ,n-offset 3))))))
-
-
-;;; Macros to handle the fact that we cannot use the machine native call and
-;;; return instructions. 
-
-(defmacro lisp-jump (function lip)
-  "Jump to the lisp function FUNCTION.  LIP is an interior-reg temporary."
-  `(progn
-     (inst addiu ,lip ,function (- (ash vm:function-header-code-offset
-					vm:word-shift)
-				   vm:function-pointer-type))
-     (inst jr ,lip)
-     (nop)))
-
-(defmacro lisp-return (return-pc lip)
-  "Return to RETURN-PC.  LIP is an interior-reg temporary."
-  `(progn
-     (inst addiu ,lip ,return-pc (- vm:word-bytes vm:other-pointer-type))
-     (inst jr ,lip)
-     (nop)))
-
-(defmacro emit-return-pc (label)
-  "Emit a return-pc header word.  LABEL is the label to use for this return-pc."
-  `(progn
-     (align vm:lowtag-bits)
-     (emit-label ,label)
-     (inst lra-header-word)))
-
-
-
-;;;; Stack TN's
-
-;;; Load-Stack-TN, Store-Stack-TN  --  Interface
-;;;
-;;;    Move a stack TN to a register and vice-versa.
-;;;
-(defmacro load-stack-tn (reg stack)
-  (once-only ((n-reg reg)
-	      (n-stack stack))
-    `(sc-case ,n-reg
-       ((any-reg descriptor-reg base-character-reg sap-reg)
-	(sc-case ,n-stack
-	  ((control-stack number-stack base-character-stack sap-stack)
-	   (loadw ,n-reg cont-tn (tn-offset ,n-stack))))))))
-
-(defmacro store-stack-tn (stack reg)
-  (once-only ((n-stack stack)
-	      (n-reg reg))
-    `(sc-case ,n-reg
-       ((any-reg descriptor-reg base-character-reg sap-reg)
-	(sc-case ,n-stack
-	  ((control-stack number-stack base-character-stack sap-stack)
-	   (storew ,n-reg cont-tn (tn-offset ,n-stack))))))))
-
-
-
-;;;; Simple Type Checking Macros
-
-(defmacro simple-test-tag (register temp target not-p tag-type tag-mask)
-  `(progn
-     (unless (zerop ,tag-mask)
-       (inst andi ,temp ,register ,tag-mask))
-     (inst xori ,temp ,temp ,tag-type)
-     (if ,not-p
-	 (inst bne ,temp zero-tn ,target)
-	 (inst beq ,temp zero-tn ,target))
-     (nop)))
-
-(defmacro simple-test-simple-type (register temp target not-p type-code)
-  "Emit conditional code that test whether Register holds an object with
-  the tag specificed if Tag-Type.  Temp should be an unboxed register."
-  (once-only ((n-register register)
-	      (n-temp temp)
-	      (n-target target)
-	      (n-not-p not-p)
-	      (n-type-code type-code))
-    `(cond ((< ,n-type-code vm:lowtag-limit)
-	    (simple-test-tag ,n-register ,n-temp ,n-target ,n-not-p
-			     ,n-type-code lowtag-mask))
-	   (t
-	    ;; Nothing clever in this version.  Assume other-immediate
-	    ;; type is already in register.
-	    ;; 
-	    (simple-test-tag ,n-temp ,n-temp ,n-target ,n-not-p
-			     ,n-type-code type-mask)))))
-
-(defmacro test-simple-type (register temp target not-p type-code)
-  "Emit conditional code that test whether Register holds an object with
-  the tag specificed if Tag-Type.  If the Tag-Type is a type for a heap
-  object than the register is dereferencd and the heap object is
-  checked.  Temp should be an unboxed register."
-  (once-only ((n-register register)
-	      (n-temp temp)
-	      (n-target target)
-	      (n-not-p not-p)
-	      (n-type-code type-code))
-    `(cond ((< ,n-type-code vm:lowtag-limit)
-	    (simple-test-tag ,n-register ,n-temp ,n-target ,n-not-p
-			     ,n-type-code lowtag-mask))
-	   (t
-	    (let* ((out-label (gen-label))
-		   (not-other-label (if ,n-not-p ,n-target out-label)))
-	      (simple-test-tag ,n-register ,n-temp not-other-label t
-			       vm:other-pointer-type vm:lowtag-mask)
-	      (load-type ,n-temp ,n-register (- vm:other-pointer-type))
-	      (nop)
-	      (simple-test-tag ,n-temp ,n-temp ,n-target ,n-not-p
-			       ,n-type-code 0)
-	      (emit-label out-label))))))
-
-
-;;;; Hairy Type Checking Macros
-
-(defun enumerate-type-codes (types)
-  (let ((type-codes nil))
-    (dolist (type types)
-      (cond ((listp type)
-	     (let ((low (eval (first type)))
-		   (high (eval (second type))))
-	       (when (> low high) (rotatef low high))
-	       (do ((n low (1+ n)))
-		   ((> n high))
-		 (push n type-codes))))
-	    (t
-	     (push (eval type) type-codes))))
-    (sort (remove-duplicates type-codes) #'<)))
-
-(defun canonicalize-type-codes (type-codes &optional (shift 0))
-  (unless type-codes (return-from canonicalize-type-codes nil))
-  (let* ((type-codes type-codes)
-	 (canonical-type-codes nil)
-	 (first-type-code (pop type-codes))
-	 (last-type-code (ash first-type-code shift))
-	 (range-start first-type-code)
-	 (range-end nil))
-    (dolist (type-code type-codes)
-      (let ((shifted-type-code (ash type-code shift)))
-	(cond ((= last-type-code (1- shifted-type-code))
-	       (setf range-end type-code))
-	      (t
-	       (push (if range-end (cons range-start range-end) range-start)
-		     canonical-type-codes)
-	       (setf range-start type-code)
-	       (setf range-end nil)))
-	(setf last-type-code shifted-type-code)))
-    (push (if range-end (cons range-start range-end) range-start)
-	  canonical-type-codes)
-    (nreverse canonical-type-codes)))
-
-(defmacro hairy-test-tag (register temp target not-p tag-types tag-mask)
-  (let ((in-label (gensym))
-	(out-label (gensym)))
-    (collect ((emit))
-      (macrolet ((frob (value)
-		   `(let ((diff (+ (- ,value) last-type-code)))
-		      (unless (zerop diff)
-			(emit `(inst addi ,temp ,temp ,diff))
-			(setf last-type-code ,value)))))
-	(do* ((types tag-types (cdr types))
-	      (type (car types) (car types))
-	      (last-type-check-p (null (cdr types)) (null (cdr types)))
-	      (last-type-code 0))
-	     ((null types))
-	  (cond ((consp type)
-		 (let ((low (car type))
-		       (high (cdr type)))
-		   (frob low)
-		   (emit `(inst bltz ,temp ,out-label))
-		   (frob high)
-		   (cond (last-type-check-p
-			  (emit `(if ,not-p
-				     (inst bgtz ,temp ,target)
-				     (inst blez ,temp ,target))))
-			 (t
-			  (emit `(inst blez ,temp ,in-label))))))
-		(t
-		 (frob type)
-		 (cond (last-type-check-p
-			(emit `(if ,not-p
-				   (inst bne ,temp zero-tn ,target)
-				   (inst beq ,temp zero-tn ,target))))
-		       (t
-			(emit `(inst beq ,temp zero-tn ,in-label))))))))
-      `(let* ((drop-through (gen-label))
-	      (,in-label (if ,not-p drop-through ,target))
-	      (,out-label (if ,not-p ,target drop-through)))
-	 ,in-label			; squelch possible warning
-	 ,out-label
-	 (unless (zerop ,tag-mask)
-	   (inst andi ,temp ,register ,tag-mask))
-	 ,@(emit)
-	 (nop)
-	 (emit-label drop-through)))))
-
-(defmacro test-hairy-type (register temp target not-p &rest types)
-  "Test-Hairy-Type Register Temp Target Not-P {Type | (Low-Type High-Type)}+
-  
-  Test whether Register holds a value with one of a specified union of
-  type codes.  All low tag type codes will be checked first.  Then the
-  pointer will be checked to see if it is an other-pointer-type type
-  pointer in which case it will be dereferenced and the remaining type
-  codes (the header word type codes) will be checked.  Each separately
-  specified Type is matched, and also all types between a Low-Type and
-  High-Type pair (inclusive) are matched.  All of the type-code
-  expressions are evaluated at macroexpand time.  Temp should be an
-  unboxed register." 
-  (once-only ((n-register register)
-	      (n-temp temp)
-	      (n-target target)
-	      (n-not-p not-p))
-    (unless types (error "Must specify at least one type."))
-    ;; 
-    ;; Partition the type codes.
-    (collect ((low-tag-types)
-	      (header-word-types))
-      (dolist (type (enumerate-type-codes types))
-	(cond ((< type vm:lowtag-limit)
-	       (low-tag-types type))
-	      (t
-	       (header-word-types type))))
-
-      (let ((low-tag-types (canonicalize-type-codes (low-tag-types)))
-	    (header-word-types (canonicalize-type-codes
-				(header-word-types) (- (1- lowtag-bits)))))
-	;; 
-	;; Generate code
-	`(let* ((out-label (gen-label))
-		(in-low-tag-label (if ,n-not-p out-label ,n-target))
-		(not-other-label (if ,n-not-p ,n-target out-label)))
-	   in-low-tag-label            ; may not be used -- squelch warning
-	   not-other-label
-	   ,@(when low-tag-types
-	       (if header-word-types
-		   `((hairy-test-tag ,n-register ,n-temp in-low-tag-label nil
-				     ,low-tag-types vm:lowtag-mask))
-		   `((hairy-test-tag ,n-register ,n-temp ,n-target ,n-not-p
-				     ,low-tag-types vm:lowtag-mask))))
-	   ,@(when header-word-types
-	       `((simple-test-tag ,n-register ,n-temp not-other-label t
-				  vm:other-pointer-type vm:lowtag-mask)
-		 (load-type ,n-temp ,n-register (- vm:other-pointer-type))
-		 (nop)
-		 (hairy-test-tag ,n-register ,n-temp ,n-target ,n-not-p
-				 ,header-word-types 0)))
-	   (emit-label out-label))))))
-
-(defmacro simple-test-hairy-type (register temp target not-p &rest types)
-  "Test-Hairy-Type Register Temp Target Not-P {Type | (Low-Type High-Type)}+
-
-  Test whether Register holds a value with one of a specified union of
-  type codes.  The type codes must either be all low tag codes or all
-  header word tag codes.  Each separately specified Type is matched, and
-  also all types between a Low-Type and High-Type pair (inclusive) are
-  matched.  All of the type-code expressions are evaluated at
-  macroexpand time.  Temp should be an unboxed register."
-  (once-only ((n-register register)
-	      (n-temp temp)
-	      (n-target target)
-	      (n-not-p not-p))
-    (unless types (error "Must specify at least one type."))
-    ;; 
-    ;; Partition the type codes.
-    (collect ((low-tag-types)
-	      (header-word-types))
-      (dolist (type (enumerate-type-codes types))
-	(cond ((< type vm:lowtag-limit)
-	       (low-tag-types type))
-	      (t
-	       (header-word-types type))))
-      (let ((low-tag-types (low-tag-types))
-	    (header-word-types (header-word-types)))
-	(cond ((and low-tag-types header-word-types)
-	       (error "SIMPLE-TEST-HAIRY-TYPE cannot check both low tag ~
-	       types and other-pointer-type tag types."))
-	      (low-tag-types
-	       `((hairy-test-tag ,n-register ,n-temp ,n-target ,n-not-p
-				 ,(canonicalize-type-codes low-tag-types)
-				 vm:lowtag-mask)))
-	      (header-word-types
-	       `(progn
-		  (inst srl ,n-temp ,n-register vm:lowtag-bits)
-		  (hairy-test-tag ,n-temp ,n-temp ,n-target ,n-not-p
-				  ,(canonicalize-type-codes header-word-types)
-				  vm:type-mask)))
-	      (t
-	       (error "Lost big.  Should not be here.")))))))
-
-
-;;;; Test-Special-Value
-
-;;; ### We may want this.
-
-#+nil
-(defmacro test-special-value (reg temp value target not-p)
-  "Test whether Reg holds the specified special Value (T, NIL, %Trap-Object).
-  Temp is an unboxed register."
-  (once-only ((n-reg reg)
-	      (n-temp temp)
-	      (n-value value)
-	      (n-target target)
-	      (n-not-p not-p))
-    `(progn
-       (inst xiu ,n-temp ,n-reg
-	     (or (cdr (assoc ,n-value
-			     `((t . ,',clc::t-16)
-			       (nil . ,',clc::nil-16)
-			       (%trap-object . ,',clc::trap-16))))
-		 (error "Unknown special value: ~S." ,n-value)))
-       (if ,n-not-p
-	   (inst bnb :eq ,n-target)
-	   (inst bb :eq ,n-target)))))
-
-
-;;;; Error Code
-
-(defmacro error-call (error-code &rest values)
-  (unless (< (length values) register-arg-count)
-    (error "Can't use ERROR-CALL with ~D values"
-	   (length values)))
-  `(progn
-     ,@(let ((index -1))
-	 (mapcar #'(lambda (value)
-		     `(move (nth ,(incf index) register-arg-tns) ,value))
-		 values))
-     (inst break ,error-code)))
-
-(defmacro generate-error-code (node error-code &rest values)
-  "Generate-Error-Code Node Error-code Value*
-  Emit code for an error with the specified Error-Code and context Values.
-  Node is used for source context."
-  `(unassemble
-     (assemble-elsewhere ,node
-       (let ((start-lab (gen-label)))
-	 (emit-label start-lab)
-	 (error-call ,error-code ,@values)
-	 start-lab))))
-
-
-;;; PSEUDO-ATOMIC -- Handy macro for making sequences look atomic.
-;;;
-(defmacro pseudo-atomic ((ndescr-temp) &rest forms)
-  (let ((label (gensym "LABEL-")))
-    `(let ((,label (gen-label)))
-       (inst andi flags-tn flags-tn (lognot (ash 1 interrupted-flag)))
-       (inst ori flags-tn flags-tn (ash 1 atomic-flag))
-       ,@forms
-       (inst andi flags-tn flags-tn (lognot (ash 1 atomic-flag)))
-       (inst andi ,ndescr-temp flags-tn (ash 1 interrupted-flag))
-       (inst beq ,ndescr-temp zero-tn ,label)
-       (nop)
-       (inst break vm:pending-interrupt-trap)
-       (emit-label ,label))))
diff --git a/compiler/mips/memory.lisp b/compiler/mips/memory.lisp
deleted file mode 100644
index 5fcf2820ab75879ba3692b80af0e9d0961c3c3e1..0000000000000000000000000000000000000000
--- a/compiler/mips/memory.lisp
+++ /dev/null
@@ -1,146 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/memory.lisp,v 1.3 1990/02/18 02:22:44 wlott Exp $
-;;;
-;;;    This file contains the MIPS definitions of some general purpose memory
-;;; reference VOPs inherited by basic memory reference operations.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-;;; Converted by William Lott.
-;;; 
-
-(in-package "C")
-
-
-;;; Cell-Ref and Cell-Set are used to define VOPs like CAR, where the offset to
-;;; be read or written is a property of the VOP used.  Cell-Setf is similar to
-;;; Cell-Set, but delivers the new value as the result.
-;;;
-(define-vop (cell-ref)
-  (:args (object :scs (descriptor-reg)))
-  (:results (value :scs (descriptor-reg any-reg)))
-  (:variant-vars offset lowtag)
-  (:policy :fast-safe)
-  (:generator 4
-    (loadw value object offset lowtag)))
-;;;
-(define-vop (cell-set)
-  (:args (object :scs (descriptor-reg))
-         (value :scs (descriptor-reg any-reg)))
-  (:variant-vars offset lowtag)
-  (:policy :fast-safe)
-  (:generator 4
-    (storew value object offset lowtag)))
-;;;
-(define-vop (cell-setf)
-  (:args (object :scs (descriptor-reg))
-	 (value :scs (descriptor-reg any-reg)
-		:target result))
-  (:results (result :scs (descriptor-reg any-reg)))
-  (:variant-vars offset lowtag)
-  (:policy :fast-safe)
-  (:generator 4
-    (storew value object offset lowtag)
-    (move result value)))
-
-;;; Define-Cell-Accessors  --  Interface
-;;;
-;;;    Define accessor VOPs for some cells in an object.  If the operation name
-;;; is NIL, then that operation isn't defined.  If the translate function is
-;;; null, then we don't define a translation.
-;;;
-(defmacro define-cell-accessors (offset lowtag
-					ref-op ref-trans set-op set-trans)
-  `(progn
-     ,@(when ref-op
-	 `((define-vop (,ref-op cell-ref)
-	     (:variant ,offset ,lowtag)
-	     ,@(when ref-trans
-		 `((:translate ,ref-trans))))))
-     ,@(when set-op
-	 `((define-vop (,set-op cell-setf)
-	     (:variant ,offset ,lowtag)
-	     ,@(when set-trans
-		 `((:translate ,set-trans))))))))
-
-
-;;; Slot-Ref and Slot-Set are used to define VOPs like Closure-Ref, where the
-;;; offset is constant at compile time, but varies for different uses.  We add
-;;; in the stardard g-vector overhead.
-;;;
-(define-vop (slot-ref)
-  (:args (object :scs (descriptor-reg)))
-  (:results (value :scs (descriptor-reg any-reg)))
-  (:variant-vars base lowtag)
-  (:info offset)
-  (:generator 4
-    (loadw value object (+ base offset) lowtag)))
-;;;
-(define-vop (slot-set)
-  (:args (object :scs (descriptor-reg))
-	 (value :scs (descriptor-reg any-reg)))
-  (:variant-vars base lowtag)
-  (:info offset)
-  (:generator 4
-    (storew value object (+ base offset) lowtag)))
-
-
-
-;;;; Indexed references:
-
-;;; Define-Indexer  --  Internal
-;;;
-;;;    Define some VOPs for indexed memory reference.  Unless the index is
-;;; constant, we must compute an intermediate result in a boxed temporary,
-;;; since the RT doesn't have any indexed addressing modes.  This means that GC
-;;; has to adjust the "raw" pointer in Index-Temp by observing that Index-Temp
-;;; points within Object-Temp.  After we are done, we clear Index-Temp so that
-;;; we don't raw pointers lying around.
-;;;
-(defmacro define-indexer (name write-p op shift)
-  `(define-vop (,name)
-     (:args (object :scs (descriptor-reg))
-	    (index :scs (any-reg descriptor-reg immediate negative-immediate))
-	    ,@(when write-p
-		'((value :scs (any-reg descriptor-reg) :target result))))
-     (:temporary (:scs (interior-reg) :type interior) lip)
-     (:results (,(if write-p 'result 'value)
-		:scs (any-reg descriptor-reg)))
-     (:variant-vars offset lowtag)
-     (:policy :fast-safe)
-     (:generator 5
-       (sc-case index
-	 ((immediate negative-immediate)
-	  (inst ,op value object
-		(- (+ (ash (tn-value index) (- word-shift ,shift))
-		      (ash offset word-shift))
-		   lowtag))
-	  ,(if write-p
-	       '(move result value)
-	       '(nop)))
-	 (t
-	  ,@(if (zerop shift)
-		`((inst add lip object index))
-		`((inst srl lip index ,shift)
-		  (inst add lip lip object)))
-	  (inst ,op value lip (- (ash offset word-shift) lowtag))
-	  ,@(when write-p
-	      `((move result value))))))))
-
-(define-indexer word-index-ref nil lw 0)
-(define-indexer word-index-set t sw 0)
-(define-indexer halfword-index-ref nil lhu 1)
-(define-indexer signed-halfword-index-ref nil lh 1)
-(define-indexer halfword-index-set t sh 1)
-(define-indexer byte-index-ref nil lbu 2)
-(define-indexer signed-byte-index-ref nil lb 2)
-(define-indexer byte-index-set t sb 2)
-
diff --git a/compiler/mips/mips-regs.txt b/compiler/mips/mips-regs.txt
deleted file mode 100644
index 1c0728b0dcc0ee90bb56d1b9af333ae6983f7f15..0000000000000000000000000000000000000000
--- a/compiler/mips/mips-regs.txt
+++ /dev/null
@@ -1,60 +0,0 @@
-Global Lisp Registers:
-	NULL - Wired NIL register.
-	CSP - Control stack pointer.
-	CONT - Continuation pointer.
-	NSP - Number stack pointer.
-	BSP - Binding stack pointer.
-	FLAGS - Special flags register.
-	ALLOC - Allocation pointer.
-	CODE - Current code object.
-
-Linkage Registers:
-	NARGS - Number of arguments or values.
-	LEXENV - Lexical Environment being called.
-	OLDCONT - Old continuation pointer.
-	CNAME - Name of called function.
-	A0-A5 - First 6 arguments.
-	ARGS - Argument pointer.
-	LRA - Lisp Return Address.
-
-
-  Reg	CN  PR	C Usage		LN 	Lisp Usage		GC
-------------------------------------------------------------------------
-  R0	-   -	Wired Zero	ZERO	Wired Zero		N
-  R1	-   N	Assembler Temp	LIP	Lisp-Interior		Special
-  R2	v0  N   Results		NL0	Non-Lisp Reg		N
-  R3	v1  N	Static Link	NL1	Non-Lisp Reg		N
-  R4	a0  N	Integer Arg	NL2	Non-Lisp Reg		N
-  R5	a1  N	Integer Arg	NL3	Non-Lisp Reg		N
-  R6	a2  N	Integer Arg	NL4	Non-Lisp Reg		N
-  R7	a3  N	Integer Arg	NARGS	Arg Count		N
-  R8	t0  N	Temporary Reg	A0	Argument		Y
-  R9	t1  N	Temporary Reg	A1	Argument		Y
-  R10	t2  N	Temporary Reg	A2	Argument		Y
-  R11	t3  N	Temporary Reg	A3	Argument		Y
-  R12	t4  N	Temporary Reg	A4	Argument		Y
-  R13	t5  N	Temporary Reg	A5	Argument		Y
-  R14	t6  N	Temporary Reg	CNAME	Call Name		Y
-  R15	t7  N	Temporary Reg	LEXENV	Lexical Env		Y
-  R16	s0  Y	Saved Temp Reg	ARGS	Arg Pointer		Y
-  R17	s1  Y	Saved Temp Reg	OLDCONT	Old Continuation	Y
-  R18	s2  Y	Saved Temp Reg	LRA	Lisp Return Address	Y
-  R19	s3  Y	Saved Temp Reg	L0	Random Lisp Reg		Y
-  R20	s4  Y	Saved Temp Reg	NULL	Null / Nil Constant	Y
-  R21	s5  Y	Saved Temp Reg	BSP	Binding Stack Pointer	Special
-  R22	s6  Y	Saved Temp Reg	CONT	Current Continuation	Special
-  R23	s7  Y	Saved Temp Reg	CSP	Control Stack Pointer	Special
-  R24	t8  N	Temporary Reg	FLAGS	Flags register		N
-  R25   t9  N	Temporary Reg	ALLOC	Allocation Pointer	Special
-  R26	k0  -	(reserved)	-	Kernel Reg (reserved)	N
-  R27	k1  -	(reserved)	-	Kernel Reg (reserved)	N
-  R28	gp  -	Global Pointer	L1	Random Lisp Reg		Y
-  R29   sp  -	Stack Pointer	NSP	Number Stack Pointer	N
-  R30	s8  Y	Saved Temp Reg	CODE	Code Pointer		Y
-  R31	ra  N	Return Addr	L2	Random Lisp Reg		Y
-
-Key:
-	CN == C/UNIX name
-	NL == Lisp name
-	PR == Preserved on C function call (callee saves)
-	GC == Considered as a root for GC
diff --git a/compiler/mips/move.lisp b/compiler/mips/move.lisp
deleted file mode 100644
index 9f573ee489d3b9cb7d22fcec8ede850a66318957..0000000000000000000000000000000000000000
--- a/compiler/mips/move.lisp
+++ /dev/null
@@ -1,177 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/move.lisp,v 1.8 1990/02/28 18:26:05 wlott Exp $
-;;;
-;;;    This file contains the RT VM definition of operand loading/saving and
-;;; the Move VOP.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package "C")
-
-;;; Load-Constant-TN  --  Internal
-;;;
-;;;    Load the Constant or immediate constant TN X into Y.  Temp is a
-;;; descriptor register temp or NIL, if none is available.  Temp must be
-;;; supplied if Y may be in memory.  Node is for souce context.
-;;;
-(defun load-constant-tn (x y temp node)
-  (declare (type tn x y) (type (or tn null temp)) (type node node))
-  (assemble node
-    (sc-case x
-      ((zero negative-immediate unsigned-immediate immediate
-	     null random-immediate immediate-base-character immediate-sap)
-       (let ((val (tn-value x))
-	     (dest (sc-case y
-		     ((any-reg descriptor-reg base-character-reg sap-reg) y)
-		     ((control-stack number-stack sap-stack
-				     base-character-stack)
-		      temp))))
-	 (etypecase val
-	   (integer
-	    (loadi dest (fixnum val)))
-	   (null
-	    (move dest null-tn))
-	   (symbol
-	    (load-symbol dest val))
-	   (string-char
-	    (loadi dest (logior (ash (char-code val) type-bits)
-				base-character-type))))
-	 (unless (eq dest y)
-	   (store-stack-tn y temp))))
-      (constant
-       (sc-case y
-	 ((any-reg descriptor-reg)
-	  (loadw y code-tn (tn-offset x) other-pointer-type))
-	 (control-stack
-	  (loadw temp code-tn (tn-offset x) other-pointer-type)
-	  (store-stack-tn y temp)))))))
-
-
-;;;; The Move VOP:
-;;;
-;;;    The Move VOP is used for doing arbitrary moves when there is no
-;;; type-specific move/coerce operation.
-
-;;; We need a register to do a memory-memory move.
-;;;
-(define-vop (move)
-  (:args (x :target y
-	    :scs (any-reg descriptor-reg)
-	    :load nil))
-  (:results (y :scs (any-reg descriptor-reg)
-	       :load nil))
-  (:temporary (:scs (descriptor-reg)
-	       :from :argument  :to :result)
-	      temp)
-  (:node-var node)
-  (:effects)
-  (:affected)
-  (:generator 0
-    (unless (location= x y)
-      (sc-case x
-	((any-reg descriptor-reg)
-	 (sc-case y
-	   ((any-reg descriptor-reg)
-	    (move y x))
-	   (control-stack
-	    (store-stack-tn y x))))
-	(control-stack
-	 (sc-case y
-	   ((any-reg descriptor-reg)
-	    (load-stack-tn y x))
-	   (control-stack
-	    (load-stack-tn temp x)
-	    (store-stack-tn y temp))))
-	(t
-	 (unassemble (load-constant-tn x y temp node)))))))
-
-
-;;; Make Move the check VOP for T so that type check generation doesn't think
-;;; it is a hairy type.  This also allows checking of a few of the values in a
-;;; continuation to fall out.
-;;;
-(primitive-type-vop move (:check) t)
-
-
-;;;; ILLEGAL-MOVE
-
-;;; This VOP exists just to begin the lifetime of a TN that couldn't be written
-;;; legally due to a type error.  An error is signalled before this VOP is
-;;; so we don't need to do anything (not that there would be anything sensible
-;;; to do anyway.)
-;;;
-(define-vop (illegal-move)
-  (:results (y))
-  (:ignore y)
-  (:generator 666))
-
-
-;;;; Operand loading and saving:
-;;;
-;;;    These are the VOPs used for loading or saving Load-TNs.  They cannot
-;;; allocate any temporaries since packing has already been done by the time
-;;; that these VOPs are emitted.  It can be assumed that the loaded (saved) TN
-;;; is free before (after) the load (save) (so may be used as a temporary.)
-;;;
-
-(define-vop (load-operand)
-  (:args (x))
-  (:results (y))
-  (:node-var node)
-  (:generator 5
-    (sc-case x
-      (control-stack
-       (sc-case y
-	 ((any-reg descriptor-reg)
-	  (load-stack-tn y x))
-	 #+nil
-	 (base-character-reg
-	  (load-stack-tn y x)
-	  (inst nilz y y system:%character-code-mask))))
-      (base-character-stack
-       (sc-case y
-	 (base-character-reg
-	  (load-stack-tn y x))))
-      (t
-       (unassemble (load-constant-tn x y nil node))))))
-
-(define-vop (store-operand)
-  (:args (x))
-  (:results (y))
-  (:generator 5
-    (sc-case y
-      (control-stack
-       (sc-case x
-	 ((any-reg descriptor-reg)
-	  (store-stack-tn y x))
-	 #+nil
-	 (base-character-reg
-	  (inst oiu x x (ash system:%string-char-type clc::type-shift-16))
-	  (store-stack-tn y x))))
-      (base-character-stack
-       (sc-case x
-	 (base-character-reg
-	  (store-stack-tn y x)))))))
-
-
-;;;; Register saving and restoring VOPs.
-
-(define-vop (save-reg)
-  (:args (reg))
-  (:results (stack))
-  (:generator 5
-    (store-stack-tn stack reg)))
-
-(define-vop (restore-reg)
-  (:args (stack))
-  (:results (reg))
-  (:generator 5
-    (load-stack-tn reg stack)))
diff --git a/compiler/mips/nlx.lisp b/compiler/mips/nlx.lisp
deleted file mode 100644
index 45f83087fa4b05301c5964a267de9ff529051950..0000000000000000000000000000000000000000
--- a/compiler/mips/nlx.lisp
+++ /dev/null
@@ -1,285 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/nlx.lisp,v 1.2 1990/02/27 00:12:10 wlott Exp $
-;;;
-;;;    This file contains the definitions of VOPs used for non-local exit
-;;; (throw, lexical exit, etc.)
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-
-;;; Save and restore dynamic environment.
-;;;
-;;;    These VOPs are used in the reentered function to restore the appropriate
-;;; dynamic environment.  Currently we only save the Current-Catch and binding
-;;; stack pointer.  We don't need to save/restore the current unwind-protect,
-;;; since unwind-protects are implicitly processed during unwinding.  If there
-;;; were any additional stacks, then this would be the place to restore the top
-;;; pointers.
-
-
-;;; Make-Dynamic-State-TNs  --  Interface
-;;;
-;;;    Return a list of TNs that can be used to snapshot the dynamic state for
-;;; use with the Save/Restore-Dynamic-Environment VOPs.
-;;;
-(defun make-dynamic-state-tns ()
-  (make-n-tns 4 *any-primitive-type*))
-
-(define-vop (save-dynamic-state)
-  (:results (catch :scs (descriptor-reg))
-	    (special :scs (descriptor-reg))
-	    (number :scs (descriptor-reg))
-	    (eval :scs (descriptor-reg)))
-  (:generator 13
-    (load-symbol-value catch lisp::*current-catch-block*)
-    (move special bsp-tn)
-    (move number nsp-tn)
-    (load-symbol-value eval lisp::*eval-stack-top*)))
-
-(define-vop (restore-dynamic-state)
-  (:args (catch :scs (descriptor-reg))
-	 (special :scs (descriptor-reg))
-	 (number :scs (descriptor-reg))
-	 (eval :scs (descriptor-reg)))
-  (:temporary (:scs (descriptor-reg)) symbol value)
-  (:generator 10
-    (let ((done (gen-label))
-	  (skip (gen-label))
-	  (loop (gen-label)))
-
-      (store-symbol-value catch lisp::*current-catch-block*)
-      (store-symbol-value eval lisp::*eval-stack-top*)
-      (move nsp-tn number)
-      
-      (inst beq special bsp-tn done)
-      (nop)
-
-      (emit-label loop)
-      (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
-      (inst beq symbol zero-tn skip)
-      (loadw value bsp-tn (- binding-value-slot binding-size))
-      (storew value symbol vm:symbol-value-slot vm:other-pointer-type)
-      (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
-      (emit-label skip)
-      (inst addiu bsp-tn bsp-tn (* -2 vm:word-bytes))
-      (inst bne bsp-tn special loop)
-      (nop)
-
-      (emit-label done))))
-
-(define-vop (current-stack-pointer)
-  (:results (res :scs (any-reg descriptor-reg)))
-  (:generator 1
-    (move res csp-tn)))
-
-
-;;;; Unwind miscop VOPs:
-
-(define-vop (unwind)
-  (:translate %continue-unwind)
-  (:args (block-arg :target block)
-	 (start :target args)
-	 (count :target nargs))
-  (:temporary (:sc any-reg :offset (first register-arg-offsets)
-		   :from (:argument 0)) block)
-  (:temporary (:sc any-reg :offset args-offset :from (:argument 1)) args)
-  (:temporary (:sc any-reg :offset nargs-offset :from (:argument 2)) nargs)
-  (:temporary (:scs (any-reg) :type fixnum) cur-uwp target-uwp next-uwp)
-  (:temporary (:scs (descriptor-reg)) return-pc)
-  (:temporary (:scs (interior-reg) :type interior) lip)
-  (:node-var node)
-  (:generator 0
-    (let ((error (generate-error-code node di:invalid-unwind-error))
-	  (do-uwp (gen-label))
-	  (do-exit (gen-label)))
-      (move block block-arg)
-      (inst beq block zero-tn error)
-      
-      (move args start)
-      (move nargs count)
-      
-      (load-symbol-value cur-uwp lisp::*current-unwind-protect-block*)
-      (loadw target-uwp block vm:unwind-block-current-uwp-slot)
-      (inst bne cur-uwp target-uwp do-uwp)
-      (nop)
-      
-      (move cur-uwp block)
-
-      (emit-label do-exit)
-      
-      (loadw cont-tn cur-uwp vm:unwind-block-current-cont-slot)
-      (loadw code-tn cur-uwp vm:unwind-block-current-code-slot)
-      (loadw return-pc cur-uwp vm:unwind-block-entry-pc-slot)
-      (lisp-return return-pc lip)
-	     
-      (emit-label do-uwp)
-
-      (loadw next-uwp cur-uwp vm:unwind-block-current-uwp-slot)
-      (b do-exit)
-      (store-symbol-value next-uwp lisp::*current-unwind-protect-block*))))
-
-
-(define-vop (throw)
-  (:args (target)
-	 (start)
-	 (count))
-  (:temporary (:scs (any-reg) :type fixnum)
-	      catch)
-  (:temporary (:scs (descriptor-reg))
-	      tag)
-  (:node-var node)
-  (:generator 0
-    (let ((loop (gen-label))
-	  (exit (gen-label))
-	  (error (generate-error-code node di:unseen-throw-tag-error target)))
-      (load-symbol-value catch lisp::*current-catch-block*)
-
-      (emit-label loop)
-
-      (inst bne catch zero-tn error)
-
-      (loadw tag catch vm:catch-block-tag-slot)
-      (inst beq tag target exit)
-      (nop)
-      (b loop)
-      (loadw catch catch vm:catch-block-previous-catch-slot)
-
-      (emit-label exit)
-
-      ;; ### Need to call unwind somehow.
-
-    )))
-
-
-
-;;;; Unwind block hackery:
-
-;;; Compute the address of the catch block from its TN, then store into the
-;;; block the current Cont, Env, Unwind-Protect, and the entry PC.
-;;;
-(define-vop (make-unwind-block)
-  (:args (tn)
-	 (entry-offset :scs (any-reg descriptor-reg)))
-  (:results (block :scs (descriptor-reg)))
-  (:temporary (:scs (descriptor-reg)) temp)
-  (:temporary (:scs (descriptor-reg) :target block) result)
-  (:generator 22
-    (inst addiu result cont-tn (* (tn-offset tn) vm:word-bytes))
-    (load-symbol-value temp lisp::*current-unwind-protect-block*)
-    (storew temp result vm:unwind-block-current-uwp-slot)
-    (storew cont-tn result vm:unwind-block-current-cont-slot)
-    (storew code-tn result vm:unwind-block-current-code-slot)
-    (storew entry-offset result vm:unwind-block-entry-pc-slot)
-    (move block result)))
-
-
-;;; Like Make-Unwind-Block, except that we also store in the specified tag, and
-;;; link the block into the Current-Catch list.
-;;;
-(define-vop (make-catch-block)
-  (:args (tn)
-	 (tag :scs (any-reg descriptor-reg))
-	 (entry-offset :scs (any-reg descriptor-reg)))
-  (:results (block :scs (descriptor-reg)))
-  (:temporary (:scs (descriptor-reg)) temp)
-  (:temporary (:scs (descriptor-reg) :target block) result)
-  (:generator 44
-    (inst addiu result cont-tn (* (tn-offset tn) vm:word-bytes))
-    (load-symbol-value temp lisp::*current-unwind-protect-block*)
-    (storew temp result vm:catch-block-current-uwp-slot)
-    (storew cont-tn result vm:catch-block-current-cont-slot)
-    (storew code-tn result vm:catch-block-current-code-slot)
-    (storew entry-offset result vm:catch-block-entry-pc-slot)
-
-    (storew tag result vm:catch-block-tag-slot)
-    (load-symbol-value temp lisp::*current-catch-block-slot*)
-    (storew temp result vm:catch-block-previous-catch-slot)
-    (store-symbol-value result lisp::*current-catch-block*)
-
-    (move block result)))
-
-
-;;; Just set the current unwind-protect to TN's address.  This instantiates an
-;;; unwind block as an unwind-protect.
-;;;
-(define-vop (set-unwind-protect)
-  (:args (tn))
-  (:temporary (:scs (descriptor-reg)) new-uwp)
-  (:generator 7
-    (inst addiu new-uwp cont-tn (* (tn-offset tn) vm:word-bytes))
-    (store-symbol-value new-uwp lisp::*current-unwind-protect-block*)))
-
-
-(define-vop (unlink-catch-block)
-  (:temporary (:scs (descriptor-reg)) block)
-  (:policy :fast-safe)
-  (:translate %catch-breakup)
-  (:generator 17
-    (load-symbol-value block lisp::*current-catch-block*)
-    (loadw block block vm:catch-block-previous-catch-slot)
-    (store-symbol-value block lisp::*current-catch-block*)))
-
-(define-vop (unlink-unwind-protect)
-  (:temporary (:scs (descriptor-reg)) block)
-  (:policy :fast-safe)
-  (:translate %unwind-protect-breakup)
-  (:generator 17
-    (load-symbol-value block lisp::*current-unwind-protect-block*)
-    (loadw block block vm:unwind-block-current-uwp-slot)
-    (store-symbol-value block lisp::*current-unwind-protect-block*)))
-
-
-;;;; NLX entry VOPs:
-;;;
-;;;    We can't just make these miscop variants, since they take funny wired
-;;; operands.
-;;;
-
-(define-vop (nlx-entry)
-  (:args (top :scs (descriptor-reg))
-	 (start)
-	 (count))
-  (:results (values :more t))
-  (:info nvals)
-  (:save-p :force-to-stack)
-  #+nil
-  (:generator 30
-    (unless (location= a0 top)
-      (inst lr a0 top))
-    (inst miscopx 'clc::nlx-entry-default-values)
-    (inst cal a1 zero-tn nvals)))
-
-
-(define-vop (nlx-entry-multiple)
-  (:args (top :scs (descriptor-reg))
-	 (start)
-	 (count))
-  (:save-p :force-to-stack)
-  #+nil
-  (:generator 30
-    (unless (location= a0 top)
-      (inst lr a0 top))
-    (inst miscop 'clc::nlx-entry-receive-values)
-    (unless (location= a0 r)
-      (inst lr r a0))
-    (unless (location= a1 r1)
-      (inst lr r1 a1))))
-
-
-;;; This VOP is just to force the TNs used in the cleanup onto the stack.
-;;;
-(define-vop (uwp-entry)
-  (:save-p :force-to-stack)
-  (:results (block) (start) (count))
-  (:ignore block start count)
-  (:generator 0))
diff --git a/compiler/mips/notes.txt b/compiler/mips/notes.txt
deleted file mode 100644
index 6ab180a1a2877c7d606d4a72f58782f1396c73a4..0000000000000000000000000000000000000000
--- a/compiler/mips/notes.txt
+++ /dev/null
@@ -1,161 +0,0 @@
-
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/notes.txt,v 1.2 1990/02/07 14:05:49 ram Rel $
-
-
-
-Call:
-
-There are several different kinds of call, depending on what is going on.
-
-The call can be named (i.e. use the symbol-function slot) or through a
-function object.
-
-The call can pass either a fixed number of args or a variable number of
-args.
-
-The call can return a fixed number of values, a variable number of values,
-or be a tail call.
-
-
-
-Register usage at the time of the call:
-
-LEXENV:  Holds the lexical environment to use during the call if it's a
-closure, or garbage if not.
-
-CALL-NAME:  Holds the symbol for a named call and garbage for others.
-
-OLD-CONT:  Holds the context pointer that should be restored upon return.
-
-A0...An:  Holds the first n+1 args.
-
-NARGS:  Holds the number of args, as a fixnum.
-
-ARGS:  Holds a pointer to the args.  Note: indexes off of this pointer are
-as if all the arguments were stored at it, e.g. the first stack arg is at
-ARGS[n] where n is number of register args.  Because of this, ARGS is the
-same as the callers CONT (OLD-CONT at the time of the call for non-tail
-call).
-[RAM: note that this must be set up even when NARGS<=n, since the callee may be
-expecting more arguments (due to optionals or a bad call.)  ARGS must be
-pointing to some valid chunk of memory, since the callee moves all of the
-positional args before checking to see if they are actually supplied.]
-
-LRA:  Holds the lisp-return-address object that the call should be returned
-to.  Calculated for non-tail call, and left as is for tail call.
-
-CSP:  Left as is.  The callee will set this as necessary based on CONT.
-
-NSP:  ???
-[RAM: will be managed similarly to CSP, i.e. callee has to allocate and is
-required to deallocate.]
-
-CONT:  The callee's context pointer.  Established as CSP for non-tail call,
-and left as is for tail call.
-
-CODE:  The function object being called.
-
-
-
-Register usage at the time of the return for single value return:
-
-A0:  The value.
-
-CODE:  The lisp-return-address we returned to.
-
-CSP:  Restored from CONT.
-[RAM: i.e. stack is guaranteed to be clean.  No SP frobbing is necessary.]
-
-CONT:  Restored from OLD-CONT.
-
-
-Additional register usage for multiple value return:
-
-NARGS:  Number of values being returned.
-
-A0...An:  The first n+1 values, or NIL if there are less than n+1 values.
-
-ARGS:  Pointer to the rest of the values.  The returnee's CONT.
-[RAM: i.e. as with ARGS in call, points n+1 words before the first stack
-value.]
-
-
-CSP:  CONT + NARGS*4
-
-
-
-
-What has to happen for this to work:
-
-Caller:
-  set NARGS
-  set ARGS
-  if tail call
-    CONT <- OLD-CONT
-  else
-    calc LRA
-    CONT <- CSP
-  if named
-    set CALL-NAME
-  set LEXENV
-  set CODE
-  calc target addr (CODE + n)
-  jr
-
-Callee:
-  allocate-frame
-    emit function header.
-    set CSP = CONT + size.
-    do something with nsp
-  setup-environment
-    set CODE = CODE - n
-  move-argument
-    move stack args from ARGS[n] to CONT[n]
-
-Returner:
-  known values:
-    move-result
-      move values from CONT[n] to OLD-CONT[n].
-    known-return
-      CONT = OLD-CONT
-      CODE = LRA
-      calc target addr (CODE + n)
-      jr
-
-  unknown constant values (return VOP):
-    nargs = 1 case:
-      CSP = CONT
-      CONT = OLD-CONT
-      CODE = LRA
-      calc target addr (CODE + n + 8)
-      jr
-    nargs != 1 case:
-      set NARGS
-      nil out unused arg regs
-      ARGS = CONT
-      CSP = CONT + NARGS * word-bytes
-      CONT = OLD-CONT
-      CODE = LRA
-      calc target addr (CODE + n)
-      jr
-
-  unknown variable values (return-multiple VOP):
-    copy the args from wherever to the top of the stack.
-[RAM: I would phrase this "to the beginning of the current (returner's) frame".
-They will already be there except with RETURN-MULTIPLE (when they *will* be on
-the stack top.)  But then after any copy, we adjust CSP so that the values are
-once again on stack top.]
-    nil out unused arg regs
-    ARGS = CONT
-    CSP = CONT + NARGS * word-bytes
-    CONT = OLD-CONT
-    CODE = LRA
-    calc target addr (CODE + n)
-    jr
-
-
-Returnee:
-  want fixed number of values:
-
-
-  want variable number of values:
diff --git a/compiler/mips/parms.lisp b/compiler/mips/parms.lisp
deleted file mode 100644
index c8074ee418fcb2bf56c1f2594b7c963407fa389a..0000000000000000000000000000000000000000
--- a/compiler/mips/parms.lisp
+++ /dev/null
@@ -1,305 +0,0 @@
-;;; -*- Package: VM; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/parms.lisp,v 1.22 1990/02/26 21:54:15 wlott Exp $
-;;;
-;;;    This file contains some parameterizations of various VM
-;;; attributes for the MIPS.  This file is separate from other stuff so 
-;;; that it can be compiled and loaded earlier. 
-;;;
-;;; Written by Rob MacLachlan
-;;;
-;;; Converted to MIPS by William Lott.
-;;;
-
-(in-package "VM")
-
-(export '(sc-number-limit most-positive-cost word-bits byte-bits word-shift
-	  word-bytes target-byte-order target-read-only-space-start
-	  target-static-space-start target-dynamic-space-start
-	  target-control-stack-start target-binding-stack-start
-	  target-heap-address-space lowtag-bits lowtag-mask
-	  lowtag-limit type-bits type-mask pad-data-block even-fixnum-type
-	  function-pointer-type other-immediate-0-type other-immediate-1-type
-	  list-pointer-type odd-fixnum-type structure-pointer-type
-	  other-pointer-type bignum-type ratio-type single-float-type
-	  double-float-type complex-type simple-array-type simple-string-type
-	  simple-bit-vector-type simple-vector-type
-	  simple-array-unsigned-byte-2-type
-	  simple-array-unsigned-byte-4-type
-	  simple-array-unsigned-byte-8-type
-	  simple-array-unsigned-byte-16-type
-	  simple-array-unsigned-byte-32-type simple-array-single-float-type
-	  simple-array-double-float-type complex-string-type
-	  complex-bit-vector-type complex-vector-type complex-array-type
-	  code-header-type function-header-type
-	  closure-function-header-type return-pc-header-type
-	  closure-header-type value-cell-header-type symbol-header-type
-	  base-character-type sap-type unbound-marker-type atomic-flag
-	  interrupted-flag pending-interrupt-trap error-trap cerror-trap
-	  fixnum static-symbols static-symbol-offset offset-static-symbol
-	  static-symbol-p
-	  *assembly-unit-length* target-fasl-code-format vm-version))
-	  
-
-(eval-when (compile load eval)
-
-
-;;;; Compiler constants.
-
-;;; Maximum number of SCs allowed.
-;;;
-(defconstant sc-number-limit 20)
-
-;;; The inclusive upper bound on a cost.  We want to write cost frobbing
-;;; code so that it is portable, but works on fixnums.  This constant
-;;; should be defined so that adding two costs cannot result in fixnum
-;;; overflow.
-;;;
-(defconstant most-positive-cost (1- (expt 2 20)))
-
-
-
-;;;; Machine Architecture parameters:
-
-(defconstant word-bits 32
-  "Number of bits per word where a word holds one lisp descriptor.")
-
-(defconstant byte-bits 8
-  "Number of bits per byte where a byte is the smallest addressable object.")
-
-(defconstant word-shift (1- (integer-length (/ word-bits byte-bits)))
-  "Number of bits to shift between word addresses and byte addresses.")
-
-(defconstant word-bytes (/ word-bits byte-bits)
-  "Number of bytes in a word.")
-
-(defconstant target-byte-order :little-endian
-  "The byte order of the target machine.  Should either be :big-endian
-  which has the MSB first (RT) or :little-endian which has the MSB last
-  (VAX).")
-
-
-
-;;;; Description of the target address space.
-
-;;; Where to put the different spaces and stacks.
-;;; 
-(defconstant target-read-only-space-start #x20000000)
-(defconstant target-static-space-start #x30000000)
-(defconstant target-dynamic-space-start #x40000000)
-(defconstant target-control-stack-start #x50000000)
-(defconstant target-binding-stack-start #x60000000)
-
-;;; How much memory to validate for lisp.
-;;; 
-(defconstant target-heap-address-space
-  '((#x40000000 . #x4000) ; Dynamic space
-    (#x50000000 . #x4000) ; Control stack
-    (#x60000000 . #x4000))) ; Binding stack
-
-
-
-;;;; Type definitions:
-
-(defconstant lowtag-bits 3
-  "Number of bits at the low end of a pointer used for type information.")
-
-(defconstant lowtag-mask (1- (ash 1 lowtag-bits))
-  "Mask to extract the low tag bits from a pointer.")
-  
-(defconstant lowtag-limit (ash 1 lowtag-bits)
-  "Exclusive upper bound on the value of the low tag bits from a
-  pointer.")
-
-(defconstant type-bits 8
-  "Number of bits used in the header word of a data block for typeing.")
-
-(defconstant type-mask (1- (ash 1 type-bits))
-  "Mask to extract the type from a header word.")
-
-(defmacro pad-data-block (words)
-  `(logandc2 (+ (ash ,words vm:word-shift) lowtag-mask) lowtag-mask))
-
-
-(defmacro defenum ((&key (prefix "") (suffix "") (start 0) (step 1))
-		   &rest identifiers)
-  (let ((results nil)
-	(index 0)
-	(start (eval start))
-	(step (eval step)))
-    (dolist (id identifiers)
-      (when id
-	(multiple-value-bind
-	    (root docs)
-	    (if (consp id)
-		(values (car id) (cdr id))
-		(values id nil))
-	  (push `(defconstant ,(intern (concatenate 'simple-string
-						    (string prefix)
-						    (string root)
-						    (string suffix)))
-		   ,(+ start (* step index))
-		   ,@docs)
-		results)))
-      (incf index))
-    `(eval-when (compile load eval)
-       ,@(nreverse results))))
-
-;;; The main types.  These types are represented by the low three bits of the
-;;; pointer or immeditate object.
-;;; 
-(defenum (:suffix -type)
-  even-fixnum
-  function-pointer
-  other-immediate-0
-  list-pointer
-  odd-fixnum
-  structure-pointer
-  other-immediate-1
-  other-pointer)
-
-;;; The heap types.  Each of these types is in the header of objects in
-;;; the heap.
-;;; 
-(defenum (:suffix -type
-	  :start (+ (ash 1 lowtag-bits) other-immediate-0-type)
-	  :step (ash 1 (1- lowtag-bits)))
-  bignum
-  ratio
-  single-float
-  double-float
-  complex
-  
-  simple-array
-  simple-string
-  simple-bit-vector
-  simple-vector
-  simple-array-unsigned-byte-2
-  simple-array-unsigned-byte-4
-  simple-array-unsigned-byte-8
-  simple-array-unsigned-byte-16
-  simple-array-unsigned-byte-32
-  simple-array-single-float
-  simple-array-double-float
-  complex-string
-  complex-bit-vector
-  complex-vector
-  complex-array
-  
-  code-header
-  function-header
-  closure-function-header
-  return-pc-header
-  closure-header
-  value-cell-header
-  symbol-header
-  base-character
-  sap
-  unbound-marker)
-
-
-;;;; Other non-type constants.
-
-(defenum (:suffix -flag)
-  atomic
-  interrupted)
-
-(defenum (:suffix -trap :start 8)
-  pending-interrupt
-  error
-  cerror)
-
-
-;;;; Static symbols.
-
-;;; These symbols are loaded into static space directly after NIL so
-;;; that the system can compute their address by adding a constant
-;;; amount to NIL.
-;;;
-
-(defparameter static-symbols
-  '(t
-
-    ;; Random stuff needed for initialization.
-    lisp::lisp-environment-list
-    lisp::lisp-command-line-list
-    lisp::*static-symbols*
-    lisp::*lisp-initialization-functions*
-    lisp::%initial-function
-
-    ;; Values needed for interfacing C and LISP.
-    lisp::*foreign-function-call-active*
-    lisp::*saved-global-pointer*
-    lisp::*saved-control-stack-pointer*
-    lisp::*saved-binding-stack-pointer*
-    lisp::*saved-allocation-pointer*
-    lisp::*saved-flags-register*
-
-    ;; Things needed for non-local-exit.
-    lisp::*current-catch-block*
-    lisp::*current-unwind-protect-block*
-    lisp::*eval-stack-top*
-    ))
-
-(defun static-symbol-p (symbol)
-  (member symbol static-symbols))
-
-(defun static-symbol-offset (symbol)
-  "Returns the byte offset of the static symbol Symbol."
-  (let ((posn (position symbol static-symbols)))
-    (unless posn (error "~S is not a static symbol." symbol))
-    (+ (* posn (pad-data-block symbol-size))
-       (pad-data-block (1- symbol-size))
-       other-pointer-type
-       (- list-pointer-type))))
-
-(defun offset-static-symbol (offset)
-  "Given a byte offset, Offset, returns the appropriate static symbol."
-  (multiple-value-bind
-      (n rem)
-      (truncate (+ offset list-pointer-type (- other-pointer-type)
-		   (- (pad-data-block (1- symbol-size))))
-		(pad-data-block symbol-size))
-    (unless (and (zerop rem) (<= 0 n (1- (length static-symbols))))
-      (error "Byte offset, ~D, is not correct." offset))
-    (elt static-symbols n)))
-
-
-;;;; Handy routine for making fixnums:
-
-(defun fixnum (num)
-  "Make a fixnum out of NUM.  (i.e. shift by two bits if it will fit.)"
-  (if (<= #x-20000000 num #x1fffffff)
-      (ash num 2)
-      (error "~D is too big for a fixnum." num)))
-
-
-
-;;;; Assembler parameters:
-
-;;; The number of bits per element in the assemblers code vector.
-;;;
-(defparameter *assembly-unit-length* 8)
-
-
-;;;; Other parameters:
-
-;;; The number representing the fasl-code format emit code in.
-;;;
-(defparameter target-fasl-code-format 7)
-
-;;; The version string for the implementation dependent code.
-;;;
-(defparameter vm-version "DECstation 3100/Mach 0.0")
-
-
-
-
-); Eval-When (Compile Load Eval)
diff --git a/compiler/mips/pred.lisp b/compiler/mips/pred.lisp
deleted file mode 100644
index 6dd78e178dccb279735d9064765f58f7ff116447..0000000000000000000000000000000000000000
--- a/compiler/mips/pred.lisp
+++ /dev/null
@@ -1,81 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/pred.lisp,v 1.2 1990/02/16 08:27:35 wlott Exp $
-;;;
-;;;    This file contains the VM definition of predicate VOPs for the MIPS.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-;;; Converted by William Lott.
-;;; 
-
-(in-package "C")
-
-
-;;;; The Branch VOP.
-
-;;; The unconditional branch, emitted when we can't drop through to the desired
-;;; destination.  Dest is the continuation we transfer control to.
-;;;
-(define-vop (branch)
-  (:info dest)
-  (:generator 5
-    (b dest)
-    (nop)))
-
-
-;;;; Conditional VOPs:
-
-;if-true (???), if-eql, ...
-
-(define-vop (if-eq)
-  (:args (x :scs (any-reg descriptor-reg zero null))
-	 (y :scs (any-reg descriptor-reg zero null)))
-  (:conditional)
-  (:info target not-p)
-  (:policy :fast-safe)
-  (:translate eq)
-  (:generator 3
-    (let ((x-prime (sc-case x
-		     ((any-reg descriptor-reg) x)
-		     (zero zero-tn)
-		     (null null-tn)))
-	  (y-prime (sc-case y
-		     ((any-reg descriptor-reg) y)
-		     (zero zero-tn)
-		     (null null-tn))))
-      (if not-p
-	  (inst bne x-prime y-prime target)
-	  (inst beq x-prime y-prime target)))
-    (nop)))
-
-
-
-
-;;;; Error VOPs
-
-(define-vop (error0)
-  (:args (code :scs (any-reg descriptor-reg)))
-  (:generator 1000
-    (error-call 0 code)))
-
-(define-vop (error1)
-  (:args (code :scs (any-reg descriptor-reg))
-	 (arg :scs (descriptor-reg)))
-  (:generator 1000
-    (error-call 1 code arg)))
-
-(define-vop (error2)
-  (:args (code :scs (any-reg descriptor-reg))
-	 (arg1 :scs (descriptor-reg))
-	 (arg2 :scs (descriptor-reg)))
-  (:generator 1000
-    (error-call 2 code arg1 arg2)))
-
diff --git a/compiler/mips/random-doc.txt b/compiler/mips/random-doc.txt
deleted file mode 100644
index 1391ca83391e03aab5febcf7b4776c7ec6a2e404..0000000000000000000000000000000000000000
--- a/compiler/mips/random-doc.txt
+++ /dev/null
@@ -1,351 +0,0 @@
--*- Mode: Text, Fill -*-
-
-$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/random-doc.txt,v 1.3 1990/03/02 17:40:56 ch Rel $
-
-DEFINE-STORAGE-BASE
-
-  Define-Storage-Base Name Kind {Key Value}*
-
-  Define a storage base having the specified Name.  Kind may be :Finite,
-  :Unbounded or :Non-Packed.  The following keywords are legal:
-
-  :Size <Size>
-      Specify the number of locations in a :Finite SB or the initial size of a
-      :Unbounded SB.
-
-
-DEFINE-STORAGE-CLASS
-
-  Define-Storage-Class Name Number Storage-Base {Key Value}*
-
-  Define a storage class Name that uses the named Storage-Base.  Number is a
-  small, non-negative integer that is used as an alias.  The following
-  keywords are defined:
-
-  :Element-Size <Size>
-      The size of objects in this SC in whatever units the SB uses.  This
-      defaults to 1.
-
-  :Locations
-      If the SB is :Finite, then this is a list of the offsets within the SB
-      that are in this SC.
-
-  
-DEFINE-MOVE-COSTS
-
-  Define-Move-Costs {((Source-SC*) {(Cost Dest-SC*)}*)}*
-
-  This macro declares the cost of the implicit move operations needed to load
-  arguments and store results.  The format is somewhat similar to the costs
-  specifications in Define-VOP.  Each argument form gives the cost for moving
-  to all possible destination SCs from some collection of equivalent source
-  SCs.
-
-  This information is used only to compute the cost of moves from arguments to
-  Load TNs or from Load TNs to results.  It is not necessary to specify the
-  costs for moves between combinations of SCs impossible in this context.
-
-
-DEFINE-SAVE-SCS
-
-  Define-Save-SCs {(save-sc saved-sc*)}*
-
-  This form is used to define which SCs must be saved on a function call.  The
-  Saved-SCs are SCs that must be saved.  The Save-SC a SC that is used in
-  combination with the defined move costs to determine the cost of saving.
-
-
-DEF-PRIMITIVE-TYPE
-
-  Def-Primitive-Type Name (SC*) {Key Value}*
-
-  Define a primitive type Name.  Each SC specifies a Storage Class that values
-  of this type may be allocated in.  The following keyword options are defined:
-
-  :Type
-      The type descriptor for the Lisp type that is equivalent to this type
-      (defaults to Name.)
-
-
-DEF-BOOLEAN-ATTRIBUTE
-
-  Def-Boolean-Attribute Name Attribute-Name*
-
-  Define a new class of boolean attributes, with the attributes havin the
-  specified Attribute-Names.  Name is the name of the class, which is used to
-  generate some macros to manipulate sets of the attributes: 
-
-    NAME-attributep attributes attribute-name*
-      Return true if one of the named attributes is present, false otherwise.
-
-    NAME-attributes attribute-name*
-      Return a set of the named attributes.
-
-
-PRIMITIVE-TYPE-VOP
-
-  Primitive-Type-VOP Vop (Kind*) Type*
-
-  Annotate all the specified primitive Types with the named VOP under each of
-  the specified kinds:
-
-  :Coerce-To-T
-  :Coerce-From-T
-  :Move
-      One argument one result VOPs used for coercion between representations
-      and explicit moves.
-
-  :Check
-      A one argument one result VOP that moves the argument to the result,
-      checking that the value is of this type in the process.
-
-DEFINE-VOP
- 
-  Define-VOP (Name [Inherits]) Spec*
-
-  Define the symbol Name to be a Virtual OPeration in the compiler.  If
-  specified, Inherits is the name of a VOP that we default unspecified
-  information from.  Each Spec is a list beginning with a keyword indicating
-  the interpretation of the other forms in the Spec:
-  
-  :Args {(Name {Key Value}*)}*
-  :Results {(Name {Key Value}*)}*
-      The Args and Results are specifications of the operand TNs passed to the
-      VOP.  The following operand options are defined:
-
-      :SCs (SC*)
-      :Load T-or-NIL
-	  :SCs specifies good SCs for this operand.  Other SCs will be
-	  penalized according to move costs.  If :Load is true (the default),
-	  then a load TN will be allocated if necessary, guaranteeing that the
-	  operand is always one of the specified SCs.
-
-      :More T-or-NIL
-	  If specified, Name is bound to the TN-Ref for the first argument or
-	  result following the fixed arguments or results.  A more operand must
-	  appear last, and cannot be targeted or restricted.
-
-      :Target Operand
-	  This operand is targeted to the named operand, indicating a desire to
-	  pack in the same location.  Not legal for results.
-  
-  :Conditional
-      This is used in place of :Results with conditional branch VOPs.  There
-      are no result values: the result is a transfer of control.  The
-      consequent and alternative continuations are passed as the first and
-      second :Info arguments.  A side-effect is to set the Predicate attribute
-      for functions in the :Translate option.
-  
-  :Temporary ({Key Value}*) Name*
-      Allocate a temporary TN for each Name, binding that variable to the TN
-      within the body of the generators.  In addition to :Target (which is 
-      is the same as for operands), the following options are
-      defined:
-
-      :Type Type
-          Specify the primitive type for the temporary, default T.
-
-      :SC SC-Name
-      :Offset SB-Offset
-	  Force the temporary to be allocated in the specified SC with the
-	  specified offset.  Offset is evaluated at macroexpand time.
-
-      :SCs (SC*)
-	  Restrict the temporary to a subset of the SCs allowed by the type,
-	  possibly requiring packing in a finite SC.
-
-      :From Time-Spec
-      :To Time-Spec
-	  Specify the beginning and end of the temporary's lives.  The defaults
-	  are :Load and :Save, i.e. the duration of the VOP.  The other
-	  intervening phases are :Argument, :Eval and :Result.  Non-zero
-	  sub-phases can be specified by a list, e.g. the second argument's
-	  life ends at (:Argument 1).
-  
-  :Generator Cost Form*
-      Specifies the translation into assembly code. Cost is the estimated cost
-      of the code emitted by this generator. The body is arbitrary Lisp code
-      that emits the assembly language translation of the VOP.  An Assemble
-      form is wrapped around the body, so code may be emitted by using the
-      local Inst macro.  During the evaluation of the body, the names of the
-      operands and temporaries are bound to the actual TNs.
-  
-  :Effects Effect*
-  :Affected Effect*
-      Specifies the side effects that this VOP has and the side effects that
-      effect its execution.  If unspecified, these default to the worst case.
-  
-  :Info Name*
-      Define some magic arguments that are passed directly to the code
-      generator.  The corresponding trailing arguments to VOP or %Primitive are
-      stored in the VOP structure.  Within the body of the generators, the
-      named variables are bound to these values.  Except in the case of
-      :Conditional VOPs, :Info arguments cannot be specified for VOPS that are
-      the direct translation for a function (specified by :Translate).
-
-  :Ignore Name*
-      Causes the named variables to be declared IGNORE in the generator body.
-
-  :Variant Thing*
-  :Variant-Vars Name*
-      These options provide a way to parameterize families of VOPs that differ
-      only trivially.  :Variant makes the specified evaluated Things be the
-      "variant" associated with this VOP.  :Variant-Vars causes the named
-      variables to be bound to the corresponding Things within the body of the
-      generator.
-
-  :Variant-Cost Cost
-      Specifies the cost of this VOP, overriding the cost of any inherited
-      generator.
-
-  :Note String
-      A short noun-like phrase describing what this VOP "does", i.e. the
-      implementation strategy.  This is for use in efficiency notes.
-
-  :Arg-Types Type*
-  :Result-Types Type*
-      Specify the template type restrictions used for automatic translation.
-      If there is a :More operand, the last type is the more type. 
-  
-  :Translate Name*
-      This option causes the VOP template to be entered as an IR2 translation
-      for the named functions.
-
-  :Policy {:Small | :Fast | :Safe | :Fast-Safe}
-      Specifies the policy under which this VOP is the best translation.
-
-  :Guard Form
-      Specifies a Form that is evaluated in the global environment.  If
-      form returns NIL, then emission of this VOP is prohibited even when
-      all other restrictions are met.
-
-  :Save-P {T | NIL | :Force-To-Stack}
-      Indicates how a VOP wants live registers saved.
-
-
-SC-CASE
-
-  SC-Case TN {({(SC-Name*) | SC-Name | T} Form*)}*
-
-  Case off of TN's SC.  The first clause containing TN's SC is evaulated,
-  returning the values of the last form.  A clause beginning with T specifies a
-  default.  If it appears, it must be last.  If no default is specified, and no
-  clause matches, then an error is signalled.
-
-
-DEFINE-MISCOP
-
-  Define-Miscop Name Args {Key Value}*
-
-  Define a miscop with the specified args/results and options.  The
-  following keywords are defined:
-
-  :results
-     Defaults to '(r).
-
-  :translate
-  :policy
-  :arg-types
-  :result-types
-  :cost
-  :conditional
-
-
-DEFINE-MISCOP-VARIANTS
-
-  Define-Miscop-Variants Vop Names*
-
-  Define a bunch of miscops VOPs that inherit the specified VOP and whose
-  Template name, Miscop name and translate function are all the same.
-
-
-DEF-SOURCE-TRANSFORM
-
-  Def-Source-Transform Name Lambda-List Form*
-
-  Define a macro-like source-to-source transformation for the function Name.
-  A source transform may "pass" by returning a non-nil second value.  If the
-  transform passes, then the form is converted as a normal function call.  If
-  the supplied arguments are not compatible with the specified lambda-list,
-  then the transform automatically passes.
-  
-  Source-Transforms may only be defined for functions.  Source transformation
-  is not attempted if the function is declared Notinline.  Source transforms
-  should not examine their arguments.  If it matters how the function is used,
-  then Deftransform should be used to define an IR1 transformation.
-  
-  If the desirability of the transformation depends on the current Optimize
-  parameters, then the Policy macro should be used to determine when to pass.
-
-
-DEFKNOWN
-
-  Defknown Name Arg-Types Result-Type [Attributes] {Key Value}* 
-
-  Declare the function Name to be a known function.  We construct a type
-  specifier for the function by wrapping (FUNCTION ...) around the Arg-Types
-  and Result-Type.  Attributes is a an unevaluated list of the boolean
-  attributes that the function has.  These attributes are meaningful here:
-      call
-         May call functions that are passed as arguments.  In order to determine
-         what other effects are present, we must find the effects of all arguments
-         that may be functions.
-        
-      unsafe
-         May incorporate arguments in the result or somehow pass them upward.
-        
-      unwind
-         May fail to return during correct execution.  Errors are O.K.
-        
-      any
-         The (default) worst case.  Includes all the other bad things, plus any
-         other possible bad thing.
-        
-      foldable
-         May be constant-folded.  The function has no side effects, but may be
-         affected by side effects on the arguments.  e.g. SVREF, MAPC.
-        
-      flushable
-         May be eliminated if value is unused.  The function has no side effects
-         except possibly CONS.  If a function is defined to signal errors, then
-         it is not flushable even if it is movable or foldable.
-        
-      movable
-         May be moved with impunity.  Has no side effects except possibly CONS,
-         and is affected only by its arguments.
-
-      predicate
-          A true predicate likely to be open-coded.  This is a hint to IR1
-	  conversion that it should ensure calls always appear as an IF test.
-	  Not usually specified to Defknown, since this is implementation
-	  dependent, and is usually automatically set by the Define-VOP
-	  :Conditional option.
-
-  Name may also be a list of names, in which case the same information is given
-  to all the names.  The keywords specify the initial values for various
-  optimizers that the function might have.
-
-
-DEF-PRIMITIVE-TRANSLATOR
-
-  Def-Primitive-Translator Name Lambda-List Form*
-
-  Define a function that converts a use of (%PRIMITIVE Name ...) into Lisp
-  code.  Lambda-List is a defmacro style lambda list.
-
-
-CTYPE-OF
-
-  CType-Of Object
-
-  Like Type-Of, only returns a Type structure instead of a type
-  specifier.  We try to return the type most useful for type checking,
-  rather than trying to come up with the one that the user might find
-  most informative.
-
-
-SC-IS
-
-  SC-Is TN SC*
-
-  Returns true if TNs SC is any of the named SCs, false otherwise.
diff --git a/compiler/mips/subprim.lisp b/compiler/mips/subprim.lisp
deleted file mode 100644
index d22278b7e1c46faff811a279a69dad357eb0c6ec..0000000000000000000000000000000000000000
--- a/compiler/mips/subprim.lisp
+++ /dev/null
@@ -1,167 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    Linkage information for standard miscops, both primitive and
-;;; sub-primitive.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-
-;;;; Subprimitive miscops:
-
-#| Inline versions exist, and we can't currently support multiple
-implementations, since they are accessed through %primitive.
-
-(define-miscop 16bit-system-ref (s i))
-(define-miscop 16bit-system-set (s i v))
-(define-miscop 8bit-system-ref (s i))
-(define-miscop 8bit-system-set (s i v))
-|#
-
-(define-miscop active-call-frame ())
-(define-miscop active-catch-frame ())
-(define-miscop alloc-array (n))
-(define-miscop alloc-bit-vector (n))
-(define-miscop alloc-code (n))
-(define-miscop alloc-function (n))
-(define-miscop alloc-g-vector (n i))
-(define-miscop alloc-i-vector (n a))
-(define-miscop alloc-static-g-vector (len))
-(define-miscop alloc-string (n))
-(define-miscop bit-bash (v1 v2 res op) :results ())
-(define-miscop break-return (stack) :results ())
-(define-miscop call-foreign (cfcn args nargs))
-#|Inline implementation...
-(define-miscop check-<= (n l))
-|#
-(define-miscop collect-garbage () :results ())
-(define-miscop current-binding-pointer ())
-(define-miscop current-stack-pointer ())
-(define-miscop dynamic-space-in-use ())
-(define-miscop error0 (code) :results ())
-(define-miscop error1 (code x) :results ())
-(define-miscop error2 (code x y) :results ())
-(define-miscop find-character (string start end character))
-(define-miscop find-character-with-attribute (a b c d e))
-(define-miscop float-long (x))
-(define-miscop float-short (x))
-(define-miscop get-allocation-space ())
-(define-miscop get-space (x))
-(define-miscop get-type (x))
-(define-miscop get-vector-access-code (v))
-#|Inline implementation...
-(define-miscop get-vector-subtype (v))
-|#
-(define-miscop halt ())
-#|Inline implementation...
-(define-miscop header-length (x))
-(define-miscop header-ref (x i))
-(define-miscop header-set (x i v))
-|#
-(define-miscop logdpb (v s p n))
-(define-miscop logldb (s p n))
-(define-miscop long-float-ref (l i))
-(define-miscop long-float-set (l i x))
-(define-miscop lsh (n b))
-(define-miscop make-complex (re im))
-(define-miscop make-immediate-type (obj type))
-(define-miscop make-ratio (num den))
-(define-miscop negate (n))
-(define-miscop newspace-bit ())
-(define-miscop pointer-system-set (s i p))
-(define-miscop purify () :results ())
-(define-miscop read-binding-stack (b))
-(define-miscop read-control-stack (f))
-(define-miscop reset-c-stack (sp) :results ())
-(define-miscop return-to-c (sp value) :results ())
-(define-miscop sap-system-ref (s i))
-(define-miscop save (x y z))
-(define-miscop set-allocation-space (space) :results ())
-(define-miscop set-c-procedure-pointer (s o v))
-(define-miscop set-call-frame (p))
-(define-miscop set-catch-frame (x))
-(define-miscop set-vector-subtype (v x))
-(define-miscop shrink-vector (v n))
-#|Inline implementation...
-(define-miscop signed-16bit-system-ref (s i))
-|#
-(define-miscop signed-32bit-system-ref (s i))
-(define-miscop signed-32bit-system-set (s i v) :translate (setf sap-ref-32))
-(define-miscop sxhash-simple-string (string))
-(define-miscop sxhash-simple-substring (string length))
-(define-miscop syscall0 (n) :results (res err))
-(define-miscop syscall1 (n x) :results (res err))
-(define-miscop syscall2 (n x y) :results (res err))
-(define-miscop syscall3 (n x y z) :results (res err))
-(define-miscop syscall4 (n x y z xx) :results (res err))
-(define-miscop typed-vref (a v i))
-(define-miscop typed-vset (a v i x))
-(define-miscop unbind-to-here (x) :results ())
-(define-miscop unix-fork (code-ptr) :results (res err))
-(define-miscop unix-pipe () :results (res err))
-(define-miscop unix-wait () :results (res err))
-(define-miscop unix-write (fd buf offset len) :results (res err))
-(define-miscop unsigned-32bit-system-ref (s i) :translate sap-ref-32)
-(define-miscop vector-length (vec))
-(define-miscop write-binding-stack (b v))
-(define-miscop write-control-stack (f v))
-
-(define-vop (syscall n-arg-two-value-miscop)
-  (:variant 'clc::syscall))
-
-(def-primitive-translator float-single (x)
-  `(%primitive float-short ,x))
-
-
-;;;; Primitive miscops:
-
-(defknown ext:assq (t list) list (foldable flushable))
-(defknown ext:memq (t list) list (foldable flushable))
-
-(define-miscop abs (num) :translate abs)
-(define-miscop alloc-symbol (name) :translate make-symbol)
-(define-miscop ash (i n) :translate ash)
-(define-miscop assq (key alist) :translate ext:assq)
-(define-miscop atan (x) :translate atan)
-(define-miscop cos (x) :translate cos)
-(define-miscop decode-float (f) :results (frac exp sign) :translate decode-float)
-(define-miscop denominator (n) :translate denominator)
-(define-miscop exp (x) :translate exp)
-(define-miscop gcd (x y) :translate gcd)
-(define-miscop get-real-time () :translate get-internal-real-time)
-(define-miscop get-run-time () :translate get-internal-run-time)
-(define-miscop imagpart (z) :translate imagpart)
-(define-miscop integer-length (i) :translate integer-length)
-(define-miscop last (l) :translate last)
-(define-miscop log (n) :translate log)
-(define-miscop logcount (i) :translate logcount)
-(define-miscop memq (item list) :translate ext:memq)
-(define-miscop nthcdr (n l) :translate nthcdr)
-(define-miscop numerator (n) :translate numerator)
-(define-miscop put (sym prop val) :translate %put)
-(define-miscop realpart (z) :translate realpart)
-(define-miscop sap-int (sap) :translate sap-int)
-(define-miscop scale-float (f exp) :translate scale-float)
-(define-miscop sin (x) :translate sin)
-(define-miscop sqrt (x) :translate sqrt)
-(define-miscop tan (x) :translate tan)
-
-(define-vop (list n-arg-miscop)
-  (:variant 'list))
-
-(define-vop (list* n-arg-miscop)
-  (:variant 'list*))
-
-;;; Continuation to allow %sp-byte-blt for now...
-(defknown lisp::%sp-byte-blt (t index t index index) void ())
-(define-miscop byte-blt (src src-start dst dst-start dst-end)
-  :translate lisp::%sp-byte-blt)
-
diff --git a/compiler/mips/system.lisp b/compiler/mips/system.lisp
deleted file mode 100644
index ecbb756d94c21ccbfd0f31de25a32ab504da0738..0000000000000000000000000000000000000000
--- a/compiler/mips/system.lisp
+++ /dev/null
@@ -1,189 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    RT VM definitions of various system hacking operations.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-(define-vop (pointer+)
-  (:args (ptr :scs (descriptor-reg))
-	 (offset :scs (any-reg descriptor-reg)))
-  (:results (res :scs (descriptor-reg)))
-  (:policy :fast-safe)
-  #+nil
-  (:generator 1
-    (inst cas res offset ptr)))
-
-(define-vop (sap+ pointer+)
-  (:translate sap+))
-
-(define-vop (pointer-)
-  (:args (ptr1 :scs (descriptor-reg) :target temp)
-	 (ptr2 :scs (descriptor-reg)))
-  (:results (res :scs (any-reg descriptor-reg)))
-  (:temporary (:from (:argument 0) :to (:result 0) :target res) temp)
-  #+nil
-  (:generator 1
-    (unless (location= ptr1 temp)
-      (inst lr temp ptr1))
-    (inst s temp ptr2)
-    (unless (location= temp res)
-      (inst lr res temp))))
-
-(define-vop (vector-word-length)
-  (:args (vec :scs (descriptor-reg)))
-  (:results (res :scs (any-reg descriptor-reg)))
-  #+nil
-  (:generator 6
-    (loadw res vec clc::g-vector-header-words)
-    (inst niuo res res clc::g-vector-words-mask-16)))
-
-(define-vop (int-sap)
-  (:args (x :scs (any-reg descriptor-reg) :target res))
-  (:results (res :scs (any-reg descriptor-reg)))
-  (:temporary (:type random  :scs (non-descriptor-reg)) temp)
-  (:translate int-sap)
-  (:policy :fast-safe)
-  #+nil
-  (:generator 6
-    (unless (location= res x)
-      (inst lr res x))
-    (let ((fixp (gen-label)))
-      (test-simple-type res temp fixp t system:%bignum-type)
-      (loadw res x (/ clc::bignum-header-size 4))
-      (emit-label fixp))))
-
-(define-vop (pointer-compare)
-  (:args (x :scs (any-reg descriptor-reg))
-	 (y :scs (any-reg descriptor-reg)))
-  (:conditional)
-  (:info target not-p)
-  (:policy :fast-safe)
-  (:note "inline comparison")
-  (:variant-vars condition)
-  #+nil
-  (:generator 3
-    (inst cl x y)
-    (if not-p
-	(inst bnb condition target)
-	(inst bb condition target))))
-
-(macrolet ((frob (name cond)
-	     `(progn
-		(def-primitive-translator ,name (x y) `(,',name ,x ,y))
-		(defknown ,name (t t) boolean (movable foldable flushable))
-		(define-vop (,name pointer-compare)
-		  (:translate ,name)
-		  (:variant ,cond)))))
-  (frob pointer< :lt)
-  (frob pointer> :gt))
-
-(define-vop (check-op)
-  (:args (x :scs (any-reg descriptor-reg))
-	 (y :scs (any-reg descriptor-reg)))
-  (:variant-vars condition not-p error)
-  (:node-var node)
-  (:policy :fast-safe)
-  #+nil
-  (:generator 3
-    (inst c x y)
-    (let ((target (generate-error-code node error x y)))
-      (if not-p
-	  (inst bb condition target)
-	  (inst bnb condition target)))))
-
-(define-vop (check<= check-op)
-  (:variant :gt t clc::error-not-<=)
-  (:translate check<=))
-
-(define-vop (check= check-op)
-  (:variant :eq nil clc::error-not-=)
-  (:translate check=))
-
-(def-primitive-translator make-fixnum (x)
-  `(%primitive make-immediate-type ,x system:%+-fixnum-type))
-
-(define-vop (make-immediate-type)
-  (:args (val :scs (any-reg descriptor-reg))
-	 (type :scs (any-reg descriptor-reg short-immediate
-			     unsigned-immediate)
-	       :target temp))
-  (:results (res :scs (any-reg descriptor-reg)))
-  (:temporary (:type random  :scs (non-descriptor-reg)) temp)
-  #+nil
-  (:generator 2
-    (sc-case type
-      ((short-immediate unsigned-immediate)
-       (inst niuo res val clc::type-not-mask-16)
-       (let ((code (tn-value type)))
-	 (check-type code (unsigned-byte 5))
-	 (unless (zerop code)
-	   (inst oiu res res (ash code clc::type-shift-16)))))
-      (t
-       (unless (location= type temp)
-	 (inst lr temp type))
-       (inst niuo res val clc::type-not-mask-16)
-       (inst sli16 temp clc::type-shift-16)
-       (inst o res temp)))))
-
-
-(define-vop (16bit-system-ref halfword-index-ref)
-  (:translate sap-ref-16)
-  (:variant 0))
-
-(define-vop (signed-16bit-system-ref signed-halfword-index-ref)
-  (:variant 0))
-
-(define-vop (16bit-system-set halfword-index-set)
-  (:translate (setf sap-ref-16))
-  (:variant 0))
-
-(define-vop (8bit-system-ref byte-index-ref)
-  (:translate sap-ref-8)
-  (:variant 0))
-
-(define-vop (8bit-system-set byte-index-set)
-  (:translate (setf sap-ref-8))
-  (:variant 0))
-
-
-(define-vop (current-sp)
-  (:results (val :scs (any-reg descriptor-reg)))
-  #+nil
-  (:generator 1
-    (inst lr val sp-tn)))
-
-;;; This guy makes sure that there aren't any random garbage pointers lying
-;;; around in registers by clearing all of the boxed registers.  Our allocating
-;;; all of the boxed registers as temporaries will prevent any TNs from being
-;;; packed in those registers at the time this VOP is invoked.
-;;;
-(define-vop (clear-registers)
-  (:temporary (:sc any-reg :offset 1) a0)
-  (:temporary (:sc any-reg :offset 3) a1)
-  (:temporary (:sc any-reg :offset 5) a2)
-  (:temporary (:sc any-reg :offset 4) t0)
-  (:temporary (:sc any-reg :offset 7) l0)
-  (:temporary (:sc any-reg :offset 8) l1)
-  (:temporary (:sc any-reg :offset 9) l2)
-  (:temporary (:sc any-reg :offset 10) l3)
-  (:temporary (:sc any-reg :offset 11) l4)
-  #+nil
-  (:generator 10
-    (inst lis a0 0)
-    (inst lis a1 0)
-    (inst lis a2 0)
-    (inst lis t0 0)
-    (inst lis l0 0)
-    (inst lis l1 0)
-    (inst lis l2 0)
-    (inst lis l3 0)
-    (inst lis l4 0)))
diff --git a/compiler/mips/type-vops.lisp b/compiler/mips/type-vops.lisp
deleted file mode 100644
index 297fac6513bb52698e91c5d967e7d7e79d61d3d4..0000000000000000000000000000000000000000
--- a/compiler/mips/type-vops.lisp
+++ /dev/null
@@ -1,295 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/type-vops.lisp,v 1.3 1990/02/26 22:53:50 ch Exp $
-;;; 
-;;; This file contains the VM definition of type testing and checking VOPs
-;;; for the RT.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-;;; Converted for the MIPS R2000 by Christopher Hoover.
-;;;
-(in-package "C")
-
-;;; ### These belongs in compiler/fundb.lisp
-;;; 
-(defknown realp (t) boolean (movable foldable flushable))
-(defknown sap-p (t) boolean (movable foldable flushable))
-
-
-;;;; Simple type checking and testing:
-;;;
-;;;    These types are represented by a single type code, so are easily
-;;; open-coded as non-shifting type test.
-
-(define-vop (check-simple-type)
-  (:args
-   (value :target result
-	  :scs (any-reg descriptor-reg)))
-  (:results
-   (result :scs (any-reg descriptor-reg)))
-  (:variant-vars type-code error-code)
-  (:node-var node)
-  (:temporary (:type random :scs (non-descriptor-reg)) temp)
-  (:generator 4
-    (let ((err-lab (generate-error-code node error-code value)))
-      (test-simple-type value temp err-lab t type-code)
-      (move result value))))
-
-(define-vop (simple-type-predicate)
-  (:args
-   (value :scs (any-reg descriptor-reg)))
-  (:conditional)
-  (:info target not-p)
-  (:variant-vars type-code)
-  (:policy :fast-safe)
-  (:temporary (:type random :scs (non-descriptor-reg)) temp)
-  (:generator 4
-    (test-simple-type value temp target not-p type-code)))
-
-(macrolet ((frob (pred-name check-name ptype type-code error-code)
-	     `(progn
-		(define-vop (,pred-name simple-type-predicate)
-		  (:variant ,type-code)
-		  (:translate ,pred-name))
-
-		,@(when check-name
-		    `((define-vop (,check-name check-simple-type)
-			(:variant ,type-code ,error-code))
-		      (primitive-type-vop ,check-name (:check) ,ptype))))))
-
-  ;; ### Want to tweek costs so that checks that do dereferences are
-  ;; more expensive.
-  ;; 
-  ;; ### May want to add all of the (simple-array <mumble> (*))
-  ;; primitive types.
-  ;;
-  ;; ### May need to add array-header-p and friends.  Whoever ports the
-  ;; array code will probably have to frob stuff here.
-  ;; 
-  (frob functionp check-function function
-    vm:function-pointer-type di:object-not-function-error)
-
-  (frob listp check-list list
-    vm:list-pointer-type di:object-not-list-error)
-
-  (frob bignump check-bigunm bignum
-    vm:bignum-type di:object-not-bignum-error)
-
-  (frob ratiop check-ratio ratio
-    vm:ratio-type di:object-not-ratio-error)
-
-  (frob single-float-p check-single-float single-float
-    vm:single-float-type di:object-not-single-float-error)
-
-  (frob double-float-p check-double-float double-float
-    vm:double-float-type di:object-not-double-float-error)
-
-  (frob simple-string-p check-simple-string simple-string
-    vm:simple-string-type di:object-not-simple-string-error)
-
-  (frob simple-bit-vector-p check-simple-bit-vector simple-bit-vector
-    vm:simple-bit-vector-type di:object-not-simple-bit-vector-error)
-
-  (frob simple-vector-p check-simple-vector simple-vector
-    vm:simple-vector-type di:object-not-simple-vector-error)
-
-  ;; ### This should really be base-character-p ...
-  (frob string-char-p check-base-character base-character
-    vm:base-character-type di:object-not-base-character-error)
-
-  (frob sap-p check-sap sap
-    vm:sap-type di:object-not-sap-error))
-
-
-;;; Slightly tenser versions for FIXNUM's
-;;; 
-(define-vop (check-fixnum check-simple-type)
-  (:ignore type-code error-code)
-  (:generator 3
-    (let ((err-lab (generate-error-code node di:object-not-fixnum-error
-					value)))
-      (inst andi temp value #x3)
-      (inst bne temp zero-tn err-lab)
-      (move result value t))))
-
-(define-vop (fixnump simple-type-predicate)
-  (:ignore type-code)
-  (:generator 3
-    (inst andi temp value #x3)
-    (if not-p
-	(inst bne temp zero-tn target)
-	(inst beq temp zero-tn target))
-    (nop)))
-
-(primitive-type-vop check-fixnum (:check) fixnum)
-
-
-;;;; Hairy type tests:
-;;;
-;;;    These types are represented by a union of type codes.  
-;;;
-
-(define-vop (hairy-type-predicate)
-  (:args
-   (obj :scs (any-reg descriptor-reg)
-	:target temp))
-  (:conditional)
-  (:info target not-p)
-  (:policy :fast-safe)
-  (:temporary (:type random :scs (non-descriptor-reg)) temp))
-
-(define-vop (check-hairy-type)
-  (:args
-   (obj :scs (any-reg descriptor-reg)
-	:target res))
-  (:results
-   (res :scs (any-reg descriptor-reg)))
-  (:temporary (:type random :scs (non-descriptor-reg)) temp)
-  (:node-var node))
-
-(macrolet ((frob (pred-name check-name error-code &rest types)
-	     (let ((cost (* (+ (length types)
-			       (count-if #'consp types))
-			    4)))
-	       `(progn
-		  ,@(when pred-name
-		      `((define-vop (,pred-name hairy-type-predicate)
-			  (:translate ,pred-name)
-			  (:generator ,cost
-			    (test-hairy-type obj temp target not-p ,@types)))))
-			
-		  ,@(when check-name
-		      `((define-vop (,check-name check-hairy-type)
-			  (:generator ,cost
-			    (let ((err-lab (generate-error-code
-					    node ,error-code obj)))
-			      (test-hairy-type obj temp err-lab t ,@types))
-			    (move res obj)))))))))
-
-  (frob nil check-function-or-symbol di:object-not-function-or-symbol-error
-    vm:function-pointer-type vm:symbol-header-type)
-
-  (frob vectorp check-vector di:object-not-vector-error
-    (vm:simple-string-type vm:simple-array-double-float-type))
-
-  (frob stringp check-string di:object-not-string-error
-    vm:simple-string-type vm:complex-string-type)
-
-  (frob bit-vector-p check-bit-vector di:object-not-bit-vector-error
-    vm:simple-bit-vector-type vm:complex-bit-vector-type)
-
-  (frob arrayp check-array di:object-not-array-error
-    (vm:simple-array-type vm:complex-array-type))
-
-  (frob numberp check-number di:object-not-number-error
-    vm:even-fixnum-type vm:odd-fixnum-type
-    (vm:bignum-type vm:complex-type))
-
-  (frob rationalp check-rational di:object-not-rational-error
-    vm:even-fixnum-type vm:odd-fixnum-type
-    vm:ratio-type vm:bignum-type)
-
-  (frob floatp check-float di:object-not-float-error
-    vm:single-float-type vm:double-float-type)
-
-  (frob realp check-real di:object-not-real-error
-    vm:even-fixnum-type vm:odd-fixnum-type
-    vm:ratio-type vm:bignum-type
-    vm:single-float-type vm:double-float-type)
-  
-  ;; ### May want to make this more tense.
-  (frob integerp check-integer di:object-not-integer-error
-    vm:even-fixnum-type vm:odd-fixnum-type
-    vm:bignum-type))
-
-
-;;;; List/symbol types:
-;;; 
-;;; symbolp (or symbol (eq nil))
-;;; consp (and list (not (eq nil)))
-
-(define-vop (list-symbol-predicate)
-  (:args
-   (obj :scs (any-reg descriptor-reg)))
-  (:conditional)
-  (:info target not-p)
-  (:policy :fast-safe)
-  (:temporary (:type random  :scs (non-descriptor-reg)) temp)))
-
-(define-vop (check-list-symbol check-hairy-type)
-  (:temporary (:type random  :scs (non-descriptor-reg)) temp))
-
-
-(macrolet ((frob (pred-name check-name error-code &rest body)
-	     `(progn
-		(define-vop (,pred-name list-symbol-predicate)
-		  (:translate ,pred-name)
-		  (:generator 8
-		    ,@body))
-		(define-vop (,check-name check-list-symbol)
-		  (:generator 8
-		    (let ((target (generate-error-code node ,error-code obj))
-			  (not-p t))
-		      ,@body
-		      (move res obj)))))))
-
-  (frob symbolp check-symbol di:object-not-symbol-error
-    (let* ((drop-thru (gen-label))
-	   (is-symbol-label (if not-p drop-thru target)))
-      (inst beq obj null-tn is-symbol-label)
-      (nop)
-      (test-simple-type obj temp target not-p vm:symbol-header-type)
-      (emit-label drop-thru)))
-
-  (frob consp check-cons di:object-not-cons-error
-    (let* ((drop-thru (gen-label))
-	   (is-not-cons-label (if not-p target drop-thru)))
-      (inst beq obj null-tn is-not-cons-label)
-      (nop)
-      (test-simple-type obj temp target not-p vm:list-pointer-type)
-      (emit-label drop-thru))))
-
-
-;;;; Function Coercion
-
-;;; If not a function, get the symbol value and test for that being a
-;;; function.  Since we test for a function rather than the unbound
-;;; marker, this works on NIL.
-;;;
-(define-vop (coerce-to-function)
-  (:args (object :scs (descriptor-reg)
-		:target result))
-  (:results (result :scs (descriptor-reg)))
-  (:node-var node)
-  (:temporary (:type random  :scs (non-descriptor-reg)) nd-temp)
-  (:temporary (:scs (descriptor-reg)) saved-object)
-  (:generator 0
-    (let ((not-function-label (gen-label))
-	  (not-coercable-label (gen-label))
-	  (done-label (gen-label)))
-      (test-simple-type object nd-temp not-function-label t
-			vm:function-pointer-type)
-      (move result object)
-      (emit-label done-label)
-
-      (unassemble
-	(assemble-elsewhere node
-	  (emit-label not-function-label)
-	  (test-simple-type object nd-temp not-coercable-label t
-			    vm:symbol-header-type)
-	  (move saved-object object)
-	  (loadw result object vm:symbol-function-slot vm:other-pointer-type)
-	  (test-simple-type result nd-temp done-label nil
-			    vm:function-pointer-type)
-	  (error-call di:undefined-symbol-error saved-object)
-
-	  (emit-label not-coercable-label)
-	  (error-call di:object-not-coercable-to-function-error object))))))
diff --git a/compiler/mips/values.lisp b/compiler/mips/values.lisp
deleted file mode 100644
index 6bb2f5f2ec016c9e515ab040eaedc842d7333a6d..0000000000000000000000000000000000000000
--- a/compiler/mips/values.lisp
+++ /dev/null
@@ -1,94 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/values.lisp,v 1.4 1990/02/26 23:43:43 wlott Exp $
-;;;
-;;;    This file contains the implementation of unknown-values VOPs.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-;;; Converted for MIPS by William Lott.
-;;; 
-
-(in-package "C")
-
-(define-vop (reset-stack-pointer)
-  (:args (ptr :scs (any-reg)))
-  (:generator 1
-    (move csp-tn ptr)))
-
-
-;;; Push some values onto the stack, returning the start and number of values
-;;; pushed as results.  It is assumed that the Vals are wired to the standard
-;;; argument locations.  Nvals is the number of values to push.
-;;;
-;;; The generator cost is pseudo-random.  We could get it right by defining a
-;;; bogus SC that reflects the costs of the memory-to-memory moves for each
-;;; operand, but this seems unworthwhile.
-;;;
-(define-vop (push-values)
-  (:args
-   (vals :more t))
-  (:results
-   (start :scs (descriptor-reg))
-   (count :scs (any-reg descriptor-reg)))
-  (:info nvals)
-  (:temporary (:scs (descriptor-reg)) temp)
-  (:temporary (:scs (descriptor-reg)
-	       :to (:result 0)
-	       :target start)
-	      start-temp)
-  (:generator 20
-    (move start-temp csp-tn)
-    (inst addi csp-tn csp-tn (* nvals vm:word-bytes))
-    (do ((val vals (tn-ref-across val))
-	 (i 0 (1+ i)))
-	((null val))
-      (let ((tn (tn-ref-tn val)))
-	(sc-case tn
-	  (descriptor-reg
-	   (storew tn start-temp i))
-	  (control-stack
-	   (load-stack-tn temp tn)
-	   (storew temp start-temp i)))))
-    (move start start-temp)
-    (move count nvals)))
-
-
-;;; Push a list of values on the stack, returning Start and Count as used in
-;;; unknown values continuations.
-;;;
-(define-vop (values-list)
-  (:args (arg :scs (descriptor-reg) :target list))
-  (:arg-types list)
-  (:policy :fast-safe)
-  (:results (start :scs (any-reg descriptor-reg))
-	    (count :scs (descriptor-reg)))
-  (:temporary (:scs (descriptor-reg) :type list :from (:argument 0)) list)
-  (:temporary (:scs (descriptor-reg)) temp)
-  (:temporary (:scs (non-descriptor-reg) :type random) ndescr)
-  (:generator 0
-    (let ((loop (gen-label))
-	  (done (gen-label)))
-
-      (move list arg)
-      (move start csp-tn)
-
-      (emit-label loop)
-      (inst beq list null-tn done)
-      (loadw temp list vm:cons-car-slot vm:list-pointer-type)
-      (loadw list list vm:cons-cdr-slot vm:list-pointer-type)
-      (inst addiu csp-tn csp-tn vm:word-bytes)
-      (storew temp csp-tn -1)
-      (test-simple-type list ndescr loop nil vm:list-pointer-type)
-      (error-call di:bogus-argument-to-values-list-error list)
-
-      (emit-label done)
-      (inst sub count csp-tn start))))
-
diff --git a/compiler/mips/vm.lisp b/compiler/mips/vm.lisp
deleted file mode 100644
index 6f2b9ffebc1611f1a0d10b1574e4d7eaf01bceef..0000000000000000000000000000000000000000
--- a/compiler/mips/vm.lisp
+++ /dev/null
@@ -1,520 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the CMU Common Lisp project at
-;;; Carnegie Mellon University, and has been placed in the public
-;;; domain.  If you want to use this code or any part of CMU Common
-;;; Lisp, please contact Scott Fahlman (Scott.Fahlman@CS.CMU.EDU)
-;;; **********************************************************************
-;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/vm.lisp,v 1.12 1990/02/26 22:55:51 ch Exp $
-;;;
-;;; This file contains the VM definition for the MIPS R2000 and the new
-;;; object format.
-;;;
-;;; Written by Christopher Hoover and William Lott.
-;;;
-(in-package "C")
-
-
-;;;; SB and SC definition:
-
-(define-storage-base registers :finite :size 32)
-(define-storage-base control-stack :unbounded :size 8)
-(define-storage-base number-stack :unbounded :size 8)
-(define-storage-base constant :non-packed)
-(define-storage-base immediate-constant :non-packed)
-
-;;;
-;;; Handy macro so we don't have to keep changing all the numbers whenever
-;;; we insert a new storage class.
-;;; 
-(defmacro define-storage-classes (&rest classes)
-  `(progn
-     ,@(mapcar (let ((index -1))
-		 #'(lambda (class)
-		     (incf index)
-		     `(define-storage-class ,(car class) ,index ,@(cdr class))))
-	       classes)))
-
-(define-storage-classes
-  ;; Objects that can be stored in any register (immediate objects)
-  (any-reg registers
-   :locations (2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 28 31))
-
-  ;; Objects that must be seen by GC (pointer objects)
-  (descriptor-reg registers
-   :locations (8 9 10 11 12 13 14 15 16 17 18 19 28 31))
-
-  ;; Objects that must not be seen by GC (unboxed objects)
-  (non-descriptor-reg registers
-   :locations (2 3 4 5 6 7))
-
-  ;; Pointers to the interior of objects.
-  (interior-reg registers
-   :locations (1))
-
-  ;; Unboxed base-characters
-  (base-character-reg registers
-   :locations (2 3 4 5 6 7))
-
-  ;; Unboxed SAP's (arbitrary pointers into address space)
-  (sap-reg registers
-   :locations (2 3 4 5 6 7))
-
-  ;; Stack for descriptor objects (scanned by GC)
-  (control-stack control-stack)
-
-  ;; Stack for non-descriptor objects (not scanned by GC)
-  (number-stack number-stack)
-
-  ;; Unboxed base-character stack
-  (base-character-stack number-stack)
-
-  ;; Unboxed SAP stack
-  (sap-stack number-stack)
-
-  ;; Non-immediate contstants in the constant pool
-  (constant constant)
-
-  ;; Immediate numeric constants.
-  ;; 
-  ;;   zero = (integer 0 0)
-  ;; 
-  ;;   negative-immediate = (integer #x-1FFF #-x0001)
-  ;;        The funny lower bound guarantees that the negation of an immediate
-  ;;        is still an immediate.
-  ;; 
-  ;;   immediate = (integer 0 #x1FFE)
-  ;;	   The funny upper bound guarantees that (1+ immediate) will fit in
-  ;;        16 bits.
-  ;; 
-  ;;   unsigned-immediate = (integer #x1FFF #x3FFE)
-  ;;	   The funny upper bound guarantees that (1+ immediate) will fit in
-  ;;        16 bits.
-  ;;
-  (zero immediate-constant)
-  (negative-immediate immediate-constant)
-  (immediate immediate-constant)
-  (unsigned-immediate immediate-constant)
-
-  ;; Immediate null/nil.
-  (null immediate-constant)
-
-  ;; Immediate unboxed base-characters.
-  (immediate-base-character immediate-constant)
-
-  ;; Immediate unboxed SAP's.
-  (immediate-sap immediate-constant)
-
-  ;; Objects that are easier to create using immediate loads than to fetch
-  ;; from the constant pool, but which aren't directly usable as immediate
-  ;; operands.  These are only recognized by move VOPs.
-  (random-immediate immediate-constant))
-
-
-;;;; Interfaces for stack sizes.
-
-(defun current-frame-size ()
-  (* word-bytes
-     (finite-sb-current-size
-      (sc-sb (svref *sc-numbers* (sc-number-or-lose 'control-stack))))))
-
-
-
-;;;; Move costs.
-
-;;; ### This needs work.
-
-;;;
-;;; Move costs for operand loading and storing
-(define-move-costs
-  ((any-reg descriptor-reg non-descriptor-reg)
-   (1 any-reg descriptor-reg non-descriptor-reg)
-   (2 base-character-reg sap-reg)
-   (5 control-stack number-stack))
-
-  ((control-stack number-stack constant)
-   (5 any-reg descriptor-reg non-descriptor-reg)
-   (6 base-character-reg sap-reg))
-
-  ((immediate zero null random-immediate)
-   (1 any-reg descriptor-reg non-descriptor-reg))
-
-  ((immediate-base-character)
-   (1 base-character-reg)
-   (2 any-reg descriptor-reg non-descriptor-reg))
-
-  ((immediate-sap)
-   (1 sap-reg)
-   (2 any-reg descriptor-reg non-descriptor-reg))
-
-  ((base-character-reg)
-   (1 base-character-reg)
-   (2 any-reg descriptor-reg non-descriptor-reg)
-   (5 base-character-stack)
-   (6 control-stack number-stack))
-
-  ((sap-reg)
-   (1 sap-reg)
-   (2 any-reg descriptor-reg non-descriptor-reg)
-   (5 sap-stack)
-   (6 control-stack number-stack))
-
-  ((base-character-stack)
-   (5 base-character-reg))
-
-  ((sap-stack)
-   (5 sap-reg)))
-
-;;;
-;;; SCs which must saved on a function call.
-(define-save-scs
-  (control-stack any-reg descriptor-reg)
-  (base-character-stack base-character-reg)
-  (sap-stack sap-reg))
-
-
-;;;; Primitive Type Definitions
-
-(def-primitive-type t (descriptor-reg control-stack))
-(defvar *any-primitive-type* (primitive-type-or-lose 't))
-
-;;; 
-(def-primitive-type fixnum (any-reg control-stack))
-
-(def-primitive-type base-character (base-character-reg any-reg
-						       base-character-stack
-						       control-stack))
-
-;;; 
-(def-primitive-type function (descriptor-reg control-stack))
-(def-primitive-type list (descriptor-reg control-stack))
-
-;;;
-(def-primitive-type bignum (descriptor-reg control-stack))
-(def-primitive-type ratio (descriptor-reg control-stack))
-(def-primitive-type complex (descriptor-reg control-stack))
-(def-primitive-type single-float (descriptor-reg control-stack))
-(def-primitive-type double-float (descriptor-reg control-stack))
-
-;;;
-(def-primitive-type simple-string (descriptor-reg control-stack))
-(def-primitive-type simple-bit-vector (descriptor-reg control-stack))
-(def-primitive-type simple-vector (descriptor-reg control-stack))
-(def-primitive-type simple-array-unsigned-byte-2 (descriptor-reg control-stack))
-(def-primitive-type simple-array-unsigned-byte-4 (descriptor-reg control-stack))
-(def-primitive-type simple-array-unsigned-byte-8 (descriptor-reg control-stack))
-(def-primitive-type simple-array-unsigned-byte-16 (descriptor-reg control-stack))
-(def-primitive-type simple-array-unsigned-byte-32 (descriptor-reg control-stack))
-(def-primitive-type simple-array-single-float (descriptor-reg control-stack))
-(def-primitive-type simple-array-double-float (descriptor-reg control-stack))
-
-(def-primitive-type sap (sap-reg sap-stack))
-
-(def-primitive-type random (non-descriptor-reg))
-(def-primitive-type interior (interior-reg))
-
-;;;
-#|
-(def-primitive complex-string (descriptor-reg control-stack))
-(def-primitive complex-bit-vector (descriptor-reg control-stack))
-(def-primitive complex-vector (descriptor-reg control-stack))
-|#
-
-
-;;;; Primitive-type-of and friends.
-
-;;; Primitive-Type-Of  --  Interface
-;;;
-;;;    Return the most restrictive primitive type that contains Object.
-;;;
-(defun primitive-type-of (object)
-  (let ((type (ctype-of object)))
-    (cond ((not (member-type-p type)) (primitive-type type))
-	  ((equal (member-type-members type) '(nil))
-	   (primitive-type-or-lose 'list))
-	  (t
-	   *any-primitive-type*))))
-
-;;; 
-(defvar *simple-array-primitive-types*
-  '((base-character . simple-string)
-    (bit . simple-bit-vector)
-    ((unsigned-byte 2) . simple-array-unsigned-byte-2)
-    ((unsigned-byte 4) . simple-array-unsigned-byte-4)
-    ((unsigned-byte 8) . simple-array-unsigned-byte-8)
-    ((unsigned-byte 16) . simple-array-unsigned-byte-16)
-    ((unsigned-byte 32) . simple-array-unsigned-byte-32)
-    (single-float . simple-array-single-float)
-    (double-float . simple-array-double-float)
-    (t . simple-vector))
-  "An a-list for mapping simple array element types to their
-  corresponding primitive types.")
-
-;;;
-;;; Return the primitive type corresponding to a type descriptor
-;;; structure. The second value is true when the primitive type is
-;;; exactly equivalent to the argument Lisp type.
-;;;
-;;; In a bootstrapping situation, we should be careful to use the
-;;; correct values for the system parameters.
-;;;
-(defun primitive-type (type)
-  (declare (type ctype type))
-  (etypecase type
-    (numeric-type
-     (if (not (eq (numeric-type-complexp type) :real))
-	 (values *any-primitive-type* nil)
-	 (case (numeric-type-class type)
-	   (integer
-	    (let ((lo (numeric-type-low type))
-		  (hi (numeric-type-high type)))
-	      (if (and hi lo
-		       (>= lo most-negative-fixnum)
-		       (<= hi most-positive-fixnum))
-		  (values (primitive-type-or-lose 'fixnum)
-			  (and (= lo most-negative-fixnum)
-			       (= hi most-positive-fixnum)))
-		  (values *any-primitive-type* nil))))
-	   (t
-	    (values *any-primitive-type* nil)))))
-    (array-type
-       (if (array-type-complexp type)
-	   (values *any-primitive-type* nil)
-	   (let* ((dims (array-type-dimensions type))
-		  (etype (array-type-specialized-element-type type))
-		  (type-spec (type-specifier etype))
-		  (ptype (cdr (assoc type-spec *simple-array-primitive-types*
-				     :test #'equal))))
-	     (if (and (consp dims) (null (rest dims)) ptype)
-		 (values (primitive-type-or-lose ptype) (eq (first dims) '*))
-		 (values *any-primitive-type* nil)))))
-    (union-type
-     (if (type= type (specifier-type 'list))
-	 (values (primitive-type-or-lose 'list) t)
-	 (let ((types (union-type-types type)))
-	   (multiple-value-bind (res exact)
-				(primitive-type (first types))
-	     (dolist (type (rest types))
-	       (multiple-value-bind (ptype ptype-exact)
-				    (primitive-type type)
-		 (unless ptype-exact (setq exact nil))
-		 (setq res (primitive-type-union res ptype))))
-	     (values res exact)))))
-    (member-type
-     (values (reduce #'primitive-type-union
-		     (mapcar #'primitive-type-of 
-			     (member-type-members type)))
-	     nil))
-    (named-type
-     (case (named-type-name type)
-       ((t bignum ratio complex function)
-	(values (primitive-type-or-lose (named-type-name type)) t))
-       (string-char
-	(values (primitive-type-or-lose 'base-character) t))
-       (standard-char
-	(values (primitive-type-or-lose 'base-character) nil))
-       (cons
-	(values (primitive-type-or-lose 'list) nil))
-       (t
-	(values *any-primitive-type* nil))))
-    (ctype
-     (values *any-primitive-type* nil))))
-
-
-;;;; Magical Registers
-
-(eval-when (compile eval load)
-  (defconstant zero-offset 0)
-  (defconstant null-offset 20)
-  (defconstant bsp-offset 21)
-  (defconstant cont-offset 22)
-  (defconstant csp-offset 23)
-  (defconstant flags-offset 24)
-  (defconstant alloc-offset 25)
-  (defconstant nsp-offset 29)
-  (defconstant code-offset 30))
-
-;;; 
-;;; Wired Zero
-(defparameter zero-tn
-  (make-random-tn :kind :normal
-		  :sc (sc-or-lose 'any-reg)
-		  :offset zero-offset))
-
-;;;
-;;; ``Wired'' NIL
-(defparameter null-tn
-  (make-random-tn :kind :normal
-		  :sc (sc-or-lose 'any-reg)
-		  :offset null-offset))
-
-;;; 
-;;; Binding stack pointer
-(defparameter bsp-tn
-  (make-random-tn :kind :normal
-		  :sc (sc-or-lose 'any-reg)
-		  :offset bsp-offset))
-
-;;;
-;;; Frame Pointer
-(defparameter cont-tn
-  (make-random-tn :kind :normal
-		  :sc (sc-or-lose 'any-reg)
-		  :offset cont-offset))
-
-;;; 
-;;; Control stack pointer
-(defparameter csp-tn
-  (make-random-tn :kind :normal
-		  :sc (sc-or-lose 'any-reg)
-		  :offset csp-offset))
-
-;;;
-;;; FLAGS magic register
-(defparameter flags-tn
-  (make-random-tn :kind :normal
-		  :sc (sc-or-lose 'any-reg)
-		  :offset flags-offset))
-
-;;; 
-;;; Allocation pointer
-(defparameter alloc-tn
-  (make-random-tn :kind :normal
-		  :sc (sc-or-lose 'any-reg)
-		  :offset alloc-offset))
-;;; 
-;;; Number stack pointer
-(defparameter nsp-tn
-  (make-random-tn :kind :normal
-		  :sc (sc-or-lose 'any-reg)
-		  :offset nsp-offset))
-
-;;; 
-;;; Code Pointer
-(defparameter code-tn
-  (make-random-tn :kind :normal
-		  :sc (sc-or-lose 'any-reg)
-		  :offset code-offset))
-
-;;;
-;;; Global Pointer (for C call-out)
-(defparameter gp-tn
-  (make-random-tn :kind :normal
-		  :sc (sc-or-lose 'any-reg)
-		  :offset 29))
-
-
-
-;;;; Side-Effect Classes
-
-(def-boolean-attribute vop
-  any)
-
-
-;;;; Constants
-
-;;;
-;;; Immediate-Constant-SC  --  Interface
-;;;
-;;; If value can be represented as an immediate constant, then return the
-;;; appropriate SC number, otherwise return NIL.
-;;;
-(defun immediate-constant-sc (value)
-  (typecase value
-    ((integer 0 0)
-     (sc-number-or-lose 'zero))
-    (null
-     (sc-number-or-lose 'null))
-    ((integer #x-1FFF #x-0001)
-     (sc-number-or-lose 'negative-immediate))
-    ((integer 0 #x1FFE)
-     (sc-number-or-lose 'immediate))
-    ((integer #x1FFF #x3FFE)
-     (sc-number-or-lose 'unsigned-immediate))
-    (symbol
-     (if (vm:static-symbol-p value)
-	 (sc-number-or-lose 'random-immediate)
-	 nil))
-    (fixnum
-     (sc-number-or-lose 'random-immediate))
-    ;; ### what here?
-    ;(sap
-    ; (sc-number-or-lose 'immediate-sap))
-    (t
-     ;;
-     ;; ### hack around bug in (typep x 'string-char)
-     (if (and (characterp value) (string-char-p value))
-	 (sc-number-or-lose 'immediate-base-character)
-	 nil))))
-
-
-;;;; Function Call Parameters
-
-;;; The SC numbers for register and stack arguments/return values.
-;;;
-(defconstant register-arg-scn (sc-number-or-lose 'descriptor-reg))
-(defconstant control-stack-arg-scn (sc-number-or-lose 'control-stack))
-
-(eval-when (compile load eval)
-
-;;; Offset of special registers used during calls
-;;;
-(defconstant nargs-offset 7)
-(defconstant cname-offset 14)
-(defconstant lexenv-offset 15)
-(defconstant args-offset 16)
-(defconstant oldcont-offset 17)
-(defconstant lra-offset 18)
-
-;;; Offsets of special stack frame locations
-(defconstant oldcont-save-offset 0)
-(defconstant lra-save-offset 1)
-(defconstant lexenv-save-offset 2)
-
-); Eval-When (Compile Load Eval)  
-
-
-(defparameter nargs-tn
-  (make-random-tn :kind :normal
-		  :sc (sc-or-lose 'any-reg)
-		  :offset nargs-offset))
-
-(defparameter args-tn
-  (make-random-tn :kind :normal
-		  :sc (sc-or-lose 'descriptor-reg)
-		  :offset args-offset))
-
-(defparameter lra-tn
-  (make-random-tn :kind :normal
-		  :sc (sc-or-lose 'any-reg)
-		  :offset lra-offset))
-
-
-(eval-when (compile load eval)
-
-;;; The number of arguments/return values passed in registers.
-;;;
-(defconstant register-arg-count 6)
-
-;;; The offsets within the register-arg SC that we pass values in, first
-;;; value first.
-;;;
-(defconstant register-arg-offsets '(8 9 10 11 12 13))
-
-;;; Names to use for the argument registers.
-;;; 
-(defconstant register-arg-names '(a0 a1 a2 a3 a4 a5))
-
-); Eval-When (Compile Load Eval)
-
-
-;;; A list of TN's describing the register arguments.
-;;;
-(defparameter register-arg-tns
-  (mapcar #'(lambda (n)
-	      (make-random-tn :kind :normal
-			      :sc (sc-or-lose 'descriptor-reg)
-			      :offset n))
-	  register-arg-offsets))
diff --git a/compiler/node.lisp b/compiler/node.lisp
deleted file mode 100644
index 888fc9dd64644fef37661668d59ffa354e4674f4..0000000000000000000000000000000000000000
--- a/compiler/node.lisp
+++ /dev/null
@@ -1,1148 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    Structures for the first intermediate representation in the compiler,
-;;; IR1.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-;;; Defvars for these variables appear later.
-(proclaim '(special *current-cookie* *default-cookie* *current-path*
-		    *current-cleanup* *current-lambda* *current-component*
-		    *fenv* *venv* *benv* *tenv*))
-
-
-;;; The front-end data structure (IR1) is composed of nodes and continuations.
-;;; The general idea is that continuations contain top-down information and
-;;; nodes contain bottom-up, derived information.  A continuation represents a
-;;; place in the code, while a node represents code that does something.
-;;;
-;;; This representation is more of a flow-graph than an augmented syntax tree.
-;;; The evaluation order is explicitly represented in the linkage by
-;;; continuations, rather than being implicit in the nodes which receive the
-;;; the results of evaluation.  This allows us to decouple the flow of results
-;;; from the flow of control.  A continuation represents both, but the
-;;; continuation can represent the case of a discarded result by having no
-;;; DEST. 
-
-(defstruct (continuation (:print-function %print-continuation)
-			 (:constructor make-continuation (&optional dest)))
-  ;;
-  ;; An indication of the way that this continuation is currently used:
-  ;;
-  ;; :Unused
-  ;;        A continuation for which all control-related slots have the default
-  ;;        values.  A continuation is unused during IR1 conversion until it is
-  ;;        assigned a block, and may be also be temporarily unused during
-  ;;        later manipulations of IR1.  In a consistent state there should
-  ;;        never be any mention of :Unused continuations.  Next can have a
-  ;;        non-null value if the next node has already been determined.
-  ;;
-  ;; :Deleted
-  ;;        A continuation that has been deleted from IR1.  Any pointers into
-  ;;        IR1 are cleared.  There are two conditions under which a deleted
-  ;;        continuation may appear in code:
-  ;;         -- The Cont of the Last node in a block may be a deleted
-  ;;            continuation when the original receiver of the continuation's
-  ;;            value was deleted.  Note that Dest in a deleted continuation is
-  ;;            null, so it is easy to know not to attempt delivering any
-  ;;            values to the continuation.
-  ;;         -- Unreachable code that hasn't been deleted yet may receive
-  ;;            deleted continuations.  All such code will be in blocks that
-  ;;            have DELETE-P set.  All unreachable code is deleted by control
-  ;;            optimization, so the backend doesn't have to worry about this.
-  ;;
-  ;; :Block-Start
-  ;;        The continuation that is the Start of Block.  This is the only kind
-  ;;        of continuation that can have more than one use.  The Block's
-  ;;        Start-Uses is a list of all the uses.
-  ;;
-  ;; :Deleted-Block-Start
-  ;;        Like :Block-Start, but Block has been deleted.  A block starting
-  ;;        continuation is made into a deleted block start when the block is
-  ;;        deleted, but the continuation still may have value semantics.
-  ;;        Since there isn't any code left, next is null.
-  ;;
-  ;; :Inside-Block
-  ;;        A continuation that is the Cont of some node in Block.
-  ;;
-  (kind :unused :type (member :unused :deleted :inside-block :block-start
-			      :deleted-block-start))
-  ;;
-  ;; The node which receives this value, if any.  In a deleted continuation,
-  ;; this is null even though the node that receives this continuation may not
-  ;; yet be deleted.
-  (dest nil :type (or node null))
-  ;;
-  ;; If this is a Node, then it is the node which is to be evaluated next.
-  ;; This is always null in :Deleted and :Unused continuations, and will be
-  ;; null in a :Inside-Block continuation when this is the CONT of the LAST.
-  (next nil :type (or node null))
-  ;;
-  ;; An assertion on the type of this continuation's value.
-  (asserted-type *wild-type* :type ctype)
-  ;;
-  ;; Cached type of this contiuation's value.  If NIL, then this must be
-  ;; recomputed: see Continuation-Derived-Type.
-  (%derived-type nil :type (or ctype null))
-  ;;
-  ;; Node where this continuation is used, if unique.  This is always null in
-  ;; :Deleted and :Unused continuations, and is never null in :Inside-Block
-  ;; continuations.  In a :Block-Start contiuation, the Block's Start-Uses
-  ;; indicate whether NIL means no uses or more than one use.
-  (use nil :type (or node null))
-  ;;
-  ;; Basic block this continuation is in.  This is null only in :Deleted and
-  ;; :Unused continuations.  Note that blocks that are unreachable but still in
-  ;; the DFO may receive deleted continuations, so it isn't o.k. to assume that
-  ;; any random continuation that you pick up out of its Dest node has a Block.
-  (block nil :type (or cblock null))
-  ;;
-  ;; Set to true when something about this continuation's value has changed.
-  ;; See Reoptimize-Continuation.  This provides a way for IR1 optimize to
-  ;; determine which operands to a node have changed.  If the optimizer for
-  ;; this node type doesn't care, it can elect not to clear this flag.
-  (reoptimize t :type boolean)
-  ;;
-  ;; An indication of what we have proven about how this contination's type
-  ;; assertion is satisfied:
-  ;; 
-  ;; NIL
-  ;;    No type check is necessary (proven type is a subtype of the assertion.)
-  ;;
-  ;; T
-  ;;    A type check is needed.
-  ;;
-  ;; :DELETED
-  ;;    Don't do a type check, but believe (intersect) the assertion.  A T
-  ;;    check can be changed to :DELETED if we somehow prove the check is
-  ;;    unnecessary, or if we eliminate it through a policy decision.
-  ;;
-  ;; :NO-CHECK
-  ;;    Type check generation sets the slot to this if a check is called for,
-  ;;    but it believes it has proven that the check won't be done for
-  ;;    policy reasons or because a safe implementation will be used.  In the
-  ;;    latter case, LTN must ensure that a safe implementation *is* be used.
-  ;;
-  ;; :ERROR
-  ;;    There is a compile-time type error in some use of this continuation.  A
-  ;;    type check should still be generated, but be careful.
-  ;;
-  ;; This is computed lazily by CONTINUATION-DERIVED-TYPE, so use
-  ;; CONTINUATION-TYPE-CHECK instead of the %'ed slot accessor.
-  ;;
-  (%type-check t :type (member t nil :deleted :no-check :error))
-  ;;
-  ;; Something or other that the back end annotates this continuation with.
-  (info nil))
-
-(defun %print-continuation (s stream d)
-  (declare (ignore d))
-  (format stream "#<Continuation c~D>" (cont-num s)))
-
-
-(defstruct node
-  ;;
-  ;; The bottom-up derived type for this node.  This does not take into
-  ;; consideration output type assertions on this node (actually on its CONT).
-  (derived-type *wild-type* :type ctype)
-  ;;
-  ;; True if this node needs to be optimized.  This is set to true whenever
-  ;; something changes about the value of a continuation whose DEST is this
-  ;; node.
-  (reoptimize t :type boolean)
-  ;;
-  ;; The continuation which receives the value of this node.  This also
-  ;; indicates what we do controlwise after evaluating this node.  This may be
-  ;; null during IR1 conversion.
-  (cont nil :type (or continuation null))
-  ;; 
-  ;; The continuation that this node is the next of.  This is null during
-  ;; IR1 conversion when we haven't linked the node in yet or in nodes that
-  ;; have been deleted from the IR1 by UNLINK-NODE.
-  (prev nil :type (or continuation null))
-  ;;
-  ;; The Cookie holds various rarely-changed information about how a node
-  ;; should be compiled.  Currently it only holds the values of the Optimize
-  ;; settings.  Values for things which have not been specified locally are
-  ;; null.  The real value is then found in the Default-Cookie.  The
-  ;; Default-Cookie must also be kept in the node since it changes when
-  ;; we run into a Proclaim duing IR1 conversion.
-  (cookie *current-cookie* :type cookie :read-only t)
-  (default-cookie *default-cookie* :type cookie :read-only t)
-  ;;
-  ;; Source code for this node.  This is used to provide context in messages to
-  ;; the user, since it may be hard to reconstruct the source from the internal
-  ;; representation.
-  (source nil :type t :read-only t)
-  ;;
-  ;; A representation of the location in the original source of the form
-  ;; responsible for generating this node.  The first element in this list is
-  ;; the "form number", which is the ordinal number of this form in a
-  ;; depth-first, left-to-right walk of the truly top-level form in which this
-  ;; appears.
-  ;;
-  ;; Following is a list of integers describing the path taken through the
-  ;; source to get to this point:
-  ;;     (k l m ...) => (nth k (nth l (nth m ...)))
-  ;; 
-  ;; This path is through the original top-level form compiled, and in general
-  ;; has nothing to do with the Source slot.  This path is our best guess for
-  ;; where the code came from, and may be not be very helpful in the case of
-  ;; code resulting from macroexpansion.  The last element in the list is the
-  ;; top-level form number, which is the ordinal number (in this call to the
-  ;; compiler) of the truly top-level form containing the orignal source
-  (source-path *current-path* :type list :read-only t)
-  ;;
-  ;; If this node is in a tail-recursive position, then this is set to the
-  ;; corresponding Tail-Set.  This is first computed at the end of IR1 (after
-  ;; cleanup code has been emitted).  If the back-end breaks tail-recursion for
-  ;; some reason, then it can null out this slot.
-  (tail-p nil :type (or tail-set null)))
-
-
-
-;;; The CBlock structure represents a basic block.  We include SSet-Element so
-;;; that we can have sets of blocks.  Initially the SSet-Element-Number is
-;;; null, but we number in reverse DFO before we do any set operations.
-;;;
-(defstruct (cblock (:print-function %print-block)
-		   (:include sset-element)
-		   (:constructor make-block (start))
-		   (:constructor make-block-key)
-		   (:conc-name block-)
-		   (:predicate block-p)
-		   (:copier copy-block))
-  ;;
-  ;; A list of all the blocks that are predecessors/successors of this block.
-  ;; In well-formed IR1, most blocks will have one or two successors.  The only
-  ;; exceptions are component head blocks and block with DELETE-P set.
-  (pred nil :type list)
-  (succ nil :type list)
-  ;;
-  ;; The continuation which heads this block (either a :Block-Start or
-  ;; :Deleted-Block-Start.)  Null when we haven't made the start continuation
-  ;; yet.
-  (start nil :type (or continuation null))
-  ;;
-  ;; A list of all the nodes that have Start as their Cont.
-  (start-uses nil :type list)
-  ;;
-  ;; The last node in this block.  This is null when we are in the process of
-  ;; building a block.
-  (last nil :type (or node null))
-  ;;
-  ;; The Lambda that this code is syntactically within, for environment
-  ;; analysis.  This may be null during IR1 conversion.  This is also null in
-  ;; the dummy head and tail blocks for a component.
-  (lambda *current-lambda* :type (or clambda null))
-  ;;
-  ;; The cleanups in effect at the beginning and after the end of this block.
-  ;; If there is no cleanup in effect within the enclosing lambda, then the
-  ;; value is the enclosing lambda.  The Lambda-Cleanup must be examined to
-  ;; determine whether later let-substitution has added an enclosing dynamic
-  ;; binding in the same environment.  Cleanup generation uses this information
-  ;; to determine if code needs to be emitted to undo dynamic bindings.
-  ;; Null in the dummy component head and tail.
-  (start-cleanup *current-cleanup* :type (or cleanup clambda null))
-  (end-cleanup *current-cleanup* :type (or cleanup clambda null))
-  ;;
-  ;; The forward and backward links in the depth-first ordering of the blocks.
-  ;; These slots are null at beginning/end.
-  (next nil :type (or null cblock))
-  (prev nil :type (or null cblock))
-  ;;
-  ;; Flags that are used to indicate that various IR1 optimization phases
-  ;; should be done on code in this block:
-  ;; -- REOPTIMIZE is set when something interesting happens the uses of a
-  ;;    continuation whose Dest is in this block.  This indicates that the
-  ;;    value-driven (forward) IR1 optimizations should be done on this block.
-  ;; -- FLUSH-P is set when code in this block becomes potentially flushable,
-  ;;    usually due to a continuation's DEST becoming null.
-  ;; -- TYPE-CHECK is true when the type check phase should be run on this
-  ;;    block.  IR1 optimize can introduce new blocks after type check has
-  ;;    already run.  We need to check these blocks, but there is no point in
-  ;;    checking blocks we have already checked.
-  ;; -- DELETE-P is true when this block is used to indicate that this block
-  ;;    has been determined to be unreachable and should be deleted.  IR1
-  ;;    phases should not attempt to  examine or modify blocks with DELETE-P
-  ;;    set, since they may:
-  ;;     - be in the process of being deleted, or
-  ;;     - have no successors, or
-  ;;     - receive :DELETED continuations.
-  ;; -- TYPE-ASSERTED, TEST-MODIFIED
-  ;;    These flags are used to indicate that something in this block might be
-  ;;    of interest to constraint propagation.  TYPE-ASSERTED is set when a
-  ;;    continuation type assertion is strengthened.  TEST-MODIFIED is set
-  ;;    whenever the test for the ending IF has changed (may be true when there 
-  ;;    is no IF.)
-  ;;
-  (reoptimize t :type boolean)
-  (flush-p t :type boolean)
-  (type-check t :type boolean)
-  (delete-p nil :type boolean)
-  (type-asserted t :type boolean)
-  (test-modified t :type boolean)
-  ;;
-  ;; Some sets used by constraint propagation.
-  (kill nil)
-  (gen nil)
-  (in nil)
-  (out nil)
-  ;;
-  ;; The component this block is in.  Null temporarily during IR1 conversion
-  ;; and in deleted blocks.
-  (component *current-component* :type (or component null))
-  ;;
-  ;; A flag used by various graph-walking code to determine whether this block
-  ;; has been processed already or what.  We make this initially NIL so that
-  ;; Find-Initial-DFO doesn't have to scan the entire initial component just to
-  ;; clear the flags.
-  (flag nil)
-  ;;
-  ;; Some kind of info used by the back end.
-  (info nil))
-
-(defun %print-block (s stream d)
-  (declare (ignore d))
-  (format stream "#<Block ~X, Start = c~D>" (system:%primitive make-fixnum s)
-	  (cont-num (block-start s))))
-
-
-;;; The Component structure provides a handle on a connected piece of the flow
-;;; graph.  Most of the passes in the compiler operate on components rather
-;;; than on the entire flow graph.
-;;;
-(defstruct (component (:print-function %print-component))
-  ;;
-  ;; The kind of component:
-  ;; 
-  ;; NIL
-  ;;     An ordinary component, containing arbitrary code.
-  ;;
-  ;; :Top-Level
-  ;;     A component containing only load-time code.
-  ;;
-  ;; :Initial
-  ;;     The result of initial IR1 conversion, on which component analysis has
-  ;;     not been done.
-  ;;
-  (kind nil :type (member nil :top-level :initial))
-  ;;
-  ;; The blocks that are the dummy head and tail of the DFO.  Entry/exit points
-  ;; have these blocks as their predecessors/successors.  Null temporarily.
-  ;; The start and return from each non-deleted function is linked to the
-  ;; component head and tail.  Until environment analysis links NLX entry stubs
-  ;; to the component head, every successor of the head is a function start
-  ;; (i.e. begins with a Bind node.)
-  (head nil :type (or null cblock))
-  (tail nil :type (or null cblock))
-  ;;
-  ;; A list of the CLambda structures for all functions in this component.
-  ;; Optional-Dispatches are represented only by their XEP and other associated
-  ;; lambdas.  This doesn't contain any deleted or let lambdas.
-  (lambdas () :type list)
-  ;;
-  ;; A list of Functional structures for functions that are newly converted,
-  ;; and haven't been local-call analyzed yet.  Unanalyzed functions aren't in
-  ;; the Lambdas list.  Functions are moved into the Lambdas as they are
-  ;; analysed.
-  (new-functions () :type list)
-  ;;
-  ;; If true, then there is stuff in this component that could benefit from
-  ;; further IR1 optimization.
-  (reoptimize t :type boolean)
-  ;;
-  ;; If true, then the control flow in this component was messed up by IR1
-  ;; optimizations.  The DFO should be recomputed.
-  (reanalyze nil :type boolean)
-  ;;
-  ;; String that is some sort of name for the code in this component.
-  (name "<unknown>" :type simple-string)
-  ;;
-  ;; Some kind of info used by the back end.
-  (info nil))
-
-
-(defprinter component
-  name
-  (reanalyze :test reanalyze))
-  
-
-;;; The Cleanup structure represents some dynamic binding action.  Blocks are
-;;; annotated with the current cleanup so that dynamic bindings can be removed
-;;; when control is transferred out of the binding environment.  We arrange for
-;;; changes in dynamic bindings to happen at block boundaries, so that cleanup
-;;; code may easily be inserted.  The "mess-up" action is explictly represented
-;;; by a funny function call or Entry node.
-;;;
-;;; We guarantee that cleanups only need to be done at block boundries by
-;;; requiring that the exit continuations initially head their blocks, and then
-;;; by not merging blocks when there is a cleanup change.
-;;;
-(defstruct (cleanup (:print-function %print-cleanup))
-  ;;
-  ;; The kind of thing that has to be cleaned up.  :Entry marks the dynamic
-  ;; extent of a lexical exit (TAGBODY or BLOCK).
-  (kind nil :type (member :special-bind :catch :unwind-protect :entry))
-  ;;
-  ;; The first messed-up continuation.  This is Use'd by the node that is the
-  ;; mess-up.  Null only temporarily.  This could be deleted if the mess-up was
-  ;; deleted.  Note that the cleanup "belongs" to the block holding the
-  ;; mess-up, rather than the start continuation's block.
-  (start nil :type (or continuation null))
-  ;;
-  ;; The syntactically enclosing cleanup.  If there is no enclosing cleanup in
-  ;; our lambda, then this is the lambda.  A :Catch or :Unwind-Protect cleanup
-  ;; is always enclosed by the :Entry cleanup for the escape block.
-  (enclosing *current-cleanup* :type (or cleanup clambda))
-  ;;
-  ;; A list of all the NLX-Info structures whose NLX-Info-Cleanup is this
-  ;; cleanup.  This is filled in by environment analysis.
-  (nlx-info nil :type list))
-
-(defprinter cleanup
-  kind
-  (start :prin1 (continuation-use start))
-  (nlx-info :test nlx-info))
-
-
-;;; The Environment structure represents the result of Environment analysis.
-;;;
-(defstruct (environment (:print-function %print-environment))
-  ;;
-  ;; The function that allocates this environment.
-  (function nil :type clambda)
-  ;;
-  ;; A list of all the Lambdas that allocate variables in this environment.
-  (lambdas nil :type list)
-  ;;
-  ;; A list of all the lambda-vars and NLX-Infos needed from enclosing
-  ;; environments by code in this environment.
-  (closure nil :type list)
-  ;;
-  ;; A list of NLX-Info structures describing all the non-local exits into this
-  ;; environment.
-  (nlx-info nil :type list)
-  ;;
-  ;; Some kind of info used by the back end.
-  (info nil))
-
-(defprinter environment
-  function
-  (closure :test closure)
-  (nlx-info :test nlx-info))
-
-
-;;; The Tail-Set structure is used to accmumlate information about
-;;; tail-recursive local calls.  The "tail set" is effectively the transitive
-;;; closure of the "is called tail-recursively by" relation.
-;;;
-;;; All functions in the same tail set share the same Tail-Set structure.
-;;; Initially each function has its own Tail-Set, but converting a TR local
-;;; call joins the tail sets of the called function and the calling function.
-;;; When computing the tail set, we consider a call to be TR when it delivers
-;;; its value to a return node; there may be an implicit MV-Prog1, and the
-;;; use of the result continuation might even turn out to be a non-local exit.
-;;;
-;;; This is the most useful interpretation for type inference.  Anyway, local
-;;; call analysis happens too early to determine which calls are truly TR.
-;;;
-(defstruct (tail-set
-	    (:print-function %print-tail-set))
-  ;;
-  ;; A list of all the lambdas in this tail set.
-  (functions nil :type list)
-  ;;
-  ;; Our current best guess of the type returned by these functions.  This is
-  ;; the union across all the functions of the return node's Result-Type.
-  ;; excluding local calls.
-  (type *wild-type* :type ctype)
-  ;;
-  ;; Some info used by the back end.
-  (info nil))
-
-(defprinter tail-set
-  functions
-  type
-  (info :test info))
-
-
-;;; The NLX-Info structure is used to collect various information about
-;;; non-local exits.  This is effectively an annotation on the Continuation,
-;;; although it is accessed by searching in the Environment-Nlx-Info.
-;;;
-(defstruct (nlx-info (:print-function %print-nlx-info))
-  ;;
-  ;; The cleanup associated with this exit.  In a catch or unwind-protect, this
-  ;; is the :Catch or :Unwind-Protect cleanup, and not the cleanup for the
-  ;; escape block.  The Cleanup-Kind of this thus provides a good indication of
-  ;; what kind of exit is being done.
-  (cleanup nil :type cleanup)
-  ;;
-  ;; The continuation exited to (the CONT of the EXIT nodes.)  This is
-  ;; primarily an indication of where this exit delivers its values to (if
-  ;; any), but it is also used as a sort of name to allow us to find the
-  ;; NLX-Info that corresponds to a given exit.  For this purpose, the Entry
-  ;; must also be used to disambiguate, since exits to different places may
-  ;; deliver their result to the same continuation.
-  (continuation nil :type continuation)
-  ;;
-  ;; The entry stub inserted by environment analysis.  This is a block
-  ;; containing a call to the %NLX-Entry funny function that has the original
-  ;; exit destination as its successor.  Null only temporarily.
-  (target nil :type (or cblock null))
-  ;;
-  ;; Some kind of info used by the back end.
-  info)
-
-(defprinter nlx-info
-  continuation
-  target
-  info)
-
-
-;;; Leaves:
-;;;
-;;;    Variables, constants and functions are all represented by Leaf
-;;; structures.  A reference to a Leaf is indicated by a Ref node.  This allows
-;;; us to easily substitute one for the other without actually hacking the flow
-;;; graph.
-
-(defstruct leaf
-  ;;
-  ;; Some name for this leaf.  The exact significance of the name depends on
-  ;; what kind of leaf it is.  In a Lambda-Var or Global-Var, this is the
-  ;; symbol name of the variable.  In a functional that is from a DEFUN, this
-  ;; is the defined name.  In other functionals, this is a descriptive string.
-  (name nil :type t)
-  ;;
-  ;; The type which values of this leaf must have.
-  (type *universal-type* :type ctype)
-  ;;
-  ;; Where the Type information came from:
-  ;;  :declared, from a declaration.
-  ;;  :assumed, from uses of the object.
-  ;;  :defined, from examination of the definition.
-  (where-from :assumed :type (member :declared :assumed :defined))
-  ;;
-  ;; List of the Ref nodes for this leaf.
-  (refs () :type list)
-  ;;
-  ;; True if there was ever a Ref or Set node for this leaf.  This may be true
-  ;; when Refs and Sets are null, since code can be deleted.
-  (ever-used nil :type boolean)
-  ;;
-  ;; Some kind of info used by the back end.
-  (info nil))
-
-
-;;; The Constant structure is used to represent known constant values.  If Name
-;;; is not null, then it is the name of the named constant which this leaf
-;;; corresponds to, otherwise this is an anonymous constant.
-;;;
-(defstruct (constant (:include leaf)
-		     (:print-function %print-constant))
-  ;;
-  ;; The value of the constant.
-  (value nil :type t))
-
-(defprinter constant
-  (name :test name)
-  value)
-
-  
-;;; The Basic-Var structure represents information common to all variables
-;;; which don't correspond to known local functions.
-;;;
-(defstruct (basic-var (:include leaf))
-  ;;
-  ;; Lists of the set nodes for this variable.
-  (sets () :type list))
-
-
-;;; The Global-Var structure represents a value hung off of the symbol Name.
-;;; We use a :Constant Var when we know that the thing is a constant, but don't
-;;; know what the value is at compile time.
-;;;
-(defstruct (global-var (:include basic-var)
-		       (:print-function %print-global-var))
-  ;;
-  ;; Kind of variable described.
-  (kind nil :type (member :special :global-function :constant :global)))
-
-(defprinter global-var
-  name
-  (type :test (not (eq type *universal-type*)))
-  (where-from :test (not (eq where-from :assumed)))
-  kind)
-
-
-;;; The Slot-Accessor structure represents defstruct slot accessors.  It is a
-;;; subtype of Global-Var to make it look more like a normal function.
-;;;
-(defstruct (slot-accessor (:include global-var
-				    (where-from :defined)
-				    (kind :global-function))
-			  (:print-function %print-slot-accessor))
-  ;;
-  ;; The description of the structure that this is an accessor for.
-  (for nil :type defstruct-description)
-  ;;
-  ;; The slot description of the slot.
-  (slot nil :type defstruct-slot-description))
-
-(defprinter slot-accessor
-  name
-  for
-  slot)
-
-
-
-;;;; Function stuff:
-
-
-;;; We default the Where-From and Type slots to :Defined and Function.  We
-;;; don't normally manipulate function types for defined functions, but if
-;;; someone wants to know, an approximation is there.
-;;;
-(defstruct (functional (:include leaf
-			 (:where-from :defined)
-			 (:type (specifier-type 'function))))
-  ;;
-  ;; Some information about how this function is used.  These values are
-  ;; meaningful:
-  ;;
-  ;;    Nil
-  ;;        An ordinary function, callable using local call.
-  ;;
-  ;;    :Let
-  ;;        A lambda that is used in only one local call, and has in effect
-  ;;        been substituted directly inline.  The return node is deleted, and
-  ;;        the result is computed with the actual result continuation for the
-  ;;        call.
-  ;;
-  ;;    :MV-Let
-  ;;        Similar to :Let, but the call is an MV-Call.
-  ;;
-  ;;    :Optional
-  ;;        A lambda that is an entry-point for an optional-dispatch.  Similar
-  ;;        to NIL, but requires greater caution, since local call analysis may
-  ;;        create new references to this function.  Also, the function cannot
-  ;;        be deleted even if it has *no* references.  The Optional-Dispatch
-  ;;        is in the LAMDBA-OPTIONAL-DISPATCH.
-  ;;
-  ;;    :External
-  ;;        An external entry point lambda.  The function it is an entry for is
-  ;;        in the Entry-Function.
-  ;;
-  ;;    :Top-Level
-  ;;        A top-level lambda, holding a compiled top-level form.  Compiled
-  ;;        very much like NIL, but provides an indication of top-level
-  ;;        context.  A top-level lambda should have *no* references.  Its
-  ;;        Entry-Function is a self-pointer.
-  ;;
-  ;;    :Escape
-  ;;    :Cleanup
-  ;;        Special functions used internally by Catch and Unwind-Protect.
-  ;;        These are pretty much like a normal function (NIL), but are treated
-  ;;        specially by local call analysis and stuff.  Neither kind should
-  ;;        ever be given an XEP even though they appear as args to funny
-  ;;        functions.  An :Escape function is never actually called, and thus
-  ;;        doesn't need to have code generated for it.
-  ;;
-  ;;    :Deleted
-  ;;        This function has been found to be uncallable, and has been
-  ;;        marked for deletion.
-  ;;
-  (kind nil :type (member nil :optional :deleted :external :top-level :escape
-			  :cleanup :let :mv-let))
-  ;;
-  ;; In a normal function, this is the external entry point (XEP) lambda for
-  ;; this function, if any.  Each function that is used other than in a local
-  ;; call has an XEP, and all of the non-local-call references are replaced
-  ;; with references to the XEP.
-  ;;
-  ;; In an XEP lambda (indicated by the :External kind), this is the function
-  ;; that the XEP is an entry-point for.  The body contains local calls to all
-  ;; the actual entry points in the function.  In a :Top-Level lambda (which is
-  ;; its own XEP) this is a self-pointer.
-  ;;
-  ;; With all other kinds, this is null.
-  (entry-function nil :type (or functional null))
-  ;;
-  ;; If we have a lambda that can be used as in inline expansion for this
-  ;; function, then this is it.  If there is no source-level lambda
-  ;; corresponding to this function then this is Null.
-  (inline-expansion nil :type list)
-  ;;
-  ;; The original function or macro lambda list, or :UNSPECIFIED if this is a
-  ;; compiler created function.
-  (arg-documentation nil :type (or list (member :unspecified)))
-  ;;
-  ;; The environment values that we use if we reconvert the Inline-Expansion.
-  (fenv *fenv*)
-  (venv *venv*)
-  (benv *benv*)
-  (tenv *tenv*))
-
-
-;;; The Lambda only deals with required lexical arguments.  Special, optional,
-;;; keyword and rest arguments are handled by transforming into simpler stuff.
-;;;
-(defstruct (clambda (:include functional)
-		    (:print-function %print-lambda)
-		    (:conc-name lambda-)
-		    (:predicate lambda-p)
-		    (:constructor make-lambda)
-		    (:copier copy-lambda))
-  ;;
-  ;; List of lambda-var descriptors for args.
-  (vars nil :type list)
-  ;;
-  ;; If this function was ever a :OPTIONAL function (an entry-point for an
-  ;; optional-dispatch), then this is that optional-dispatch.  The optional
-  ;; dispatch will be :DELETED if this function is no longer :OPTIONAL.
-  (optional-dispatch nil :type (or optional-dispatch null))
-  ;;
-  ;; The Bind node for this Lambda.  This node marks the beginning of the
-  ;; lambda, and serves to explicitly represent the lambda binding semantics
-  ;; within the flow graph representation.
-  (bind nil :type bind)
-  ;;
-  ;; The Return node for this Lambda, or NIL if it has been deleted.  This
-  ;; marks the end of the lambda, receiving the result of the body.  In a let,
-  ;; the return node is deleted, and the body delivers the value to the actual
-  ;; continuation.  The return may also be deleted if it is unreachable.
-  (return nil :type (or creturn null))
-  ;;
-  ;; If this is a let, then the Lambda whose Lets list we are in, otherwise
-  ;; this is a self-pointer.
-  (home nil :type (or clambda null))
-  ;;
-  ;; A list of all the all the lambdas that have been let-substituted in this
-  ;; lambda.  This is only non-null in lambdas that aren't lets.
-  (lets () :type list)
-  ;;
-  ;; A list of all the Entry nodes in this function and its lets.  Null an a
-  ;; let.
-  (entries () :type list)
-  ;;
-  ;; If true, then this is the innermost cleanup that dynamically encloses the
-  ;; call to this function.  If false, then there is no such cleanup.  This is
-  ;; never true if the lambda isn't a let, since in other cases the function
-  ;; will have its own environment, and the non-local exit mechanism will deal
-  ;; with cleanups.
-  (cleanup nil :type (or cleanup null))
-  ;;
-  ;; A list of all the functions directly called from this function (or one of
-  ;; its lets) using a non-let local call.
-  (calls () :type list)
-  ;;
-  ;; The Tail-Set that this lambda is in.  Null when Return is null.
-  (tail-set nil :type (or tail-set null))
-  ;;
-  ;; The structure which represents the environment that this Function's
-  ;; variables are allocated in.  This is filled in by environment analysis.
-  ;; In a let, this is EQ to our home's environment.
-  (environment nil :type (or environment null)))
-
-
-(defprinter lambda
-  name
-  (type :test (not (eq type *universal-type*)))
-  (where-from :test (not (eq where-from :assumed)))
-  (vars :prin1 (mapcar #'leaf-name vars)))
-
-
-;;; The Optional-Dispatch leaf is used to represent hairy lambdas.  If is a
-;;; Functional, like Lambda.  Each legal number of arguments has a function
-;;; which is called when that number of arguments is passed.  The function is
-;;; called with all the arguments actually passed.  If additional arguments are
-;;; legal, then the LEXPR style More-Entry handles them.  The value returned by
-;;; the function is the value which results from calling the Optional-Dispatch.
-;;;
-;;; The theory is that each entry-point function calls the next entry
-;;; point tail-recursively, passing all the arguments passed in and the default
-;;; for the argument the entry point is for.  The last entry point calls the
-;;; real body of the function.  In the presence of supplied-p args and other
-;;; hair, things are more complicated.  In general, there is a distinct
-;;; internal function that takes the supplied-p args as parameters.  The
-;;; preceding entry point calls this function with NIL filled in for the
-;;; supplied-p args, while the current entry point calls it with T in the
-;;; supplied-p positions.
-;;;
-;;; Note that it is easy to turn a call with a known number of arguments into a
-;;; direct call to the appropriate entry-point function, so functions that are
-;;; compiled together can avoid doing the dispatch.
-;;;
-(defstruct (optional-dispatch (:include functional)
-			      (:print-function %print-optional-dispatch))
-  ;;
-  ;; The original parsed argument list, for anyone who cares.
-  (arglist nil :type list)
-  ;;
-  ;; True if &allow-other-keys was supplied.
-  (allowp nil :type boolean)
-  ;;
-  ;; True if &key was specified.  (Doesn't necessarily mean that there are any
-  ;; keyword arguments...)
-  (keyp nil :type boolean)
-  ;;
-  ;; The number of required arguments.  This is the smallest legal number of
-  ;; arguments.
-  (min-args 0 :type unsigned-byte)
-  ;;
-  ;; The total number of required and optional arguments.  Args at positions >=
-  ;; to this are rest, key or illegal args.
-  (max-args 0 :type unsigned-byte)
-  ;;
-  ;; List of the Lambdas which are the entry points for non-rest, non-key
-  ;; calls.  The entry for Min-Args is first, Min-Args+1 second, ... Max-Args
-  ;; last.  The last entry-point always calls the main entry; in simple cases
-  ;; it may be the main entry.
-  (entry-points nil :type list)
-  ;;
-  ;; An entry point which takes Max-Args fixed arguments followed by an
-  ;; argument context pointer and an argument count.  This entry point deals
-  ;; with listifying rest args and parsing keywords.  This is null when extra
-  ;; arguments aren't legal.  
-  (more-entry nil :type (or clambda null))
-  ;;
-  ;; The main entry-point into the function, which takes all arguments
-  ;; including keywords as fixed arguments.  The format of the arguments must
-  ;; be determined by examining the arglist.  This may be used by callers that
-  ;; supply at least Max-Args arguments and know what they are doing.
-  (main-entry nil :type (or clambda null)))
-
-
-(defprinter optional-dispatch
-  name
-  (type :test (not (eq type *universal-type*)))
-  (where-from :test (not (eq where-from :assumed)))
-  arglist
-  min-args
-  max-args
-  (entry-points :test entry-points)
-  (more-entry :test more-entry)
-  main-entry)
-
-
-;;; The Arg-Info structure allows us to tack various information onto
-;;; Lambda-Vars during IR1 conversion.  If we use one of these things, then the
-;;; var will have to be massaged a bit before it is simple and lexical.
-;;;
-(defstruct (arg-info (:print-function %print-arg-info))
-  ;;
-  ;; True if this arg is to be specially bound.
-  (specialp nil :type boolean)
-  ;;
-  ;; The kind of argument being described.  Required args only have arg
-  ;; info structures if they are special.
-  (kind nil :type (member :required :optional :keyword :rest))
-  ;;
-  ;; If true, the Var for supplied-p variable of a keyword or optional arg.
-  ;; This is true for keywords with non-constant defaults even when there is no
-  ;; user-specified supplied-p var.
-  (supplied-p nil :type (or lambda-var null))
-  ;;
-  ;; The default for a keyword or optional, represented as the original
-  ;; Lisp code.  This is set to NIL in keyword arguments that are defaulted
-  ;; using the supplied-p arg.
-  (default nil :type t)
-  ;;
-  ;; The actual keyword for a keyword argument.
-  (keyword nil :type (or keyword null)))
-
-(defprinter arg-info
-  (specialp :test specialp)
-  kind
-  (supplied-p :test supplied-p)
-  (default :test default)
-  (keyword :test keyword))
-
-
-;;; The Lambda-Var structure represents a lexical lambda variable.  This
-;;; structure is also used during IR1 conversion to describe lambda arguments
-;;; which may ultimately turn out not to be simple and lexical.
-;;;
-;;; Lambda-Vars with no Refs are considered to be deleted; environment analysis
-;;; isn't done on these variables, so the back end must check for and ignore
-;;; unreferenced variables.  Note that a deleted lambda-var may have sets; in
-;;; this case the back end is still responsible for propagating the Set-Value
-;;; to the set's Cont.
-;;;
-(defstruct (lambda-var (:include basic-var)
-		       (:print-function %print-lambda-var))
-  ;;
-  ;; True if this variable has been declared Ignore.
-  (ignorep nil :type boolean)
-  ;;
-  ;; The Lambda that this var belongs to.  This may be null when we are
-  ;; building a lambda during IR1 conversion.
-  (home nil :type (or null clambda))
-  ;;
-  ;; This is set by environment analysis if it chooses an indirect (value cell)
-  ;; representation for this variable because it is both set and closed over.
-  (indirect nil :type boolean)
-  ;;
-  ;; The following two slots are only meaningful during IR1 conversion of hairy
-  ;; lambda vars:
-  ;;
-  ;; The Arg-Info structure which holds information obtained from &keyword
-  ;; parsing.
-  (arg-info nil :type (or arg-info null))
-  ;;
-  ;; If true, the Global-Var structure for the special variable which is to be
-  ;; bound to the value of this argument.
-  (specvar nil :type (or global-var null))
-  ;;
-  ;; Set of the CONSTRAINTs on this variable.  Used by constraint
-  ;; propagation.  This is left null by the lambda pre-pass if it determine
-  ;; that this is a set closure variable, and is thus not a good subject for
-  ;; flow analysis.
-  (constraints nil :type (or sset null)))
-
-(defprinter lambda-var
-  name
-  (type :test (not (eq type *universal-type*)))
-  (where-from :test (not (eq where-from :assumed)))
-  (ignorep :test ignorep)
-  (arg-info :test arg-info)
-  (specvar :test specvar))
-
-
-;;;; Basic node types:
-
-;;; A Ref represents a reference to a leaf.  Ref-Reoptimize is initially (and
-;;; forever) NIL, since Refs don't receive any values and don't have any IR1
-;;; optimizer.
-;;;
-(defstruct (ref (:include node (:reoptimize nil))
-		(:constructor make-ref (derived-type source leaf inlinep))
-		(:print-function %print-ref))
-  ;;
-  ;; The leaf referenced.
-  (leaf nil :type leaf)
-  ;;
-  ;; For a function variable, indicates the legality of coding inline.  Nil,
-  ;; means that there is no relevent declaration so we can do whatever we want.
-  (inlinep nil :type inlinep))
-
-(defprinter ref
-  leaf
-  (inlinep :test inlinep))
-
-
-;;; Naturally, the IF node always appears at the end of a block.  Node-Cont is
-;;; a dummy continuation, and is there only to keep people happy.
-;;;
-(defstruct (cif (:include node)
-		(:print-function %print-if)
-		(:conc-name if-)
-		(:predicate if-p)
-		(:constructor make-if)
-		(:copier copy-if))
-  ;;
-  ;; Continuation for the predicate.
-  (test nil :type continuation)
-  ;;
-  ;; The blocks that we execute next in true and false case, respectively (may
-  ;; be the same.)
-  (consequent nil :type cblock)
-  (alternative nil :type cblock))
-
-(defprinter if
-  (test :prin1 (continuation-use test))
-  consequent
-  alternative)
-
-
-(defstruct (cset (:include node
-			   (:derived-type *universal-type*))
-		 (:print-function %print-set)
-		 (:conc-name set-)
-		 (:predicate set-p)
-		 (:constructor make-set)
-		 (:copier copy-set))
-  ;;
-  ;; Descriptor for the variable set.
-  (var nil :type basic-var)
-  ;;
-  ;; Continuation for the value form.
-  (value nil :type continuation))
-
-(defprinter set
-  var
-  (value :prin1 (continuation-use value)))
-
-
-;;; The Basic-Combination structure is used to represent both normal and
-;;; multiple value combinations.  In a local function call, this node appears
-;;; at the end of its block and the body of the called function appears as the
-;;; successor.  The NODE-CONT remains the continuation which receives the
-;;; value of the call.
-;;;
-(defstruct (basic-combination (:include node))
-  ;;
-  ;; Continuation for the function.
-  (fun nil :type continuation)
-  ;;
-  ;; List of continuations for the args.  In a local call, an argument
-  ;; continuation may be replaced with NIL to indicate that the corresponding
-  ;; variable is unreferenced, and thus no argument value need be passed.
-  (args nil :type list)
-  ;;
-  ;; The kind of function call being made.  :Full is a standard call, with the
-  ;; function being determined at run time.  :Local is used when we are calling
-  ;; a function known at compile time.  The IR1 for the called function is
-  ;; spliced into the flow graph for the caller.  Calls to known global
-  ;; functions are represented by storing the Function-Info for the function in
-  ;; this slot.
-  (kind :full :type (or (member :full :local) function-info))
-  ;;
-  ;; Some kind of information attached to this node by the back end.
-  (info nil))
-
-
-;;; The Combination node represents all normal function calls, including
-;;; FUNCALL.  This is distinct from Basic-Combination so that an MV-Combination
-;;; isn't Combination-P.
-;;;
-(defstruct (combination (:include basic-combination)
-			(:constructor make-combination (source fun))
-			(:print-function %print-combination)))
-
-(defprinter combination
-  (fun :prin1 (continuation-use fun))
-  (args :prin1 (mapcar #'(lambda (x)
-			   (if x
-			       (continuation-use x)
-			       "<deleted>"))
-		       args)))
-
-
-;;; An MV-Combination is to Multiple-Value-Call as a Combination is to Funcall.
-;;; This is used to implement all the multiple-value receiving forms.
-;;;
-(defstruct (mv-combination (:include basic-combination)
-			   (:constructor make-mv-combination (source fun))
-			   (:print-function %print-mv-combination)))
-
-(defprinter mv-combination
-  (fun :prin1 (continuation-use fun))
-  (args :prin1 (mapcar #'continuation-use args)))
-
-
-;;; The Bind node marks the beginning of a lambda body and represents the
-;;; creation and initialization of the variables.
-;;;
-(defstruct (bind (:include node)
-		 (:print-function %print-bind))
-  ;;
-  ;; The lambda we are binding variables for.  Null when we are creating the
-  ;; Lambda during IR1 translation.
-  (lambda nil :type (or clambda null)))
-
-(defprinter bind
-  lambda)
-
-
-;;; The Return node marks the end of a lambda body.  It collects the return
-;;; values and represents the control transfer on return.  This is also where
-;;; we stick information used for Tail-Set type inference.
-;;;
-(defstruct (creturn (:include node)
-		    (:print-function %print-return)
-		    (:conc-name return-)
-		    (:predicate return-p)
-		    (:constructor make-return)
-		    (:copier copy-return))
-  ;;
-  ;; The lambda we are returing from.  Null temporarily during ir1tran.
-  (lambda nil :type (or clambda null))
-  ;;
-  ;; The continuation which yields the value of the lambda.
-  (result nil :type continuation)
-  ;;
-  ;; The union of the node-derived-type of all uses of the result other than by
-  ;; a local call, intersected with the result's asserted-type.  If there are
-  ;; no non-call uses, this is *empty-type*.
-  (result-type *wild-type* :type ctype))
-
-
-(defprinter return
-  lambda
-  result-type)
-
-
-;;;; Non-local exit support:
-;;;
-;;;    In IR1, we insert special nodes to mark potentially non-local lexical
-;;; exits.
-
-
-;;; The Entry node serves to mark the start of the dynamic extent of a lexical
-;;; exit.  It is the mess-up node for the corresponding :Entry cleanup.
-;;;
-(defstruct (entry (:include node)
-		  (:print-function %print-entry))
-  ;;
-  ;; All of the continuations for potential non-local exits to this point.
-  (exits nil :type list))
-
-(defprinter entry
-  exits)
-
-
-;;; The Exit node marks the place at which exit code would be emitted, if
-;;; necessary.  This is interposed between the uses of the exit continuation
-;;; and the exit continuation's DEST.  Instead of using the returned value
-;;; being delivered directly to the exit continuation, it is delivered to our
-;;; Value continuation.  The original exit continuation is the exit node's
-;;; CONT.
-;;;
-(defstruct (exit (:include node)
-		 (:print-function %print-exit))
-  ;;
-  ;; The Entry node that this is an exit for.  If null, this is a degenerate
-  ;; exit.  A degenerate exit is used to "fill" an empty block (which isn't
-  ;; allowed in IR1.)  In a degenerate exit, Value is always also null.
-  (entry nil :type (or entry null))
-  ;;
-  ;; The continuation yeilding the value we are to exit with.  If NIL, then no
-  ;; value is desired (as in GO).
-  (value nil :type (or continuation null)))
-
-(defprinter exit
-  (entry :test entry)
-  (value :test value))
-
-
-;;;; Miscellaneous IR1 structures:
-
-(defstruct (unknown-function
-	    (:print-function
-	     (lambda (s stream d)
-	       (declare (ignore d))
-	       (format stream "#<Unknown-Function ~S>"
-		       (unknown-function-name s)))))
-  ;;
-  ;; The name of the unknown function called.
-  (name nil :type (or symbol list))
-  ;;
-  ;; The number of times this function was called.
-  (count 0 :type unsigned-byte)
-  ;;
-  ;; A list of COMPILER-ERROR-CONTEXT structures describing places where this
-  ;; function was called.  Note that we only record the first
-  ;; *UNKNOWN-FUNCTION-WARNING-LIMIT* calls.
-  (warnings () :type list))
diff --git a/compiler/old-rt/arith.lisp b/compiler/old-rt/arith.lisp
deleted file mode 100644
index 5a453fb90c10b377e8be77eedfbcab170463dc13..0000000000000000000000000000000000000000
--- a/compiler/old-rt/arith.lisp
+++ /dev/null
@@ -1,185 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    This file contains the VM definition arithmetic VOPs for the RT.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-
-;;; Assume that any constant operand is the second arg...
-
-(defmacro define-fixnum-binop (name inherits translate op &key
-				    unsigned immed-op commute-op short-op
-				    function)
-  `(define-vop (,name ,inherits)
-     (:translate ,translate)
-     (:generator 1
-       (sc-case y
-	 ((any-reg descriptor-reg)
-	  (cond ((location= x r)
-		 (inst ,op x y))
-		,@(when commute-op
-		    `(((location= y r)
-		       (inst ,commute-op y x))))
-		(t
-		 (inst lr r x)
-		 (inst ,op r y))))
-	 ,@(when (or immed-op short-op)
-	     `(((short-immediate unsigned-immediate
-				 ,@(unless unsigned '(immediate)))
-		(cond
-		 ,@(when short-op
-		     `(((and (sc-is y short-immediate)
-			     (location= x r))
-			(inst ,short-op r (tn-value y)))))
-		 (t
-		  (inst ,immed-op r x
-			,(if function
-			     `(,function (tn-value y))
-			     '(tn-value y))))))))))))
-
-
-;;;; Arithmetic:
-
-(define-vop (fast-binop/fixnum)
-  (:args (x :target r
-	    :scs (any-reg descriptor-reg))
-	 (y :target r
-	    :scs (any-reg descriptor-reg
-			  short-immediate unsigned-immediate immediate)))
-  (:results (r :scs (any-reg descriptor-reg)))
-  (:arg-types fixnum fixnum)
-  (:result-types fixnum)
-  (:effects)
-  (:affected)
-  (:note "inline fixnum arithmetic")
-  (:policy :fast-safe))
-
-(define-fixnum-binop fast-+/fixnum fast-binop/fixnum + a
-  :short-op ais :immed-op ai :commute-op a)
-
-(define-fixnum-binop fast--/fixnum fast-binop/fixnum - s
-  :short-op sis :immed-op ai :function - :commute-op sf)
-
-
-(define-vop (fixnum-unop)
-  (:args (x :scs (any-reg descriptor-reg)))
-  (:results (res :scs (any-reg descriptor-reg)))
-  (:note "inline fixnum arithmetic")
-  (:arg-types fixnum)
-  (:result-types fixnum)
-  (:policy :fast-safe))
-
-(macrolet ((frob (name inst trans)
-	     `(define-vop (,name fixnum-unop)
-		(:translate ,trans)
-		(:generator 1
-		  (inst ,inst res x)))))
-  (frob fast-negate/fixnum twoc %negate)
-  (frob fast-lognot/fixnum onec lognot)
-  (frob fast-abs/fixnum abs abs))
-
-(define-miscop-variants effectless-unaffected-two-arg-miscop + - / *)
-(define-miscop negate (x) :translate %negate)
-(define-miscop truncate (x y) :results (q r) :translate truncate)
-
-
-;;;; Logic operations:
-
-;;; Like fast-binop/fixnum, except the immediate operand is unsigned, and
-;;; a fixnum result assertion isn't needed.
-;;;
-(define-vop (fast-logic-binop/fixnum fast-binop/fixnum)
-  (:args (x :target r
-	    :scs (any-reg descriptor-reg))
-	 (y :target r
-	    :scs (any-reg descriptor-reg short-immediate unsigned-immediate)))
-  (:result-types t))
-
-(define-fixnum-binop fast-logior/fixnum fast-logic-binop/fixnum logior o
-  :immed-op oil :unsigned t :commute-op o)
-
-(define-fixnum-binop fast-logand/fixnum fast-logic-binop/fixnum logand n
-  :immed-op nilz :unsigned t :commute-op n)
-
-(define-fixnum-binop fast-logxor/fixnum fast-logic-binop/fixnum logxor x
-  :immed-op xil :unsigned t :commute-op x)
-
-#|
-(define-vop (fast-ash/fixnum fast-binop/fixnum)
-  (:generator 1
-    (sc-case y
-      ((any-reg descriptor-reg)
-       ))))
-|#
-
-(define-miscop-variants effectless-unaffected-two-arg-miscop
-			logand logior logxor)
-(define-miscop-variants effectless-unaffected-one-arg-miscop lognot)
-(define-miscop ldb (size pos int) :translate %ldb)
-(define-miscop mask-field (size pos int) :translate %mask-field)
-(define-miscop dpb (new size pos int) :translate %dpb)
-(define-miscop deposit-field (new size pos int) :translate %deposit-field)
-
-
-;;;; Binary conditional VOPs:
-
-(define-vop (fast-conditional/fixnum)
-  (:args (x :scs (any-reg descriptor-reg))
-	 (y :scs (any-reg descriptor-reg
-			  short-immediate unsigned-immediate immediate)))
-  (:arg-types fixnum fixnum)
-  (:conditional)
-  (:info target not-p)
-  (:effects)
-  (:affected)
-  (:policy :fast-safe)
-  (:note "inline fixnum comparison")
-  (:variant-vars condition)
-  (:generator 1
-    (sc-case y
-      (short-immediate
-       (inst cis x (tn-value y)))
-      ((immediate unsigned-immediate)
-       (inst ci x (tn-value y)))
-      ((any-reg descriptor-reg)
-       (inst c x y)))
-
-    (if not-p
-	(inst bnb condition target)
-	(inst bb condition target))))
-
-
-(define-vop (fast-if-</fixnum fast-conditional/fixnum)
-  (:translate <)
-  (:variant :lt))
-
-(define-vop (fast-if->/fixnum fast-conditional/fixnum)
-  (:translate >)
-  (:variant :gt))
-
-(define-vop (fast-if-=/fixnum fast-conditional/fixnum)
-  (:translate =)
-  (:variant :eq))
-
-
-
-(define-vop (if-< two-arg-conditional-miscop)
-  (:variant 'clc::compare :lt)
-  (:translate <))
-
-(define-vop (if-> two-arg-conditional-miscop)
-  (:variant 'clc::compare :gt)
-  (:translate >))
-
-(define-vop (if-= two-arg-conditional-miscop)
-  (:variant 'clc::compare :eq)
-  (:translate =))
diff --git a/compiler/old-rt/assem-insts.lisp b/compiler/old-rt/assem-insts.lisp
deleted file mode 100644
index d791605963d0d57f6d02e6bd424089aa929cace2..0000000000000000000000000000000000000000
--- a/compiler/old-rt/assem-insts.lisp
+++ /dev/null
@@ -1,286 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    Assembler instruction definitions for the IBM RT PC.
-;;;
-(in-package 'c)
-
-(def-instruction-format R 2 ; Instruction format "R"
-  (:unsigned 8 :instruction-constant) ; OP
-  (:unsigned 4 :register) ; R2
-  (:unsigned 4 :register)) ; R3
-
-(def-instruction-format R1 2 ; Instruction format "R"
-  (:unsigned 8 :instruction-constant) ; OP
-  (:unsigned 4 :enumeration '((:pz . #b1000)
-			      (:lt . #b1001)
-			      (:eq . #b1010)
-			      (:gt . #b1011)
-			      (:c0 . #b1100)
-			      (:ov . #b1110)
-			      (:tb . #b1111))) ; Condition code
-  (:unsigned 4 :register)) ; R3
-
-(def-instruction-format R2 2 ; Instruction format "R"
-  (:unsigned 8 :instruction-constant) ; OP
-  (:unsigned 4 :register) ; R2
-  (:signed 4 :immediate)) ; R3
-
-(def-instruction-format DS 2 ; Instruction format "D-Short"
-  (:unsigned 4 :instruction-constant) ; OP
-  (:signed 4 :immediate) ; I
-  (:unsigned 4 :register) ; R2
-  (:unsigned 4 :register)) ; R3
-
-(def-instruction-format D 4 ; Instruction format "D"
-  (:unsigned 8 :instruction-constant) ; OP
-  (:unsigned 4 :register) ; R2
-  (:unsigned 4 :register) ; R3
-  (:signed 16 :immediate)) ; I
-
-(def-instruction-format Dr2z 4 ; Instruction format "D" with R2 0 (ci...)
-  (:unsigned 8 :instruction-constant) ; OP
-  (:unsigned 4 :constant 0) ; R2
-  (:unsigned 4 :register) ; R3
-  (:signed 16 :immediate)) ; I
-
-(def-instruction-format X 2 ; Instruction format "X"
-  (:unsigned 4 :instruction-constant)
-  (:unsigned 4 :register) ; 
-  (:unsigned 4 :register) ; R2
-  (:unsigned 4 :register)) ; R3
-
-(def-instruction-format x0 2 ; Special format for the LR pseudo-instruction
-  (:unsigned 4 :instruction-constant)
-  (:unsigned 4 :register)
-  (:unsigned 4 :register)
-  (:unsigned 4 :constant 0))
-
-(def-instruction-format BM 4 ;Instruction format for Miscop branches
-  (:unsigned 8 :instruction-constant)
-  (:signed 24 :fixup :miscop))
-
-(def-instruction-format JI 2 ; Instruction format "JI"
-  (:unsigned 5 :instruction-constant) ; OP
-  (:unsigned 3 :enumeration '((:pz . #b000)
-			      (:lt . #b001)
-			      (:eq . #b010)
-			      (:gt . #b011)
-			      (:c0 . #b100)
-			      (:ov . #b110)
-			      (:tb . #b111))) ; Condition code
-  (:signed 8 :branch #'(lambda (x) (ash x -1)))) ; J1
-
-(def-instruction-format BI 4 ; Instruction format "BI"
-  (:unsigned 8 :instruction-constant) ; OP
-  (:unsigned 4 :enumeration '((:pz . #b1000)
-			      (:lt . #b1001)
-			      (:eq . #b1010)
-			      (:gt . #b1011)
-			      (:c0 . #b1100)
-			      (:ov . #b1110)
-			      (:tb . #b1111))) ; Condition code
-  (:signed 20 :branch #'(lambda (x) (ash x -1)))) ; B1
-
-; Instruction format "BI" with register arg (bal,...)
-
-(def-instruction-format BIR 4
-  (:unsigned 8 :instruction-constant) ; OP
-  (:unsigned 4 :register)
-  (:signed 20 :branch #'(lambda (x) (ash x -1)))) ; B1
-
-
-(def-instruction-format BA 4
-  (:unsigned 8 :instruction-constant)
-  (:signed 24 :branch #'(lambda (x) (ash x -1))))
-
-(def-instruction-format SR 2
-  (:unsigned 12 :instruction-constant)
-  (:unsigned 4 :register))
-
-(def-instruction-format SN 2
-  (:unsigned 12 :instruction-constant)
-  (:signed 4 :immediate))
-
-;;; Storage Access instructions:
-
-(def-instruction lcs  ds #x04)
-(def-instruction lc   d  #xCE)
-(def-instruction lhas ds #x05)
-(def-instruction lha  d  #xCA)
-(def-instruction lhs  r  #xEB)
-(def-instruction lh   d  #xDA)
-(def-instruction ls   ds #x07)
-(def-instruction l    d  #xCD)
-(def-instruction lm   d  #xC9)
-(def-instruction tsh  d  #xCF)
-(def-instruction stcs ds #x01)
-(def-instruction stc  d  #xDE)
-(def-instruction sths ds #x02)
-(def-instruction sth  d  #xDC)
-(def-instruction sts  ds #x03)
-(def-instruction st   d  #xDD)
-(def-instruction stm  d  #xD9)
-
-;;; Address Computation instructions:
-
-(def-instruction cal  d  #xC8)
-(def-instruction cal16 d #xC2)
-(def-instruction cau  d  #xD8)
-(def-instruction cas  x  #x06)
-(def-instruction lr   x0 #x06)
-(def-instruction ca16 r  #xF3)
-(def-instruction inc  r2 #x91)
-(def-instruction dec  r2 #x93)
-(def-instruction lis  r2 #xA4)
-
-;;; Branching instructions:
-
-(def-instruction bala-inst ba #x8A)
-(def-instruction balax-inst ba #x8B)
-(def-instruction miscop bm #x8A)
-(def-instruction miscopx bm #x8B)
-(def-instruction bali-inst bir #x8C)
-(def-instruction balix-inst bir #x8D)
-(def-instruction balr r  #xEC)
-(def-instruction balrx r #xED)
-(def-instruction jb-inst   ji #x01)
-(def-instruction bb-inst   bi #x8E)
-(def-instruction bbx-inst  bi #x8F)
-(def-instruction bbr  r1 #xEE)
-(def-instruction bbrx r1 #xEF)
-(def-instruction jnb-inst  ji #x00)
-(def-instruction bnb-inst  bi #x88)
-(def-instruction bnbx-inst bi #x89)
-(def-instruction bnbr r1  #xE8)
-(def-instruction bnbrx r1  #xe9)
-
-;;; Trap instructions:
-
-(def-instruction ti   d  #xCC)
-(def-instruction tgte r  #xBD)
-(def-instruction tlt  r  #xBE)
-
-;;; Move and Insert instructions.
-
-(def-instruction mc03 r  #xF9)
-(def-instruction mc13 r  #xFA)
-(def-instruction mc23 r  #xFB)
-(def-instruction mc33 r  #xFC)
-(def-instruction mc30 r  #xFD)
-(def-instruction mc31 r  #xFE)
-(def-instruction mc32 r  #xFF)
-(def-instruction mftb r  #xBC)
-(def-instruction mftbil r2 #x9D)
-(def-instruction mftbiu r2 #x9C)
-(def-instruction mttb r  #xBF)
-(def-instruction mttbil r2 #x9F)
-(def-instruction mttbiu r2 #x9E)
-
-;;; Arithmetic instructions.
-
-(def-instruction a    r  #xE1)
-(def-instruction ae   r  #xF1)
-(def-instruction aei  d  #xD1)
-(def-instruction ai   d  #xC1)
-(def-instruction ais  r2 #x90)
-(def-instruction abs  r  #xE0)
-(def-instruction onec r  #xF4)
-(def-instruction twoc r  #xE4)
-(def-instruction c    r  #xB4)
-(def-instruction cis  r2 #x94)
-(def-instruction ci   dr2z #xD4)
-(def-instruction cl   r  #xB3)
-(def-instruction cli  dr2z #xD3)
-(def-instruction exts r  #xB1)
-(def-instruction s    r  #xE2)
-(def-instruction sf   r  #xB2)
-(def-instruction se   r  #xF2)
-(def-instruction sfi  d  #xD2)
-(def-instruction sis  r2 #x92)
-(def-instruction d    r  #xB6)
-(def-instruction m    r  #xE6)
-
-;;; Logical instructions.
-
-(def-instruction clrbl r2 #x99)
-(def-instruction clrbu r2 #x98)
-(def-instruction setbl r2 #x9B)
-(def-instruction setbu r2 #x9A)
-(def-instruction n     r  #xE5)
-(def-instruction nilz  d  #xC5)
-(def-instruction nilo  d  #xC6)
-(def-instruction niuz  d  #xD5)
-(def-instruction niuo  d  #xD6)
-(def-instruction o     r  #xE3)
-(def-instruction oil   d  #xC4)
-(def-instruction oiu   d  #xC3)
-(def-instruction x     r  #xE7)
-(def-instruction xil   d  #xC7)
-(def-instruction xiu   d  #xD7)
-(def-instruction clz   r  #xF5)
-
-;;; Shifting instructions.
-
-(def-instruction sar   r  #xB0)
-(def-instruction sari  r2 #xA0)
-(def-instruction sari16 r2 #xA1)
-(def-instruction sr    r  #xB8)
-(def-instruction sri   r2 #xA8)
-(def-instruction sri16 r2 #xA9)
-(def-instruction srp   r  #xB9)
-(def-instruction srpi  r2 #xAC)
-(def-instruction srpi16 r2 #xAD)
-(def-instruction sl    r  #xBA)
-(def-instruction sli   r2 #xAA)
-(def-instruction sli16 r2 #xAB)
-(def-instruction slp   r  #xBB)
-(def-instruction slpi  r2 #xAE)
-(def-instruction slpi16 r2 #xAF)
-
-;;; Special Purpose Register Manipulation instructions.
-
-(def-instruction mtmq  sr #xB5A)
-(def-instruction mfmq  sr #x96A)
-(def-instruction mtcsr sr #xB5F)
-(def-instruction mfcsr sr #x96F)
-(def-instruction clrcb sn #x95F)
-(def-instruction setcb sn #x97F)
-
-;;; Execution Control instructions.
-
-(def-instruction lps   d  #xD0)
-(def-instruction svc   d  #xC0)
-
-
-(def-branch bala (label) label
-  (-32768 32767 (bala-inst label)))
-
-(def-branch balax (label) label
-  (-32768 32767 (balax-inst label)))
-
-(def-branch bali (pc label) label
-  (-32768 32767 (bali-inst pc label)))
-
-(def-branch balix (pc label) label
-  (-32768 32767 (balix-inst pc label)))
-
-(def-branch bbx (n label) label
-  (-32768 32767 (bbx-inst n label)))
-
-(def-branch bb (n label) label
-;  (-128 127 (jb-inst n label))
-  (-32768 32767 (bb-inst n label)))
-
-(def-branch bnbx (n label) label
-  (-32768 32767 (bnbx-inst n label)))
-
-(def-branch bnb (n label) label
-;  (-128 127 (jnb-inst n label))
-  (-32768 32767 (bnb-inst n label)))
diff --git a/compiler/old-rt/call.lisp b/compiler/old-rt/call.lisp
deleted file mode 100644
index 3e48c5fd9e5c813343d651ebe92684aa2b14fe3c..0000000000000000000000000000000000000000
--- a/compiler/old-rt/call.lisp
+++ /dev/null
@@ -1,971 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    This file contains the VM definition of function call for the RT.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-
-;;;; Interfaces to IR2 conversion:
-
-;;; Standard-Argument-Location  --  Interface
-;;;
-;;;    Return a wired TN describing the N'th full call argument passing
-;;; location.
-;;;
-(defun standard-argument-location (n)
-  (declare (type unsigned-byte n))
-  (if (< n register-arg-count)
-      (make-wired-tn *any-primitive-type* register-arg-scn
-		     (elt register-arg-offsets n))
-      (make-wired-tn *any-primitive-type* stack-arg-scn n)))
-
-
-;;; Make-Return-PC-Passing-Location  --  Interface
-;;;
-;;;    Make a passing location TN for a local call return PC.  If standard is
-;;; true, then use the standard (full call) location, otherwise use any legal
-;;; location.  Even in the non-standard case, this may be restricted by a
-;;; desire to use a subroutine call instruction.
-;;;
-(defun make-return-pc-passing-location (standard)
-  (if standard
-      (make-wired-tn *any-primitive-type* register-arg-scn return-pc-offset)  
-      (make-restricted-tn *any-primitive-type* (list register-arg-scn))))
-
-
-;;; Make-Old-Cont-Passing-Location  --  Interface
-;;;
-;;;    Similar to Make-Return-PC-Passing-Location, but makes a location to pass
-;;; Old-Cont in.  This is (obviously) wired in the standard convention, but is
-;;; totally unrestricted in non-standard conventions, since we can always fetch
-;;; it off of the stack using the arg pointer.
-;;;
-(defun make-old-cont-passing-location (standard)
-  (if standard
-      (make-wired-tn *any-primitive-type* register-arg-scn old-cont-offset)
-      (make-normal-tn *any-primitive-type*)))
-
-
-;;; Make-Old-Cont-Save-Location, Make-Return-PC-Save-Location  --  Interface
-;;;
-;;;    Make the TNs used to hold Old-Cont and Return-PC within the current
-;;; function.  We treat these specially so that the debugger can find them at a
-;;; known location.
-;;;
-(defun make-old-cont-save-location (env)
-  (make-wired-environment-tn *any-primitive-type*
-			     stack-arg-scn old-cont-save-offset
-			     env))
-;;;
-(defun make-return-pc-save-location (env)
-  (make-wired-environment-tn *any-primitive-type*
-			     stack-arg-scn return-pc-save-offset
-			     env))
-
-
-;;; Make-Argument-Pointer-Location  --  Interface
-;;;
-;;;    Similar to Make-Return-PC-Passing-Location, but makes a location to pass
-;;; an argument pointer in.  Even when non-standard locations are allowed, this
-;;; must be restricted to a register, since the argument pointer is used to
-;;; fetch stack arguments.
-;;;
-(defun make-argument-pointer-location (standard)
-  (if standard
-      (make-wired-tn *any-primitive-type* register-arg-scn
-		     argument-pointer-offset)
-      (make-restricted-tn *any-primitive-type* (list register-arg-scn))))
-
-
-;;; Make-Argument-Count-Location  --  Interface
-;;;
-;;;    Make a TN for the standard argument count passing location.  We only
-;;; need to make the standard location, since a count is never passed when we
-;;; are using non-standard conventions.
-;;;
-(defun make-argument-count-location ()
-  (make-wired-tn *any-primitive-type* register-arg-scn argument-count-offset))
-
-
-;;; Select-Component-Format  --  Interface
-;;;
-;;;    This function is called by the Entry-Analyze phase, allowing
-;;; VM-dependent initialization of the IR2-Component structure.  We push
-;;; placeholder entries in the Constants to leave room for the component name,
-;;; code vector and debug info.
-;;;
-(defun select-component-format (component)
-  (declare (type component component))
-  (dotimes (i 3)
-    (vector-push-extend nil
-			(ir2-component-constants (component-info component))))
-  (undefined-value))
-
-
-;;;; Argument/value passing, frame hackery:
-
-;;; Fetch the argument Arg using the argument pointer Argp, yeilding the value
-;;; Val.  This operation is used at function entry to move the arguments from
-;;; their passing locations to the appropriate variable.
-;;;
-(define-vop (move-argument)
-  (:args (arg :scs (any-reg descriptor-reg)  :load nil  :target val)
-	 (argp :scs (descriptor-reg)))
-  (:results (val :scs (any-reg descriptor-reg)))
-  (:generator 0
-    (sc-case arg
-      (stack
-       (loadw val argp (tn-offset arg)))
-      ((any-reg descriptor-reg)
-       (unless (location= arg val)
-	 (inst lr val arg))))))
-
-
-;;; Similar to Move-Argument, but is used to store known values into the frame
-;;; being returned into.  In this case, it is Loc that is potentially on the
-;;; stack in a different frame.
-;;;
-(define-vop (move-value)
-  (:args (value :scs (any-reg descriptor-reg)
-		:target loc)
-	 (old-cont :scs (descriptor-reg)))
-  (:results (loc :scs (any-reg descriptor-reg)  :load nil))
-  (:generator 0
-    (sc-case loc
-      (stack
-       (storew value old-cont (tn-offset loc)))
-      ((any-reg descriptor-reg)
-       (unless (location= loc value)
-	 (inst lr loc value))))))
-
-
-;;; Used for setting up the Old-Cont in local call.
-;;;
-(define-vop (current-cont)
-  (:results (val :scs (any-reg descriptor-reg)))
-  (:generator 1
-    (inst lr val cont-tn)))
-
-
-;;; Default-Unknown-Values  --  Internal
-;;;
-;;;    Emit code needed at the return-point from an unknown-values call for a
-;;; fixed number of values.  Values is the head of the TN-Ref list for the
-;;; locations that the values are to be received into.  Nvals is the number of
-;;; values that are to be received (should equal the length of Values).  Node
-;;; is the node to use for source context in emitted code.
-;;;
-;;;    Move-Temp and Nil-Temp are Descriptor-Reg TNs used as temporaries.
-;;;
-;;;    This code exploits the fact that in the unknown-values convention, a
-;;; single value return returns at the return PC + 4, whereas a return of other
-;;; than one value returns directly at the return PC.
-;;;
-;;;    If 0 or 1 values are expected, then we just emit an instruction to reset
-;;; the SP (which will only be executed when other than 1 value is returned.)
-;;;
-;;; In the general case, we have to do three things:
-;;;  -- Default unsupplied register values.  This need only be done when a
-;;;     single value is returned, since register values are defaulted by the
-;;;     called in the non-single case.
-;;;  -- Default unsupplied stack values.  This needs to be done whenever there
-;;;     are stack values.
-;;;  -- Reset SP.  This must be done whenever other than 1 value is returned,
-;;;     regardless of the number of values desired.
-;;;
-;;; The general-case code looks like this:
-#|
-	br regs-defaulted		; Skip if MVs
-	cau a1 0 nil-16			; Default register values
-	...
-	loadi nargs 1			; Force defaulting of stack values
-	lr args sp			; Set up args for SP resetting
-
-regs-defaulted
-	cau nil-temp 0 nil-16		; Cache nil
-
-	cmpi nargs 3			; If 4'th value unsupplied...
-	blex default-value-4		;    jump to default code
-	loadw move-temp args-tn 3	; Move value to correct location.
-	store-stack-tn val4-tn move-temp
-
-	cmpi nargs 4			; Check 5'th value, etc.
-	blex default-value-5
-	loadw move-temp args-tn 4
-	store-stack-tn val5-tn move-temp
-
-	...
-
-defaulting-done
-	lr sp args			; Reset SP.
-<end of code>
-
-<elsewhere>
-default-value-4 
-	store-stack-tn val4-tn nil-temp ; Nil out 4'th value.
-
-default-value-5
-	store-stack-tn val5-tn nil-temp ; Nil out 5'th value.
-
-	...
-
-	br defaulting-done
-|#
-;;;
-(defun default-unknown-values (node values nvals move-temp nil-temp)
-  (declare (type node node) (type (or tn-ref null) values)
-	   (type unsigned-byte nvals) (type tn move-temp nil-temp))
-  (assemble node
-    (if (<= nvals 1)
-	(inst ai sp-tn args-tn 0)
-	(let ((regs-defaulted (gen-label))
-	      (defaulting-done (gen-label)))
-	  (inst bnb :pz regs-defaulted)
-
-	  (do ((i 1 (1+ i))
-	       (val (tn-ref-across values) (tn-ref-across val)))
-	      ((= i (min nvals register-arg-count)))
-	    (inst cau (tn-ref-tn val) zero-tn clc::nil-16))
-	  (when (> nvals register-arg-count)
-	    (loadi nargs-tn 1)
-	    (inst lr args-tn sp-tn))
-
-	  (emit-label regs-defaulted)
-
-	  (when (> nvals register-arg-count)
-	    (inst cau nil-temp zero-tn clc::nil-16)
-
-	    (collect ((defaults))
-	      (do ((i register-arg-count (1+ i))
-		   (val (do ((i 0 (1+ i))
-			     (val values (tn-ref-across val)))
-			    ((= i register-arg-count) val))
-			(tn-ref-across val)))
-		  ((null val))
-		
-		(let ((default-lab (gen-label))
-		      (tn (tn-ref-tn val)))
-		  (defaults (cons default-lab tn))
-		  (cmpi nargs-tn i)
-		  (inst bnbx :gt default-lab)
-		  (loadw move-temp args-tn i)
-		  (store-stack-tn tn move-temp)))
-
-	      (emit-label defaulting-done)
-	      (inst lr sp-tn args-tn)
-
-	      (unassemble
-	       (assemble-elsewhere node
-		 (dolist (def (defaults))
-		   (emit-label (car def))
-		   (store-stack-tn (cdr def) nil-temp))
-		 (inst bnb :pz defaulting-done))))))))
-  (undefined-value))
-
-
-;;;; Unknown values receiving:
-
-;;; Receive-Unknown-Values  --  Internal
-;;;
-;;;    Emit code needed at the return point for an unknown-values call for an
-;;; arbitrary number of values.
-;;;
-;;;    We do the single and non-single cases with no shared code: there doesn't
-;;; seem to be any potential overlap, and receiving a single value is more
-;;; important efficiency-wise.
-;;;
-;;;    When there is a single value, we just push it on the stack, returning
-;;; the old SP and 1.
-;;;
-;;;    When there is a variable number of values, we move all of the argument
-;;; registers onto the stack, and return Args and Nargs.
-;;;
-;;;    Args and Nargs are TNs wired to the named locations.  We must
-;;; explicitly allocate these TNs, since their lifetimes overlap with the
-;;; results Start and Count (also, it's nice to be able to target them).
-;;;
-(defun receive-unknown-values (node args nargs start count)
-  (declare (type node node) (type tn args nargs start count))
-  (assemble node
-    (let ((variable-values (gen-label))
-	  (done (gen-label)))
-      (inst bnb :pz variable-values)
-
-      (inst inc sp-tn 4)
-      (storew (first register-argument-tns) sp-tn -1)
-      (inst cal start sp-tn -4)
-      (loadi count 1)
-
-      (emit-label done)
-
-      (unassemble
-	(assemble-elsewhere node
-	  (emit-label variable-values)
-	  (do ((arg register-argument-tns (rest arg))
-	       (i 0 (1+ i)))
-	      ((null arg))
-	    (storew (first arg) args i))
-	  (unless (location= start args)
-	    (inst lr start args))
-	  (unless (location= count nargs)
-	    (inst lr count nargs))
-	  (inst bnb :pz done)))))
-  (undefined-value))
-
-
-;;; VOP that can be inherited by unknown values receivers.  The main thing this
-;;; handles is allocation of the result temporaries.
-;;;
-(define-vop (unknown-values-receiver)
-  (:results
-   (start :scs (descriptor-reg))
-   (count :scs (descriptor-reg)))
-  (:node-var node)
-  (:temporary (:sc descriptor-reg
-	       :offset argument-pointer-offset
-	       :from :eval  :to (:result 0))
-	      values-start)
-  (:temporary (:sc any-reg
-	       :offset argument-count-offset
-	       :from :eval  :to (:result 1))
-	      nvals))
-
-
-;;;; Tail-recursive local call:
-
-;;; We just do the control transfer.  The other stuff is done with explicit
-;;; move VOPs.
-;;;
-(define-vop (tail-call-local)
-  (:args
-   (args :more t))
-  (:info start)
-  (:ignore args)
-  (:generator 5
-    (when start
-      (inst bnb :pz start))))
-
-
-;;;; Local call with unknown values convention return:
-
-;;; Non-TR local call for a fixed number of values passed according to the
-;;; unknown values convention.
-;;;
-;;; Args are the argument passing locations, which are specified only to
-;;; terminate their lifetimes in the caller.
-;;;
-;;; Values are the return value locations (wired to the standard passing
-;;; locations).
-;;;
-;;; Save is the save info, which we can ignore since saving has been done.
-;;; Return-PC is the TN that the return PC should be passed in.
-;;; Target is a continuation pointing to the start of the called function.
-;;; Nvals is the number of values received.
-;;;
-(define-vop (call-local)
-  (:args (args :more t))
-  (:results (values :more t))
-  (:save-p t)
-  (:info save return-pc target nvals)
-  (:ignore args save)
-  (:node-var node)
-  (:vop-var vop)
-  (:temporary (:scs (descriptor-reg)) move-temp nil-temp)
-  (:temporary (:sc stack
-	       :offset env-save-offset)
-	      env-save)
-  (:generator 5
-    (store-stack-tn env-save env-tn)
-    (inst lr cont-tn sp-tn)
-    (inst balix return-pc target)
-    (inst cal sp-tn sp-tn (current-frame-size))
-    (note-this-location vop :unknown-return)
-    (unassemble
-      (default-unknown-values node values nvals move-temp nil-temp))
-    (load-stack-tn env-tn env-save)))
-
-
-;;; Non-TR local call for a variable number of return values passed according
-;;; to the unknown values convention.  The results are the start of the values
-;;; glob and the number of values received.
-;;;
-(define-vop (multiple-call-local unknown-values-receiver)
-  (:args (args :more t))
-  (:save-p t)
-  (:info save return-pc target)
-  (:ignore args save)
-  (:vop-var vop)
-  (:temporary (:sc stack
-	       :offset env-save-offset)
-	      env-save)
-  (:generator 20
-    (store-stack-tn env-save env-tn)
-    (inst lr cont-tn sp-tn)
-    (inst balix return-pc target)
-    (inst cal sp-tn sp-tn (current-frame-size))
-    (note-this-location vop :unknown-return)
-    (unassemble
-      (receive-unknown-values node values-start nvals start count))
-    (load-stack-tn env-tn env-save)))
-
-
-;;;; Local call with known values return:
-
-;;; Non-TR local call with known return locations.  Known-value return works
-;;; just like argument passing in local call.
-;;;
-(define-vop (known-call-local)
-  (:args
-   (args :more t))
-  (:results
-   (res :more t))
-  (:save-p t)
-  (:info save return-pc target)
-  (:ignore args res save)
-  (:vop-var vop)
-  (:generator 5
-    (inst lr cont-tn sp-tn)
-    (inst balix return-pc target)
-    (inst cal sp-tn sp-tn (current-frame-size))
-    (note-this-location vop :known-return)))
-
-
-;;; Return from known values call.  We receive the return locations as
-;;; arguments to terminate their lifetimes in the returning function.  We
-;;; restore CONT and SP and jump to the Return-PC.
-;;;
-(define-vop (known-return)
-  (:args
-   (old-cont :scs (descriptor-reg))
-   (return-pc :scs (descriptor-reg))
-   (locs :more t))
-  (:ignore locs)
-  (:generator 6
-    (inst lr sp-tn cont-tn)
-    (inst bnbrx :pz return-pc)
-    (inst lr cont-tn old-cont)))
-
-
-;;;; Full call:
-;;;
-;;;    There is something of a cross-product effect with full calls.  Different
-;;; versions are used depending on whether we know the number of arguments or
-;;; the name of the called function, and whether we want fixed values, unknown
-;;; values, or a tail call.
-
-;;; In full call, the arguments are passed by placing them in TNs wired to the
-;;; beginning of the current frame (as done by Standard-Argument-Location).  A
-;;; pointer to these arguments is then passed as the argument pointer.
-
-
-;;; Define-Full-Call  --  Internal
-;;;
-;;;    This macro helps in the definition of full call VOPs by avoiding code
-;;; replication in defining the cross-product VOPs.
-;;;
-;;; Name is the name of the VOP to define.
-;;; 
-;;; Named is true if the first argument is a symbol whose global function
-;;; definition is to be called.
-;;;
-;;; Return is either :Fixed, :Unknown or :Tail:
-;;; -- If :Fixed, then the call is for a fixed number of values, returned in
-;;;    the standard passing locations (passed as result operands).
-;;; -- If :Unknown, then the result values are pushed on the stack, and the
-;;;    result values are specified by the Start and Count as in the
-;;;    unknown-values continuation representation.
-;;; -- If :Tail, then do a tail-recursive call.  No values are returned.
-;;;    The Old-Cont and Return-PC are passed as the second and third arguments.
-;;;
-;;; Variable is true if there are a variable number of arguments passed on the
-;;; stack, with the last argument pointing to the beginning of the arguments.
-;;; If Variable is false, the arguments are set up in the standard passing
-;;; locations and are passed as the remaining arguments.  Variable cannot be
-;;; specified with :Tail return.  TR variable argument call is implemented
-;;; separately.
-;;;
-(defmacro define-full-call (name named return variable)
-  (assert (not (and variable (eq return :tail))))
-  `(define-vop (,name
-		,@(when (eq return :unknown)
-		    '(unknown-values-receiver)))
-     (:args
-      ,(if named
-	   '(name :scs (descriptor-reg)
-		  :target name-pass)
-	   '(arg-fun :scs (descriptor-reg)
-		     :target function))
-      
-      ,@(when (eq return :tail)
-	  '((old-cont :scs (descriptor-reg)
-		      :target old-cont-pass)
-	    (return-pc :scs (descriptor-reg)
-		       :target return-pc-pass)))
-      
-      ,(if variable
-	   '(args :scs (descriptor-reg)
-		  :target args-pass)
-	   '(args :more t)))
-
-     ,@(when (eq return :fixed)
-	 '((:results (values :more t))))
-   
-     ,@(unless (eq return :tail)
-	 '((:save-p t)
-	   (:node-var node)
-	   (:vop-var vop)
-	   (:temporary (:sc stack
-			:offset env-save-offset)
-		       env-save)))
-
-     (:info ,@(unless (eq return :tail) '(save))
-	    ,@(unless variable '(nargs))
-	    ,@(when (eq return :fixed) '(nvals)))
-
-     (:ignore
-      ,@(unless (eq return :tail) '(save))
-      ,@(unless variable '(args)))
-
-     (:temporary (:sc descriptor-reg
-		  :offset old-cont-offset
-		  :from (:argument ,(if (eq return :tail) 1 0))
-		  :to :eval)
-		 old-cont-pass)
-
-     (:temporary (:sc descriptor-reg
-		  :offset return-pc-offset
-		  :from (:argument ,(if (eq return :tail) 2 0))
-		  :to :eval)
-		 return-pc-pass)
-
-     ,@(when named 
-	 '((:temporary (:sc descriptor-reg
-			:offset call-name-offset
-			:from (:argument 0)
-			:to :eval)
-		       name-pass)))
-
-     (:temporary (:scs (descriptor-reg)
-		       :from (:argument 0)
-		       :to :eval)
-		 function)
-
-     (:temporary (:sc descriptor-reg
-		  :offset argument-pointer-offset
-		  :from (:argument ,(if variable 1 0))
-		  :to :eval)
-		 args-pass)
-
-     (:temporary (:sc descriptor-reg
-		  :offset argument-count-offset
-		  :to :eval)
-		 nargs-pass)
-
-     ,@(when variable
-	 '((:temporary (:sc descriptor-reg
-			:offset (first register-arg-offsets)
-			:to :eval)
-		       a0)
-	   (:temporary (:sc descriptor-reg
-			:offset (second register-arg-offsets)
-			:to :eval)
-		       a1)
-	   (:temporary (:sc descriptor-reg
-			:offset (third register-arg-offsets)
-			:to :eval)
-		       a2)))
-
-     ,@(when (eq return :fixed)
-	 '((:temporary (:scs (descriptor-reg)
-			:from :eval)
-		       move-temp nil-temp)))
-
-     (:temporary (:scs (descriptor-reg)
-		  :to :eval)
-		 code offset)
-
-     (:generator ,(+ (if named 5 0)
-		     (if variable 19 1)
-		     (if (eq return :tail) 0 10)
-		     15
-		     (if (eq return :unknown) 25 0))
-       
-       ,@(if named
-	     `((unless (location= name name-pass)
-		 (inst lr name-pass name))
-	       (loadw function name-pass (/ clc::symbol-definition 4)))
-	     `((unless (location= arg-fun function)
-		 (inst lr function arg-fun))))
-       
-       ,@(if variable
-	     `((unless (location= args args-pass)
-		 (inst lr args-pass args))
-	       (inst lr nargs-pass sp-tn)
-	       (inst s nargs-pass args-pass)
-	       (inst sari nargs-pass 2)
-	       (loadw a0 args-pass 0)
-	       (loadw a1 args-pass 1)
-	       (loadw a2 args-pass 2))
-	     `((loadi nargs-pass nargs)
-	       (inst lr args-pass cont-tn)))
-       
-       (load-slot code function system:%function-code-slot)
-       (load-slot offset function system:%function-offset-slot)
-       (inst cas code code offset)
-       
-       ,@(if (eq return :tail)
-	     '((unless (location= old-cont old-cont-pass)
-		 (inst lr old-cont-pass old-cont))
-	       (unless (location= return-pc return-pc-pass)
-		 (inst lr return-pc-pass return-pc))
-	       (inst bnbrx :pz code)
-	       (inst lr env-tn function))
-	     '((store-stack-tn env-save env-tn)
-	       (inst lr old-cont-pass cont-tn)
-	       (inst lr cont-tn sp-tn)
-	       (inst balrx return-pc-pass code)
-	       (inst lr env-tn function)
-	       (no-op)))
-       
-       ,@(ecase return
-	   (:fixed
-	    '((note-this-location vop :unknown-return)
-	      (unassemble
-	       (default-unknown-values node values nvals move-temp nil-temp))))
-	   (:unknown
-	    '((note-this-location vop :unknown-return)
-	      (unassemble
-	       (receive-unknown-values node values-start nvals start count))))
-	   (:tail))
-       
-       ,@(unless (eq return :tail)
-	   '((load-stack-tn env-tn env-save))))))
-
-
-(define-full-call call nil :fixed nil)
-(define-full-call call-named t :fixed nil)
-(define-full-call multiple-call nil :unknown nil)
-(define-full-call multiple-call-named t :unknown nil)
-(define-full-call tail-call nil :tail nil)
-(define-full-call tail-call-named t :tail nil)
-
-(define-full-call call-variable nil :fixed t)
-(define-full-call multiple-call-variable nil :unknown t)
-
-
-;;; Defined separately, since needs a MISCOP call that BLT's the arguments
-;;; down.
-;;;
-;;; This miscop uses a non-standard calling convention so that the argument
-;;; registers are free for loading of stack arguments.  Old-Cont, Args and the
-;;; function are passed in the registers that they will ultimately go in:
-;;; OLD-CONT, ARGS and ENV.  The Return-PC is passed in A3 rather than PC
-;;; because the BALA trashes PC.  We use BALA even though the miscop never
-;;; returns, since there isn't any BA.
-;;;
-;;; [### We could easily code inline the special case of nargs <= 3.]
-;;;
-(define-vop (tail-call-variable)
-  (:args
-   (function :scs (descriptor-reg))
-   (old-cont :scs (descriptor-reg)
-	     :target old-cont-pass)
-   (return-pc :scs (descriptor-reg)
-	      :target a3)
-   (args :scs (descriptor-reg)
-	 :target args-pass))
-  (:temporary (:sc descriptor-reg
-	       :offset old-cont-offset
-	       :from (:argument 1))
-	      old-cont-pass)
-  (:temporary (:sc descriptor-reg
-	       :offset a3-offset
-	       :from (:argument 2))
-	      a3)
-  (:temporary (:sc descriptor-reg
-	       :offset argument-pointer-offset
-	       :from (:argument 3))
-	      args-pass)
-  (:generator 75
-    (inst lr env-tn function)
-    (unless (location= old-cont old-cont-pass)
-      (inst lr old-cont-pass old-cont))
-    (unless (location= return-pc a3)
-      (inst lr a3 return-pc))
-    (unless (location= args args-pass)
-      (inst lr args-pass args))
-    (inst miscop 'clc::tail-call-variable)))
-
-
-;;;; Unknown values return:
-
-
-;;; Do unknown-values return of a fixed number of values.  The Values are
-;;; required to be set up in the standard passing locations.  Nvals is the
-;;; number of values returned.
-;;;
-;;; If returning a single value, then deallocate the current frame, restore
-;;; CONT and jump to the single-value entry at Return-PC + 4.
-;;;
-;;; If returning other than one value, then load the number of values returned,
-;;; NIL out unsupplied values registers, restore CONT and return at Return-PC.
-;;; When there are stack values, we must initialize the argument pointer to
-;;; point to the beginning of the values block (which is the beginning of the
-;;; current frame.)
-;;;
-(define-vop (return)
-  (:args
-   (old-cont :scs (descriptor-reg any-reg))
-   (return-pc :scs (descriptor-reg) :target pc-save)
-   (values :more t))
-  (:ignore values)
-  (:info nvals)
-  (:temporary (:scs (descriptor-reg) :from (:argument 0)) pc-save)
-  (:temporary (:sc descriptor-reg
-	       :offset (first register-arg-offsets)
-	       :from (:eval 0)
-	       :to (:eval 1))
-	      a0)
-  (:temporary (:sc descriptor-reg
-	       :offset (second register-arg-offsets)
-	       :from (:eval 0)
-	       :to (:eval 1))
-	      a1)
-  (:temporary (:sc descriptor-reg
-	       :offset (third register-arg-offsets)
-	       :from (:eval 0)
-	       :to (:eval 1))
-	      a2)
-  (:temporary (:sc descriptor-reg
-	       :offset argument-count-offset)
-	      nvals-loc)
-  (:temporary (:sc descriptor-reg
-	       :offset argument-pointer-offset)
-	      vals-loc)
-  (:generator 6
-    (cond ((= nvals 1)
-	   (inst lr sp-tn cont-tn)
-	   (inst inc return-pc 4)
-	   (inst bnbrx :pz return-pc)
-	   (inst lr cont-tn old-cont))
-	  (t
-	   (loadi nvals-loc nvals)
-	   (inst lr vals-loc cont-tn)
-	   (inst cal sp-tn vals-loc (* nvals 4))
-	   (inst lr cont-tn old-cont)
-
-	   (unless (location= pc-save return-pc)
-	     (inst lr pc-save return-pc))
-
-	   (when (< nvals 3)
-	     (inst cau a2 zero-tn clc::nil-16)
-	     (when (< nvals 2)
-	       (inst lr a1 a2))
-	     (when (< nvals 1)
-	       (inst lr a0 a2)))
-
-	   (inst bnbr :pz pc-save)))))
-
-
-;;; Do unknown-values return of an arbitrary number of values (passed on the
-;;; stack.)  We check for the common case of a single return value, and do that
-;;; inline using the normal single value return convention.  Otherwise, we
-;;; branch off to code that calls a miscop.
-;;;
-;;; The Return-Multiple miscop uses a non-standard calling convention.  For one
-;;; thing, it doesn't return.  We only use BALA because there isn't a BA
-;;; instruction.   Also, we don't use A0..A2 for argument passing, since the
-;;; miscop will want to load these with values off of the stack.  Instead, we
-;;; pass Old-Cont, Start and Count in the normal locations for these values.
-;;; Return-PC is passed in A3 since PC is trashed by the BALA. 
-;;;
-(define-vop (return-multiple)
-  (:args
-   (old-cont :scs (descriptor-reg) :target old-cont-pass)
-   (return-pc :scs (descriptor-reg)
-	      :target a3)
-   (start :scs (descriptor-reg)
-	  :target vals-loc)
-   (count :scs (descriptor-reg)
-	  :target nvals-loc))
-  (:temporary (:sc descriptor-reg
-	       :offset old-cont-offset
-	       :from (:argument 0))
-	      old-cont-pass)
-  (:temporary (:sc descriptor-reg
-	       :offset a3-offset
-	       :from (:argument 1))
-	      a3)
-  (:temporary (:sc descriptor-reg
-	       :offset argument-pointer-offset
-	       :from (:argument 2))
-	      vals-loc)
-  (:temporary (:sc descriptor-reg
-	       :offset argument-count-offset
-	       :from (:argument 3))
-	      nvals-loc)
-  (:temporary (:sc descriptor-reg
-	       :offset (first register-arg-offsets))
-	      a0)
-  (:node-var node)
-  (:generator 13
-    (let ((non-single (gen-label)))
-      (cmpi count 1)
-      (inst bnbx :eq non-single)
-      (loadw a0 start)
-      (inst lr sp-tn cont-tn)
-      (inst inc return-pc 4)
-      (inst bnbrx :pz return-pc)
-      (inst lr cont-tn old-cont)
-
-      (unassemble
-	(assemble-elsewhere node
-	  (emit-label non-single)
-	  (unless (location= old-cont-pass old-cont)
-	    (inst lr old-cont-pass old-cont))
-	  (unless (location= a3 return-pc)
-	    (inst lr a3 return-pc))
-	  (unless (location= vals-loc start)
-	    (inst lr vals-loc start))
-	  (unless (location= nvals-loc count)
-	    (inst lr nvals-loc count))
-	  (inst miscop 'clc::return-multiple))))))
-
-
-;;;; XEP hackery:
-
-
-(define-vop (allocate-frame)
-  (:generator 1
-    (inst cal sp-tn cont-tn (current-frame-size))))
-
-;;; Fetch the constant pool from the function entry structure.
-;;;
-(define-vop (setup-environment)
-  (:generator 5
-    (load-slot env-tn env-tn system:%function-entry-constants-slot)))
-
-;;; Return the current Env as our result, then indirect throught the closure
-;;; and the closure-entry to find the constant pool
-;;;
-(define-vop (setup-closure-environment)
-  (:results (closure :scs (descriptor-reg)))
-  (:generator 11
-    (inst lr closure env-tn)
-    (load-slot env-tn env-tn system:%function-name-slot)
-    (load-slot env-tn env-tn system:%function-entry-constants-slot)))
-
-
-;;; Copy a more arg from the argument area to the end of the current frame.
-;;; Fixed is the number of non-more arguments.  This definition and the
-;;; associated miscop assume that all the arguments and stuff are in their
-;;; passing registers, and that all other non-dedicated registers are free.
-;;;
-;;; We sleazily save the return PC in NAME so that we can do a miscop call.
-;;;
-(define-vop (copy-more-arg)
-  (:temporary (:sc descriptor-reg :offset a3-offset) a3)
-  (:temporary (:sc descriptor-reg :offset call-name-offset) name)
-  (:info fixed)
-  (:generator 20
-    (loadi a3 fixed)
-    (inst lr name pc-tn)
-    (inst miscop 'clc::copy-more-arg)
-    (inst lr pc-tn name)))
-
-
-;;; More args are stored consequtively on the stack, starting immediately at
-;;; the context pointer.
-;;;
-(define-vop (more-arg word-index-ref)
-  (:variant 0)
-  (:translate %more-arg))
-
-
-;;; Turn more arg (context, count) into a list.  Context and count are passed
-;;; in ARGS and NARGS.
-;;;
-(define-vop (listify-rest-args zero-arg-miscop)
-  (:args (context :target args :scs (any-reg descriptor-reg))
-	 (count :target nargs :scs (any-reg descriptor-reg)))
-  (:temporary (:sc any-reg
-	       :offset argument-pointer-offset
-	       :from (:argument 0)
-	       :to :eval)
-	      args)
-  (:temporary (:sc any-reg
-	       :offset argument-count-offset
-	       :from (:argument 1)
-	       :to :eval)
-	      nargs)
-  (:variant-vars)
-  (:translate %listify-rest-args)
-  (:generator 50
-    (unless (location= context args)
-      (inst lr args context))
-    (unless (location= count nargs)
-      (inst lr nargs count))
-    (inst miscop 'clc::listify-rest-args)
-    (unless (location= a0 r)
-      (inst lr r a0))))
-
-
-;;; Return the location and size of the more arg glob created by Copy-More-Arg.
-;;; Supplied is the total number of arguments supplied (originally passed in
-;;; NARGS.)  Fixed is the number of non-rest arguments.
-;;;
-;;; We must duplicate some of the work done by Copy-More-Arg, since at that
-;;; time the environment is in a pretty brain-damaged state, preventing this
-;;; info from being returned as values.  What we do is compute
-;;; supplied - fixed, and return a pointer that many words below the current
-;;; stack top.
-;;;
-(define-vop (more-arg-context)
-  (:args
-   (supplied :scs (any-reg descriptor-reg)))
-  (:info fixed)
-  (:results
-   (context :scs (descriptor-reg))
-   (count :scs (any-reg descriptor-reg)))
-  (:temporary (:scs (any-reg) :type fixnum) byte-size)
-  (:generator 5
-    (inst ai count supplied (- fixed))
-    (inst lr byte-size count)
-    (inst sli byte-size 2)
-    (inst lr context sp-tn)
-    (inst s context byte-size)))
-
-
-;;; Signal wrong argument count error if Nargs isn't = to Count.
-;;;
-(define-vop (verify-argument-count)
-  (:args
-   (nargs :scs (any-reg descriptor-reg)))
-  (:info count)
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:generator 3
-    (let ((err-lab (generate-error-code vop clc::error-wrong-number-args
-					nargs)))
-      (cmpi nargs count)
-      (inst bnb :eq err-lab))))
-
-
-;;; Signal an argument count error.
-;;;
-(define-vop (argument-count-error)
-  (:args (nargs :scs (any-reg descriptor-reg)))
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:generator 0
-    (error-call clc::error-wrong-number-args nargs)
-    (note-this-location vop :internal-error)))
diff --git a/compiler/old-rt/cell.lisp b/compiler/old-rt/cell.lisp
deleted file mode 100644
index 5e0243876401fda2fd39eb40511771eb743dc156..0000000000000000000000000000000000000000
--- a/compiler/old-rt/cell.lisp
+++ /dev/null
@@ -1,166 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    This file contains the VM definition of various primitive memory access
-;;; VOPs for the RT.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-
-;;;; Symbol hacking VOPs:
-
-;;; Do a cell ref with an error check for being unbound.
-;;;
-(define-vop (checked-cell-ref)
-  (:args (object :scs (descriptor-reg) :target obj-temp))
-  (:results (value :scs (descriptor-reg any-reg)))
-  (:policy :fast-safe)
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:temporary (:type random  :scs (non-descriptor-reg)) temp)
-  (:temporary (:scs (descriptor-reg)) obj-temp))
-
-;;; With Symbol-Value, we check that the value isn't the trap object.  So
-;;; Symbol-Value of NIL is NIL.
-;;;
-(define-vop (symbol-value checked-cell-ref)
-  (:translate symbol-value)
-  (:generator 9
-    (unless (location= obj-temp object)
-      (inst lr obj-temp object))
-    (loadw value obj-temp (/ clc::symbol-value 4))
-    (let ((err-lab (generate-error-code vop clc::error-symbol-unbound
-					obj-temp)))
-      (test-special-value value temp '%trap-object err-lab nil))))
-
-;;; With Symbol-Function, we check that the result is a function, so NIL is
-;;; always un-fbound.
-;;;
-(define-vop (symbol-function checked-cell-ref)
-  (:translate symbol-function)
-  (:generator 10
-    (unless (location= obj-temp object)
-      (inst lr obj-temp object))
-    (loadw value obj-temp (/ clc::symbol-definition 4))
-    (let ((err-lab (generate-error-code vop clc::error-symbol-undefined
-					obj-temp)))
-      (test-simple-type value temp err-lab t system:%function-type))))
-
-
-;;; Like CHECKED-CELL-REF, only we are a predicate to see if the cell is bound.
-(define-vop (boundp-frob)
-  (:args (object :scs (descriptor-reg)))
-  (:conditional)
-  (:info target not-p)
-  (:policy :fast-safe)
-  (:temporary (:scs (descriptor-reg)) value)
-  (:temporary (:type random  :scs (non-descriptor-reg)) temp))
-
-(define-vop (boundp boundp-frob)
-  (:translate boundp)
-  (:generator 9
-    (loadw value object (/ clc::symbol-value 4))
-    (test-special-value value temp '%trap-object target (not not-p))))
-
-
-;;; SYMBOL isn't a primitive type, so we can't use it for the arg restriction
-;;; on the symbol case of fboundp.  Instead, we transform to a funny function.
-
-(defknown fboundp/symbol (t) boolean (flushable))
-;;;
-(deftransform fboundp ((x) (symbol))
-  '(fboundp/symbol x))
-;;;
-(define-vop (fboundp/symbol boundp-frob)
-  (:translate fboundp/symbol)
-  (:generator 10
-    (loadw value object (/ clc::symbol-definition 4))
-    (test-simple-type value temp target not-p system:%function-type)))
-
-(def-source-transform makunbound (x)
-  `(set ,x (%primitive make-immediate-type 0 system:%trap-type)))
-
-
-(define-vop (fast-symbol-value cell-ref)
-  (:variant (/ clc::symbol-value 4))
-  (:policy :fast)
-  (:translate symbol-value))
-
-(define-vop (fast-symbol-function cell-ref)
-  (:variant (/ clc::symbol-definition 4))
-  (:policy :fast)
-  (:translate symbol-function))
-
-(define-cell-accessors (/ clc::symbol-value 4) nil nil set set)
-(define-cell-accessors (/ clc::symbol-definition 4)
-  nil nil set-symbol-function %sp-set-definition)
-(define-cell-accessors (/ clc::symbol-property-list 4)
-  symbol-plist symbol-plist set-symbol-plist %sp-set-plist)
-(define-cell-accessors (/ clc::symbol-print-name 4)
-  symbol-name symbol-name nil nil)
-(define-cell-accessors (/ clc::symbol-package 4)
-  symbol-package symbol-package set-package nil)
-
-
-(define-miscop bind (val symbol) :results ())
-(define-miscop unbind (num) :results ())
-
-
-;;;; List hackery:
-
-(define-cell-accessors (/ clc::list-car 4)
-  car car set-car %rplaca)
-(define-cell-accessors (/ clc::list-cdr 4)
-  cdr cdr set-cdr %rplacd)
-
-(define-miscop cons (x y) :translate cons)
-
-
-;;;; Value cell and closure hackery:
-
-(define-miscop make-value-cell (val))
-(define-miscop make-closure (nvars entry))
-
-(define-vop (value-cell-ref cell-ref)
-  (:variant (+ clc::g-vector-header-size-in-words
-	       system:%function-value-cell-value-slot)))
-
-(define-vop (value-cell-set cell-set)
-  (:variant (+ clc::g-vector-header-size-in-words
-	       system:%function-value-cell-value-slot)))
-
-(define-vop (closure-init slot-set))
-(define-vop (closure-ref slot-ref))
-
-
-;;;; Structure hackery:
-
-(define-vop (structure-ref slot-ref))
-(define-vop (structure-set slot-set))
-
-
-;;;; Number hackery:
-
-(define-vop (realpart cell-ref)
-  (:policy :fast-safe)
-  (:variant (/ clc::complex-realpart 4)))
-
-(define-vop (imagpart cell-ref)
-  (:policy :fast-safe)
-  (:variant (/ clc::complex-imagpart 4)))
-
-(define-vop (numerator cell-ref)
-  (:policy :fast-safe)
-  (:variant (/ clc::ratio-numerator 4)))
-
-(define-vop (denominator cell-ref)
-  (:policy :fast-safe)
-  (:variant (/ clc::ratio-denominator 4)))
diff --git a/compiler/old-rt/core.lisp b/compiler/old-rt/core.lisp
deleted file mode 100644
index 0d6aa7da059e4208f147a2e620c4beda60377411..0000000000000000000000000000000000000000
--- a/compiler/old-rt/core.lisp
+++ /dev/null
@@ -1,171 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;
-;;;    This file contains stuff that knows how to load compiled code directly
-;;; into core, e.g. incremental compilation.
-;;;
-(in-package 'c)
-
-
-;;; The CORE-OBJECT structure holds the state needed to resolve cross-component
-;;; references during in-core compilation.
-;;;
-(defstruct (core-object
-	    (:constructor make-core-object ())
-	    (:print-function
-	     (lambda (s stream d)
-	       (declare (ignore s d))
-	       (format stream "#<Core-Object>"))))
-  ;;
-  ;; A hashtable translating ENTRY-INFO structures to the corresponding actual
-  ;; FUNCTIONs for functions in this compilation.
-  (entry-table (make-hash-table :test #'eq) :type hash-table)
-  ;;
-  ;; A list of all the DEBUG-INFO objects created, kept so that we can
-  ;; backpatch with the source info.
-  (debug-info () :type list))
-
-
-;;; MAKE-FUNCTION-ENTRY  --  Internal
-;;;
-;;;    Make a function entry, filling in slots from the ENTRY-INFO.
-;;;
-(defun make-function-entry (entry code-obj code-vec object)
-  (declare (type entry-info entry) (type core-object object))
-  (let ((res (%primitive alloc-function (1+ %function-entry-type-slot))))
-    (%primitive set-vector-subtype res
-		(if (entry-info-closure-p entry)
-		    %function-closure-entry-subtype
-		    %function-entry-subtype))
-    (%primitive header-set res %function-name-slot (entry-info-name entry))
-    (%primitive header-set res %function-code-slot code-vec)
-    (%primitive header-set res %function-offset-slot
-		(+ (label-location (entry-info-offset entry))
-		   clc::i-vector-header-size))
-    (%primitive header-set res %function-entry-constants-slot code-obj)
-    (%primitive header-set res %function-entry-arglist-slot
-		(entry-info-arguments entry))
-    (%primitive header-set res %function-entry-type-slot
-		(entry-info-type entry))
-
-    (setf (gethash entry (core-object-entry-table object)) res))
-  (undefined-value))
-    
-
-;;; CORE-FUNCTION-OR-LOSE  --  Internal
-;;;
-;;;    Get the function for a function entry that has been dumped to core.
-;;;
-(defun core-function-or-lose (fun object)
-  (declare (type clambda fun) (type core-object object))
-  (let ((res (gethash (leaf-info fun) (core-object-entry-table object))))
-    (assert res () "Unresolved forward function reference?")
-    res))
-
-
-;;; DO-CORE-FIXUPS  --  Internal
-;;;
-;;;    Do "load-time" fixups on the code vector.  Currently there are only
-;;; :MISCOP fixups.
-;;;
-(defun do-core-fixups (code fixups)
-  (declare (list fixups))
-  (dolist (fixup fixups)
-    (let ((offset (second fixup))
-	  (value (third fixup)))
-      (ecase (first fixup)
-	(:miscop
-	 (let ((loaded-addr (get value 'lisp::%loaded-address)))
-	   (unless loaded-addr
-	     (error "Miscop ~A is undefined." value))
-    
-	   (let ((hi-addr (logior (ash clc::type-assembler-code
-				       clc::type-shift-16)
-				  (logand (ash loaded-addr -16) #xFFFF))))
-	     (setf (aref code (+ offset 1)) (logand hi-addr #xFF))
-	     (setf (aref code (+ offset 2))
-		   (logand (ash loaded-addr -8) #xFF))
-	     (setf (aref code (+ offset 3))
-		   (logand loaded-addr #xFF)))))))))
-
-
-;;; MAKE-CORE-COMPONENT  --  Interface
-;;;
-;;;    Dump a component to core.  We pass in the assembler fixups, code vector
-;;; and node info.
-;;;
-(defun make-core-component (component code-vector code-length
-				      node-vector nodes-length
-				      fixups object)
-  (declare (type component component) (type index nodes-length code-length)
-	   (list fixups) (type core-object object))
-  (without-gcing
-    (let* ((2comp (component-info component))
-	   (constants (ir2-component-constants 2comp))
-	   (box-num (length constants))
-	   (code-obj (%primitive alloc-function box-num))
-	   (code-vec (%primitive alloc-code code-length)))
-      (%primitive byte-blt code-vector 0 code-vec 0 code-length)
-      (%primitive header-set code-obj %function-code-slot code-vec)
-      (do-core-fixups code-vec fixups)
-      
-      (dolist (entry (ir2-component-entries 2comp))
-	(make-function-entry entry code-obj code-vec object))
-      
-      (%primitive set-vector-subtype code-obj %function-constants-subtype)
-      
-      (%primitive header-set code-obj %function-name-slot
-		  (component-name component))
-      (let ((info (debug-info-for-component component node-vector
-					    nodes-length)))
-	(push info (core-object-debug-info object))
-	(%primitive header-set code-obj %function-constants-debug-info-slot
-		    info))
-      
-      (dotimes (i box-num)
-	(let ((const (aref constants i)))
-	  (etypecase const
-	    (null)
-	    (constant
-	     (%primitive header-set code-obj i (constant-value const)))
-	    (list
-	     (ecase (car const)
-	       (:entry
-		(%primitive header-set code-obj i
-			    (core-function-or-lose (cdr const) object)))
-	       (:label
-		(%primitive header-set code-obj i
-			    (+ (label-location (cdr const))
-				clc::i-vector-header-size))))))))))
-  (undefined-value))
-
-
-;;; CORE-CALL-TOP-LEVEL-LAMBDA  --  Interface
-;;;
-;;;    Call the top-level lambda function dumped for Entry, returning the
-;;; values.
-;;;
-(defun core-call-top-level-lambda (entry object)
-  (declare (type clambda entry) (type core-object object))
-  (funcall (core-function-or-lose entry object)))
-
-
-;;; FIX-CORE-SOURCE-INFO  --  Interface
-;;;
-;;;    Backpatch all the DEBUG-INFOs dumped so far with the specified
-;;; SOURCE-INFO list.
-;;;
-(defun fix-core-source-info (info object)
-  (declare (type source-info info) (type core-object object))
-  (let ((res (debug-source-for-info info)))
-    (dolist (info (core-object-debug-info object))
-      (setf (compiled-debug-info-source info) res))
-    (setf (core-object-debug-info object) ()))
-  (undefined-value))
diff --git a/compiler/old-rt/dump.lisp b/compiler/old-rt/dump.lisp
deleted file mode 100644
index ccced97cee02255172a19f5452e7b751bf1e2074..0000000000000000000000000000000000000000
--- a/compiler/old-rt/dump.lisp
+++ /dev/null
@@ -1,1044 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;
-;;;    This file contains stuff that knows about dumping code both to files to
-;;; the running Lisp.
-;;;
-(in-package 'c)
-
-(proclaim '(special compiler-version))
-
-(import '(system:%primitive system:%array-data-slot
-			    system:%array-displacement-slot
-			    system:%g-vector-structure-subtype
-			    system:%function-constants-constants-offset))
-
-
-
-;;;; Fasl dumper state:
-
-;;; The Fasl-File structure represents everything we need to know about dumping
-;;; to a fasl file.  We need to objectify the state, since the fasdumper must
-;;; be reentrant.
-;;;
-(defstruct (fasl-file
-	    (:print-function
-	     (lambda (s stream d)
-	       (declare (ignore d))
-	       (format stream "#<Fasl-File ~S>"
-		       (namestring (fasl-file-stream s))))))
-  ;;
-  ;; The stream we dump to.
-  (stream nil :type stream)
-  ;;
-  ;; Hashtables we use to keep track of dumped constants so that we can get
-  ;; them from the table rather than dumping them again.  The EQUAL-TABLE is
-  ;; used for lists and strings, and the EQ-TABLE is used for everything else.
-  ;; We use a separate EQ table to avoid performance patholigies with objects
-  ;; for which EQUAL degnerates to EQL.  Everything entered in the EQUAL table
-  ;; is also entered in the EQ table.
-  (equal-table (make-hash-table :test #'equal) :type hash-table)
-  (eq-table (make-hash-table :test #'eq) :type hash-table)
-  ;;
-  ;; The table's current free pointer: the next offset to be used.
-  (table-free 0 :type unsigned-byte)
-  ;;
-  ;; Alist (Package . Offset) of the table offsets for each package we have
-  ;; currently located.
-  (packages () :type list)
-  ;;
-  ;; Table mapping from the Entry-Info structures for dumped XEPs to the table
-  ;; offsets of the corresponding code pointers.
-  (entry-table (make-hash-table :test #'eq) :type hash-table)
-  ;;
-  ;; Table holding back-patching info for forward references to XEPs.  The key
-  ;; is the Entry-Info structure for the XEP, and the value is a list of conses
-  ;; (<code-handle> . <offset>), where <code-handle> is the offset in the table
-  ;; of the code object needing to be patched, and <offset> is the offset that
-  ;; must be patched.
-  (patch-table (make-hash-table :test #'eq) :type hash-table)
-  ;;
-  ;; A list of the table handles for all of the DEBUG-INFO structures dumped in
-  ;; this file.  These structures must be back-patched with source location
-  ;; information when the compilation is complete.
-  (debug-info () :type list)
-  ;;
-  ;; Used to keep track of objects that we are in the process of dumping so that
-  ;; circularities can be preserved.  The key is the object that we have
-  ;; previously seen, and the value is the object that we reference in the table
-  ;; to find this previously seen object.  (The value is never NIL.)
-  ;;
-  ;; Except with list objects, the key and the value are always the same.  In a
-  ;; list, the key will be some tail of the value.
-  (circularity-table (make-hash-table :test #'eq) :type hash-table))
-
-
-;;; This structure holds information about a circularity.
-;;;
-(defstruct circularity
-  ;;
-  ;; Kind of modification to make to create circularity.
-  (type nil :type (member :rplaca :rplacd :svset))
-  ;;
-  ;; Object containing circularity.
-  object
-  ;;
-  ;; Index in object for circularity.
-  (index nil :type unsigned-byte)
-  ;;
-  ;; The object to be stored at Index in Object.  This is that the key that we
-  ;; were using when we discovered the circularity.
-  value
-  ;;
-  ;; The value that was associated with Value in the CIRCULARITY-TABLE.  This
-  ;; is the object that we look up in the EQ-TABLE to locate Value.
-  enclosing-object)
-
-
-;;; A list of the Circularity structures for all of the circularities detected
-;;; in the the current top-level call to Dump-Object.  Setting this lobotomizes
-;;; circularity detection as well, since circular dumping uses the table.
-;;;
-(defvar *circularities-detected*)
-
-
-;;; Used to inhibit table access when dumping forms to be read by the cold
-;;; loader.
-;;;
-(defvar *cold-load-dump* nil)
-
-
-;;;; Utilities:
-
-;;; Dump-Byte  --  Internal
-;;;
-;;;    Write the byte B to the specified fasl-file stream.
-;;;
-(proclaim '(inline dump-byte))
-(defun dump-byte (b file)
-  (declare (type (unsigned-byte 8) b) (type fasl-file file))
-  (write-byte b (fasl-file-stream file))
-  (undefined-value))
-
-
-;;; Dump-FOP  --  Internal
-;;;
-;;;    Dump the FOP code for the named FOP to the specified fasl-file.
-;;;
-(defun dump-fop (fs file)
-  (declare (symbol fs) (type fasl-file file))
-  (let ((val (get fs 'lisp::fop-code)))
-    (assert val () "Compiler bug: ~S not a legal fasload operator." fs)
-    (dump-byte val file))
-  (undefined-value))
-
-
-;;; Dump-FOP*  --  Internal
-;;;
-;;;    Dump a FOP-Code along with an integer argument, choosing the FOP based
-;;; on whether the argument will fit in a single byte.
-;;;
-(defmacro dump-fop* (n byte-fop word-fop file)
-  (once-only ((n-n n)
-	      (n-file file))
-    `(cond ((< ,n-n 256)
-	    (dump-fop ',byte-fop ,n-file)
-	    (dump-byte ,n-n ,n-file))
-	   (t
-	    (dump-fop ',word-fop ,n-file)
-	    (quick-dump-number ,n-n 4 ,n-file)))))
-
-
-;;; Quick-Dump-Number  --  Internal
-;;;
-;;;    Dump Num to the fasl stream, represented by the specified number of
-;;; bytes.
-;;;
-(defun quick-dump-number (num bytes file)
-  (declare (integer num) (type unsigned-byte bytes) (type fasl-file file))
-  (let ((stream (fasl-file-stream file)))
-    (do ((n num (ash n -8))
-	 (i bytes (1- i)))
-	((= i 0))
-      (write-byte (logand n #xFF) stream)))
-  (undefined-value))
-
-
-;;; Dump-Push  --  Internal
-;;;
-;;;    Push the object at table offset Handle on the fasl stack.
-;;;
-(defun dump-push (handle file)
-  (declare (type unsigned-byte handle) (type fasl-file file))
-  (dump-fop* handle lisp::fop-byte-push lisp::fop-push file)
-  (undefined-value))
-
-
-;;; Dump-Pop  --  Internal
-;;;
-;;;    Pop the object currently on the fasl stack top into the table, and
-;;; return the table index, incrementing the free pointer.
-;;;
-(defun dump-pop (file)
-  (prog1 (fasl-file-table-free file)
-    (dump-fop 'lisp::fop-pop file)
-    (incf (fasl-file-table-free file))))
-
-
-;;; EQUAL-CHECK-TABLE  --  Internal
-;;;
-;;;    If X is in File's EQUAL-TABLE, then push the object and return T,
-;;; otherwise NIL.  If *COLD-LOAD-DUMP* is true, then do nothing and return
-;;; NIL.
-;;;
-(defun equal-check-table (x file)
-  (declare (type fasl-file file))
-  (unless *cold-load-dump*
-    (let ((handle (gethash x (fasl-file-equal-table file))))
-      (cond (handle
-	     (dump-push handle file)
-	     t)
-	    (t
-	     nil)))))
-
-
-;;; EQ-SAVE-OBJECT, EQUAL-SAVE-OBJECT  --  Internal
-;;;
-;;;    These functions are called after dumping an object to save the object in
-;;; the table.  The object (also passed in as X) must already be on the top of
-;;; the FOP stack.  If *COLD-LOAD-DUMP* is true, then we don't do anything.
-;;;
-(defun eq-save-object (x file)
-  (declare (type fasl-file file))
-  (unless *cold-load-dump*
-    (let ((handle (dump-pop file)))
-      (setf (gethash x (fasl-file-eq-table file)) handle)
-      (dump-push handle file)))
-  (undefined-value))
-;;;
-(defun equal-save-object (x file)
-  (declare (type fasl-file file))
-  (unless *cold-load-dump*
-    (let ((handle (dump-pop file)))
-      (setf (gethash x (fasl-file-equal-table file)) handle)
-      (setf (gethash x (fasl-file-eq-table file)) handle)
-      (dump-push handle file)))
-  (undefined-value))
-
-
-;;; NOTE-POTENTIAL-CIRCULARITY  --  Internal
-;;;
-;;;    Record X in File's CIRCULARITY-TABLE unless *COLD-LOAD-DUMP* is true.
-;;; This is called on objects that we are about to dump might have a circular
-;;; path through them.
-;;;
-;;; The object must not currently be in this table, since the dumper should
-;;; never be recursively called on a circular reference.  Instead, the dumping
-;;; function must detect the circularity and arrange for the dumped object to
-;;; be patched.
-;;;
-(defun note-potential-circularity (x file)
-  (unless *cold-load-dump*
-    (let ((circ (fasl-file-circularity-table file)))
-      (assert (not (gethash x circ)))
-      (setf (gethash x circ) x)))
-  (undefined-value))
-
-
-;;; Fasl-Dump-Cold-Load-Form  --  Interface
-;;;
-;;;    Dump Form to a fasl file so that it evaluated at load time in normal
-;;; load and at cold-load time in cold load.  This is used to dump package
-;;; frobbing forms.
-;;;
-(defun fasl-dump-cold-load-form (form file)
-  (declare (type fasl-file file))
-  (dump-fop 'lisp::fop-normal-load file)
-  (let ((*cold-load-dump* t))
-    (dump-object form file))
-  (dump-fop 'lisp::fop-eval-for-effect file)
-  (dump-fop 'lisp::fop-maybe-cold-load file)
-  (undefined-value))
-
-
-;;;; Opening and closing:
-
-;;; Open-Fasl-File  --  Interface
-;;;
-;;;    Return a Fasl-File object for dumping to the named file.  Some
-;;; information about the source is specified by the string Where.
-;;;
-(defun open-fasl-file (name where)
-  (declare (type pathname name))
-  (let* ((stream (open name :direction :output
-		       :if-exists :new-version
-		       :element-type '(unsigned-byte 8)))
-	 (res (make-fasl-file :stream stream)))
-    (format stream
-	    "FASL FILE output from ~A.~@
-	    Compiled ~A on ~A~@
-	    Compiler ~A, Lisp ~A~@
-	    Targeted for ~A, FASL code format ~D~%"
-	    where
-	    (ext:format-universal-time nil (get-universal-time))
-	    (machine-instance) compiler-version
-	    (lisp-implementation-version) vm-version target-fasl-code-format)
-    ;;
-    ;; Terminate header.
-    (dump-byte 255 res)
-    ;;
-    ;; Specify code format.
-    (dump-fop 'lisp::fop-code-format res)
-    (dump-byte target-fasl-code-format res)
-
-    res))
-
-
-;;; Close-Fasl-File  --  Interface
-;;;
-;;;    Close the specified Fasl-File, aborting the write if Abort-P is true.
-;;; We do various sanity checks, then end the group.
-;;;
-(defun close-fasl-file (file abort-p)
-  (declare (type fasl-file file))
-  (dump-fop 'lisp::fop-verify-empty-stack file)
-  (dump-fop 'lisp::fop-verify-table-size file)
-  (quick-dump-number (fasl-file-table-free file) 4 file)
-  (dump-fop 'lisp::fop-end-group file)
-  (close (fasl-file-stream file) :abort abort-p)
-  (undefined-value))
-
-
-;;;; Component (function) dumping:
-
-;;; Dump-Code-Object  --  Internal
-;;;
-;;;    Dump out the constant pool and code-vector for component, push the
-;;; result in the table and return the offset.
-;;;
-;;;    The only tricky thing is handling constant-pool references to functions.
-;;; If we have already dumped the function, then we just push the code pointer.
-;;; Otherwise, we must create back-patching information so that the constant
-;;; will be set when the function is eventually dumped.  This is a bit awkward,
-;;; since we don't have the handle for the code object being dumped while we
-;;; are dumping its constants.
-;;;
-;;;    We dump a trap object as a placeholder for the code vector, which is
-;;; actually filled in by the loader.
-;;;
-(defun dump-code-object (component code-vector code-length node-vector
-				   nodes-length file)
-  (declare (type component component) (type fasl-file file)
-	   (simple-vector node-vector)
-	   (type unsigned-byte code-length nodes-length))
-  (let* ((2comp (component-info component))
-	 (constants (ir2-component-constants 2comp))
-	 (num-consts (length constants)))
-    (collect ((patches))
-      (dump-object (component-name component) file)
-      (dump-fop 'lisp::fop-misc-trap file)
-
-      (let ((info (debug-info-for-component component node-vector
-					    nodes-length)))
-	(dump-object info file)
-	(let ((info-handle (dump-pop file)))
-	  (dump-push info-handle file)
-	  (push info-handle (fasl-file-debug-info file))))
-
-      (do ((i %function-constants-constants-offset (1+ i)))
-	  ((= i num-consts))
-	(let ((entry (aref constants i)))
-	  (etypecase entry
-	    (constant
-	     (dump-object (constant-value entry) file))
-	    (cons
-	     (ecase (car entry)
-	       (:entry
-		(let* ((info (leaf-info (cdr entry)))
-		       (handle (gethash info (fasl-file-entry-table file))))
-		  (cond
-		   (handle
-		    (dump-push handle file))
-		   (t
-		    (patches (cons info i))
-		    (dump-fop 'lisp::fop-misc-trap file)))))
-	       (:label
-		(dump-object (+ (label-location (cdr entry))
-				clc::i-vector-header-size)
-			     file))))
-	    (null
-	     (dump-fop 'lisp::fop-misc-trap file)))))
-
-      (cond ((and (< num-consts #x100) (< code-length #x10000))
-	     (dump-fop 'lisp::fop-small-code file)
-	     (dump-byte num-consts file)
-	     (quick-dump-number code-length 2 file))
-	    (t
-	     (dump-fop 'lisp::fop-code file)
-	     (quick-dump-number num-consts 4 file)
-	     (quick-dump-number code-length 4 file)))
-      
-      (write-string code-vector (fasl-file-stream file) :end code-length)
-      
-      (let ((handle (dump-pop file)))
-	(dolist (patch (patches))
-	  (push (cons handle (cdr patch))
-		(gethash (car patch) (fasl-file-patch-table file))))
-	handle))))
-
-
-;;; Dump-Fixups  --  Internal
-;;;
-;;;    Dump all the fixups.  Currently there are only miscop fixups, and we
-;;; always access them by name rather than number.  There is no reason for
-;;; using miscop numbers other than a minor load-time efficiency win.
-;;;
-(defun dump-fixups (code-handle fixups file)
-  (declare (type unsigned-byte code-handle) (list fixups)
-	   (type fasl-file file))
-  (dump-push code-handle file)
-  (dolist (fixup fixups)
-    (let ((offset (second fixup))
-	  (value (third fixup)))
-      (ecase (first fixup)
-	(:miscop
-	 (assert (symbolp value))
-	 (dump-object value file)
-	 (dump-fop 'lisp::fop-user-miscop-fixup file)
-	 (quick-dump-number offset 4 file)))))
-
-  (dump-fop 'lisp::fop-pop-for-effect file)
-  (undefined-value))
-
-
-;;; Dump-One-Entry  --  Internal
-;;;
-;;;    Dump a function-entry data structure corresponding to Entry to File.
-;;; Code-Handle is the table offset of the code object for the component.
-;;;
-;;; If the entry is a DEFUN, then we also dump a FOP-FSET so that the cold
-;;; loader can instantiate the definition at cold-load time, allowing forward
-;;; references to functions in top-level forms.
-;;;
-(defun dump-one-entry (entry code-handle file)
-  (declare (type entry-info entry) (type unsigned-byte code-handle)
-	   (type fasl-file file))
-  (let ((name (entry-info-name entry)))
-    (dump-push code-handle file)
-    (dump-object (if (entry-info-closure-p entry)
-		     system:%function-closure-entry-subtype
-		     system:%function-entry-subtype)
-		 file)
-
-    (dump-object name file)
-    (dump-fop 'lisp::fop-misc-trap file)
-    (dump-object (+ (label-location (entry-info-offset entry))
-		    clc::i-vector-header-size)
-		 file)
-    (dump-fop 'lisp::fop-misc-trap file)
-    (dump-object (entry-info-arguments entry) file)
-    (dump-object (entry-info-type entry) file)
-    (dump-fop 'lisp::fop-function-entry file)
-    (dump-byte 6 file)
-
-    (let ((handle (dump-pop file)))
-      (when (and name (symbolp name))
-	(dump-object name file)
-	(dump-push handle file)
-	(dump-fop 'lisp::fop-fset file))
-      handle)))
-
-
-;;; Alter-Code-Object  --  Internal
-;;;
-;;;    Alter the code object referenced by Code-Handle at the specified Offset,
-;;; storing the object referenced by Entry-Handle.
-;;;
-(defun alter-code-object (code-handle offset entry-handle file)
-  (dump-push code-handle file)
-  (dump-push entry-handle file)
-  (dump-fop* offset lisp::fop-byte-alter-code lisp::fop-alter-code file)
-  (undefined-value))
-
-
-;;; Fasl-Dump-Component  --  Interface
-;;;
-;;;    Dump the code, constants, etc. for component.  We pass in the assembler
-;;; fixups, code vector and node info.
-;;;
-(defun fasl-dump-component (component code-vector code-length
-				      node-vector nodes-length
-				      fixups file)
-  (declare (type component component) (type unsigned-byte length)
-	   (list fixups) (type fasl-file file))
-
-  (dump-fop 'lisp::fop-verify-empty-stack file)
-  (dump-fop 'lisp::fop-verify-table-size file)
-  (quick-dump-number (fasl-file-table-free file) 4 file)
-
-  (let ((code-handle (dump-code-object component code-vector code-length
-				       node-vector nodes-length file))
-	(2comp (component-info component)))
-    (dump-fixups code-handle fixups file)
-    (dump-fop 'lisp::fop-verify-empty-stack file)
-
-    (dolist (entry (ir2-component-entries 2comp))
-      (let ((entry-handle (dump-one-entry entry code-handle file)))
-	(setf (gethash entry (fasl-file-entry-table file)) entry-handle)
-
-	(let ((old (gethash entry (fasl-file-patch-table file))))
-	  (when old
-	    (dolist (patch old)
-	      (alter-code-object (car patch) (cdr patch) entry-handle file))
-	    (remhash entry (fasl-file-patch-table file)))))))
-
-  (assert (zerop (hash-table-count (fasl-file-patch-table file))))
-
-  (undefined-value))
-
-
-;;; FASL-DUMP-TOP-LEVEL-LAMBDA-CALL  --  Interface
-;;;
-;;;    Dump a FOP-FUNCALL to call an already dumped top-level lambda at load
-;;; time.  
-;;;
-(defun fasl-dump-top-level-lambda-call (fun file)
-  (declare (type clambda fun) (type fasl-file file))
-  (let ((handle (gethash (leaf-info fun) (fasl-file-entry-table file))))
-    (assert handle)
-    (dump-push handle file)
-    (dump-fop 'lisp::fop-funcall-for-effect file)
-    (dump-byte 0 file))
-  (undefined-value))
-
-
-;;; FASL-DUMP-SOURCE-INFO  --  Interface
-;;;
-;;;    Compute the correct list of DEBUG-SOURCE structures and backpatch all of
-;;; the dumped DEBUG-INFO structures.  We clear the FASL-FILE-DEBUG-INFO,
-;;; so that subsequent components with different source info may be dumped.
-;;;
-(defun fasl-dump-source-info (info file)
-  (declare (type source-info info) (type fasl-file file))
-  (let ((res (debug-source-for-info info)))
-    (dump-object res file)
-    (let ((res-handle (dump-pop file)))
-      (dolist (info-handle (fasl-file-debug-info file))
-	(dump-push res-handle file)
-	(dump-fop 'lisp::fop-svset file)
-	(quick-dump-number info-handle 4 file)
-	(quick-dump-number 2 4 file))))
-
-  (setf (fasl-file-debug-info file) ())
-  (undefined-value))
-
-
-;;;; Main entries to object dumping:
-
-;;; Dump-Non-Immediate-Object  --  Internal
-;;;
-;;;    This function deals with dumping objects that are complex enough so that
-;;; we want to cache them in the table, rather than repeatedly dumping them.
-;;; If the object is in the EQ-TABLE, then we push it, otherwise, we do a type
-;;; dispatch to a type specific dumping function.  The type specific branches
-;;; do any appropriate EQUAL-TABLE check and table entry.
-;;;
-;;;    When we go to dump the object, we enter it in the CIRCULARITY-TABLE.
-;;;
-(defun dump-non-immediate-object (x file)
-  (let ((index (gethash x (fasl-file-eq-table file))))
-    (cond ((and index (not *cold-load-dump*))
-	   (dump-push index file))
-	  (t
-	   (typecase x
-	     (symbol (dump-symbol x file))
-	     (list
-	      (unless (equal-check-table x file)
-		(dump-list x file)
-		(equal-save-object x file)))
-	     (vector
-	      (cond ((stringp x)
-		     (unless (equal-check-table x file)
-		       (dump-string x file)
-		       (equal-save-object x file)))
-		    ((subtypep (array-element-type x)
-			       '(unsigned-byte 16))
-		     (dump-i-vector x file)
-		     (eq-save-object x file))
-		    (t
-		     (dump-vector x file)
-		     (eq-save-object x file))))
-	     (array
-	      (dump-array x file)
-	      (eq-save-object x file))
-	     (number
-	      (unless (equal-check-table x file)
-		(etypecase x
-		  (ratio (dump-ratio x file))
-		  (complex (dump-complex x file))
-		  (long-float (dump-long-float x file))
-		  (integer (dump-integer x file)))
-		(equal-save-object x file)))
-#|
-	     (compiled-function
-	      (dump-function x file)
-	      (eq-save-object x file))
-|#
-	     (t
-	      (compiler-error
-	       "This object cannot be dumped into a fasl file:~% ~S"
-	       x))))))
-
-  (undefined-value))
-
-
-;;; Sub-Dump-Object  --  Internal
-;;;
-;;;    Dump an object of any type by dispatching to the correct type-specific
-;;; dumping function.  We pick off immediate objects, symbols and and magic
-;;; lists here.  Other objects are handled by Dump-Non-Immediate-Object.
-;;;
-;;; This is the function used for recursive calls to the fasl dumper.  We don't
-;;; worry about creating circularities here, since it is assumed that there is
-;;; a top-level call to Dump-Object.
-;;;
-(defun sub-dump-object (x file)
-  (cond ((listp x)
-	 (cond ((null x) (dump-fop 'lisp::fop-empty-list file))
-	       #|
-	       ((eq (car x) '%eval-at-load-time) (load-time-eval x))
-	       |#
-	       (t
-		(dump-non-immediate-object x file))))
-	((symbolp x)
-	 (if (eq x t)
-	     (dump-fop 'lisp::fop-truth file)
-	     (dump-non-immediate-object x file)))
-	((fixnump x) (dump-integer x file))
-	((characterp x) (dump-character x file))
-	((typep x 'short-float) (dump-short-float x file))
-#| Probably a bug to ever dump a trap object...
-	((lisp::trap-object-p x)
-	 (dump-fop 'lisp::fop-misc-trap file))
-|#
-	(t
-	 (dump-non-immediate-object x file))))
-
-
-;;; Dump-Circularities  --  Internal
-;;;
-;;;    Dump stuff to backpatch already dumped objects.  Infos is the list of
-;;; Circularity structures describing what to do.  The patching FOPs take the
-;;; value to store on the stack.  We compute this value by fetching the
-;;; enclosing object from the table, and then CDR'ing it if necessary.
-;;;
-(defun dump-circularities (infos file)
-  (let ((table (fasl-file-eq-table file)))
-    (dolist (info infos)
-      (let* ((value (circularity-value info))
-	     (enclosing (circularity-enclosing-object info)))
-	(dump-push (gethash enclosing table) file)
-	(unless (eq enclosing value)
-	  (do ((current enclosing (cdr current))
-	       (i 0 (1+ i)))
-	      ((eq current value)
-	       (dump-fop 'lisp::fop-nthcdr file)
-	       (quick-dump-number i 4 file)))))
-      
-      (dump-fop (case (circularity-type info)
-		  (:rplaca 'lisp::fop-rplaca)
-		  (:rplacd 'lisp::fop-rplacd)
-		  (:svset 'lisp::fop-svset))
-		file)
-      (quick-dump-number (gethash (circularity-object info) table) 4 file)
-      (quick-dump-number (circularity-index info) 4 file))))
-
-
-;;; Dump-Object  -- Interface
-;;;
-;;;    Set up stuff for circularity detection, then dump an object.  All shared
-;;; and circular structure will be exactly preserved within a single call to
-;;; Dump-Object.  Sharing between objects dumped by separate calls is only
-;;; preserved when convenient.
-;;;
-;;;    We peek at the objec type so that we only pay the circular detection
-;;; overhead on types of objects that might be circular.
-;;;
-(defun dump-object (x file)
-  (if (or (arrayp x) (consp x))
-      (let ((*circularities-detected* ())
-	    (circ (fasl-file-circularity-table file)))
-	(clrhash circ)
-	(sub-dump-object x file)
-	(when *circularities-detected*
-	  (dump-circularities *circularities-detected* file)
-	  (clrhash circ)))
-      (sub-dump-object x file)))
-
-
-#|
-;;; Load-Time-Eval  --  Internal
-;;;
-;;;    This guy deals with the magical %Eval-At-Load-Time marker that
-;;; #, turns into when the *compiler-is-reading* and a fasl file is being
-;;; written.
-;;;
-(defun load-time-eval (x file)
-  (when *compile-to-lisp*
-    (compiler-error "#,~S in a bad place." (third x)))
-  (assemble-one-lambda (cadr x))
-  (dump-fop 'lisp::fop-funcall file)
-  (dump-byte 0 file))
-|#
-
-;;;; Number Dumping:
-
-;;; Dump a ratio
-
-(defun dump-ratio (x file)
-  (sub-dump-object (numerator x) file)
-  (sub-dump-object (denominator x) file)
-  (dump-fop 'lisp::fop-ratio file))
-
-;;; Or a complex...
-
-(defun dump-complex (x file)
-  (sub-dump-object (realpart x) file)
-  (sub-dump-object (imagpart x) file)
-  (dump-fop 'lisp::fop-complex file))
-
-;;; Dump an integer.
-
-(defun dump-integer (n file)
-  (let* ((bytes (compute-bytes n)))
-    (cond ((= bytes 1)
-	   (dump-fop 'lisp::fop-byte-integer file)
-	   (dump-byte (logand #xFF n) file))
-	  ((< bytes 5)
-	   (dump-fop 'lisp::fop-word-integer file)
-	   (quick-dump-number n 4 file))
-	  ((< bytes 256)
-	   (dump-fop 'lisp::fop-small-integer file)
-	   (dump-byte bytes file)
-	   (quick-dump-number n bytes file))
-	  (t (dump-fop 'lisp::fop-integer file)
-	     (quick-dump-number bytes 4 file)
-	     (quick-dump-number n bytes file)))))
-
-;;; Compute how many bytes it will take to represent signed integer N.
-
-(defun compute-bytes (n)
-  (truncate (+ (integer-length n) 8) 8))
-
-;;;
-;;; These two are almost exactly alike, and could easily be the same function.
-
-(defun dump-short-float (x file)
-  (multiple-value-bind (f exponent sign) (decode-float x)
-    (let ((mantissa (truncate (scale-float (* f sign) (float-precision f)))))
-      (dump-fop 'lisp::fop-float file)
-      (dump-byte (1+ (integer-length exponent)) file)
-      (quick-dump-number exponent (compute-bytes exponent) file)
-      (dump-byte (1+ (integer-length mantissa)) file)
-      (quick-dump-number mantissa (compute-bytes mantissa) file))))
-
-#|
-(defun dump-single-float (x file)
-  (multiple-value-bind (f exponent sign) (decode-float x)
-    (let ((mantissa (truncate (scale-float (* f sign) (float-precision f)))))
-      (dump-fop 'lisp::fop-float file)
-      (dump-byte (1+ (integer-length exponent)) file)
-      (dump-byte exponent file)
-      (dump-byte (1+ (integer-length mantissa)) file)
-      (quick-dump-number mantissa (compute-bytes mantissa) file))))
-|#
-;;; For long-floats we're careful that the dumped mantissa actually
-;;; has 63 significant bits, so the fasloader can recognize it as such.
-
-(defun dump-long-float (x file)
-  (multiple-value-bind (f exponent sign) (decode-float x)
-    (let ((mantissa (truncate (scale-float (* f sign) (float-precision f)))))
-      (dump-fop 'lisp::fop-float file)
-      (dump-byte (1+ (integer-length exponent)) file)
-      (quick-dump-number exponent (compute-bytes exponent) file)
-      (dump-byte (1+ (integer-length mantissa)) file)
-      (quick-dump-number mantissa (compute-bytes mantissa) file))))
-
-
-;;;; Symbol Dumping:
-
-;;; Dump-Package  --  Internal
-;;;
-;;;    Return the table index of Pkg, adding the package to the table if
-;;; necessary.  During cold load, we read the string as a normal string so that
-;;; we can do the package lookup at cold load time.
-;;;
-(defun dump-package (pkg file)
-  (cond ((cdr (assoc pkg (fasl-file-packages file))))
-	(t
-	 (unless *cold-load-dump*
-	   (dump-fop 'lisp::fop-normal-load file))
-	 (dump-string (package-name pkg) file)
-	 (dump-fop 'lisp::fop-package file)
-	 (unless *cold-load-dump*
-	   (dump-fop 'lisp::fop-maybe-cold-load file))
-	 (let ((entry (dump-pop file)))
-	   (push (cons pkg entry) (fasl-file-packages file))
-	   entry))))
-
-
-;;; Dump-Symbol  --  Internal
-;;;
-;;;    If we get here, it is assumed that the symbol isn't in the table, but we
-;;; are responsible for putting it there when appropriate.  To avoid too much
-;;; special-casing, we always push the symbol in the table, but don't record
-;;; that we have done so if *Cold-Load-Dump* is true.
-;;;
-(defun dump-symbol (s file)
-  (let* ((pname (symbol-name s))
-	 (pname-length (length pname))
-	 (pkg (symbol-package s)))
-
-    (cond ((null pkg)
-	   (dump-fop* pname-length lisp::fop-uninterned-small-symbol-save
-		      lisp::fop-uninterned-symbol-save file))
-	  ((eq pkg *package*)
-	   (dump-fop* pname-length lisp::fop-small-symbol-save
-		      lisp::fop-symbol-save file))
-	  ((eq pkg ext:*lisp-package*)
-	   (dump-fop* pname-length lisp::fop-lisp-small-symbol-save
-		      lisp::fop-lisp-symbol-save file))
-	  ((eq pkg ext:*keyword-package*)
-	   (dump-fop* pname-length lisp::fop-keyword-small-symbol-save
-		      lisp::fop-keyword-symbol-save file))
-	  ((< pname-length 256)
-	   (dump-fop* (dump-package pkg file)
-		      lisp::fop-small-symbol-in-byte-package-save
-		      lisp::fop-small-symbol-in-package-save file)
-	   (dump-byte pname-length file))
-	  (t
-	   (dump-fop* (dump-package pkg file)
-		      lisp::fop-symbol-in-byte-package-save
-		      lisp::fop-symbol-in-package-save file)
-	   (quick-dump-number pname-length 4 file)))
-
-    (write-string pname (fasl-file-stream file))
-
-    (unless *cold-load-dump*
-      (setf (gethash s (fasl-file-eq-table file)) (fasl-file-table-free file)))
-
-    (incf (fasl-file-table-free file)))
-
-  (undefined-value))
-
-
-;;; Dumper for lists.
-
-;;; Dump-List  --  Internal
-;;;
-;;;    Dump a list, setting up patching information when there are
-;;; circularities.  We scan down the list, checking for CDR and CAR
-;;; circularities.
-;;;
-;;; If there is a CDR circularity, we terminate the list with NIL and make a
-;;; Circularity notation for the CDR of the previous cons.
-;;;
-;;; If there is no CDR circularity, then we mark the current cons and check for
-;;; a CAR circularity.  When there is a CAR circularity, we make the CAR NIL
-;;; initially, arranging for the current cons to be patched later.
-;;;
-;;; Otherwise, we recursively call the dumper to dump the current element.
-;;;
-;;; Marking of the conses is inhibited when *cold-load-dump* is true.  This
-;;; inhibits all circularity detection.
-;;;
-(defun dump-list (list file)
-  (assert (and list
-	       (not (gethash list (fasl-file-circularity-table file)))))
-  (do* ((l list (cdr l))
-	(n 0 (1+ n))
-	(circ (fasl-file-circularity-table file)))
-       ((atom l)
-	(cond ((null l)
-	       (terminate-undotted-list n file))
-	      (t
-	       (sub-dump-object l file)
-	       (terminate-dotted-list n file))))
-
-    (let ((ref (gethash l circ)))
-      (when ref
-	(push (make-circularity :type :rplacd  :object list  :index (1- n)
-				:value l  :enclosing-object ref)
-	      *circularities-detected*)
-	(terminate-undotted-list n file)
-	(return)))
-
-    (unless *cold-load-dump*
-      (setf (gethash l circ) list))
-
-    (let* ((obj (car l))
-	   (ref (gethash obj circ)))
-      (cond (ref
-	     (push (make-circularity :type :rplaca  :object list  :index n
-				     :value obj  :enclosing-object ref)
-		   *circularities-detected*)
-	     (sub-dump-object nil file))
-	    (t
-	     (sub-dump-object obj file))))))
-
-
-(defun terminate-dotted-list (n file)
-  (case n
-    (1 (dump-fop 'lisp::fop-list*-1 file))
-    (2 (dump-fop 'lisp::fop-list*-2 file))
-    (3 (dump-fop 'lisp::fop-list*-3 file))
-    (4 (dump-fop 'lisp::fop-list*-4 file))
-    (5 (dump-fop 'lisp::fop-list*-5 file))
-    (6 (dump-fop 'lisp::fop-list*-6 file))
-    (7 (dump-fop 'lisp::fop-list*-7 file))
-    (8 (dump-fop 'lisp::fop-list*-8 file))
-    (T (do ((nn n (- nn 255)))
-	   ((< nn 256)
-	    (dump-fop 'lisp::fop-list* file)
-	    (dump-byte nn file))
-	 (dump-fop 'lisp::fop-list* file)
-	 (dump-byte 255 file)))))
-
-;;; If N > 255, must build list with one list operator, then list* operators.
-
-(defun terminate-undotted-list (n file)
-    (case n
-      (1 (dump-fop 'lisp::fop-list-1 file))
-      (2 (dump-fop 'lisp::fop-list-2 file))
-      (3 (dump-fop 'lisp::fop-list-3 file))
-      (4 (dump-fop 'lisp::fop-list-4 file))
-      (5 (dump-fop 'lisp::fop-list-5 file))
-      (6 (dump-fop 'lisp::fop-list-6 file))
-      (7 (dump-fop 'lisp::fop-list-7 file))
-      (8 (dump-fop 'lisp::fop-list-8 file))
-      (T (cond ((< n 256)
-		(dump-fop 'lisp::fop-list file)
-		(dump-byte n file))
-	       (t (dump-fop 'lisp::fop-list file)
-		  (dump-byte 255 file)
-		  (do ((nn (- n 255) (- nn 255)))
-		      ((< nn 256)
-		       (dump-fop 'lisp::fop-list* file)
-		       (dump-byte nn file))
-		    (dump-fop 'lisp::fop-list* file)
-		    (dump-byte 255 file)))))))
-
-;;;; Array dumping:
-
-;;; Named G-vectors get their subtype field set at load time.
-
-(defun dump-vector (obj file)
-  (cond ((and (simple-vector-p obj)
-	      (= (%primitive get-vector-subtype obj)
-		 %g-vector-structure-subtype))
-	 (normal-dump-vector obj file)
-	 (dump-fop 'lisp::fop-structure file))
-	(t
-	 (normal-dump-vector obj file))))
-
-(defun normal-dump-vector (v file)
-  (note-potential-circularity v file)
-  (do ((index 0 (1+ index))
-       (length (length v))
-       (circ (fasl-file-circularity-table file)))
-      ((= index length)
-       (dump-fop* length lisp::fop-small-vector lisp::fop-vector file))
-    (let* ((obj (aref v index))
-	   (ref (gethash obj circ)))
-      (cond (ref
-	     (push (make-circularity :type :svset  :object v  :index index
-				     :value obj  :enclosing-object ref)
-		   *circularities-detected*)
-	     (sub-dump-object nil file))
-	    (t
-	     (sub-dump-object obj file))))))
-
-;;; Dump a string.
-
-(defun dump-string (s file)
-  (let ((length (length s)))
-    (dump-fop* length lisp::fop-small-string lisp::fop-string file)
-    (dotimes (i length)
-      (dump-byte (char-code (char s i)) file))))
-
-;;; Dump-Array  --  Internal
-;;;
-;;;    Dump a multi-dimensional array.  Someday when we figure out what
-;;; a displaced array looks like, we can fix this.
-;;;
-(defun dump-array (array file)
-  (unless (zerop (%primitive header-ref array %array-displacement-slot))
-    (compiler-error
-     "Attempt to dump an array with a displacement, you lose big."))
-  (let ((rank (array-rank array)))
-    (dotimes (i rank)
-      (dump-integer (array-dimension array i) file))
-    (sub-dump-object (%primitive header-ref array %array-data-slot) file)
-    (dump-fop 'lisp::fop-array file)
-    (quick-dump-number rank 4 file)))
-
-;;; Dump-I-Vector  --  Internal  
-;;;
-;;;    Dump an I-Vector using the Guy Steele memorial fasl-operation.
-;;;
-(defun dump-i-vector (vec file)
-  (let* ((len (length vec))
-	 (ac (%primitive get-vector-access-code
-			 (if #-new-compiler (%primitive complex-array-p vec)
-			     #+new-compiler (array-header-p vec)
-			     (%primitive header-ref vec %array-data-slot)
-			     vec)))
-	 (size (ash 1 ac))
-	 (count (ceiling size 8))
-	 (ints-per-entry (floor (* count 8) size)))
-    (declare (fixnum len ac size count ints-per-entry))
-    (dump-fop 'lisp::fop-int-vector file)
-    (quick-dump-number len 4 file)
-    (dump-byte size file)
-    (dump-byte count file)
-    (if (> ints-per-entry 1)
-	(do ((prev 0 end)
-	     (end ints-per-entry (the fixnum (+ end ints-per-entry))))
-	    ((>= end len)
-	     (unless (= prev len)
-	       (do ((pos (* (1- ints-per-entry) size) (- pos size))
-		    (idx prev (1+ idx))
-		    (res 0))
-		   ((= idx len)
-		    (dump-byte res file))
-		 (setq res (dpb (aref vec idx) (byte size pos) res)))))
-	  (declare (fixnum prev end))
-	  (do* ((idx prev (1+ idx))
-		(res 0))
-	       ((= idx end)
-		(dump-byte res file))
-	    (declare (fixnum idx))
-	    (setq res (logior (ash res size) (aref vec idx)))))
-	(dotimes (i len)
-	  (declare (fixnum i))
-	  (quick-dump-number (aref vec i) count file)))))
-
-;;; Dump a character.
-
-(defun dump-character (ch file)
-  (cond
-   ((string-char-p ch)
-    (dump-fop 'lisp::fop-short-character file)
-    (dump-byte (char-code ch) file))
-   (t
-    (dump-fop 'lisp::fop-character file)
-    (dump-byte (char-code ch) file)
-    (dump-byte (char-bits ch) file)
-    (dump-byte (char-font ch) file))))
diff --git a/compiler/old-rt/fop.lisp b/compiler/old-rt/fop.lisp
deleted file mode 100644
index 07a75553f2fb2827a2d60eca501fd9bcfe93ced7..0000000000000000000000000000000000000000
--- a/compiler/old-rt/fop.lisp
+++ /dev/null
@@ -1,14 +0,0 @@
-;;;
-;;; Define new FOPs for bootstrapping...
-
-(in-package 'lisp)
-
-(eval-when (compile load eval)
-
-  (clone-fop (fop-alter-code 140) (fop-byte-alter-code 141)
-   )
-
-  (define-fop (fop-function-entry 142)
-   )
-
-); Eval-When (Compile load Eval)
diff --git a/compiler/old-rt/genesis.lisp b/compiler/old-rt/genesis.lisp
deleted file mode 100644
index fea92810141e2415f97aaf1553a1c01a7ae6366e..0000000000000000000000000000000000000000
--- a/compiler/old-rt/genesis.lisp
+++ /dev/null
@@ -1,1571 +0,0 @@
-;;; -*- Package: Lisp; Log: C.Log -*-
-
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; Core image builder for Spice Lisp.
-;;; Written by Skef Wholey.  Package hackery courtesy of Rob MacLachlan.
-;;;
-;;; We gobble up FASL files, building a virtual memory image in a collection
-;;; of blocks in system table space.  When we're done and wish to write out the
-;;; file, we allocate a block large enough to hold the contents of the memory
-;;; image, and twiddle the page map to map the parts of the image consecutively
-;;; into this large block, which we then write out as a file.
-;;;
-
-(in-package "LISP")
-
-;;; Hack version that accepts NFASL file type...
-
-#-new-compiler
-(defun load (filename &key ((:verbose *load-verbose*) *load-verbose*)
-		      ((:print *load-print-stuff*) *load-print-stuff*)
-		      (if-does-not-exist :error))
-  "Loads the file named by Filename into the Lisp environment.  See manual
-   for details."
-  (let ((*package* *package*))
-    (if (streamp filename)
-	(if (equal (stream-element-type filename) '(unsigned-byte 8))
-	    (fasload filename)
-	    (sloload filename))
-	(let* ((pn (merge-pathnames (pathname filename)
-				    *default-pathname-defaults*))
-	       (tn (probe-file pn)))
-	  (cond
-	   (tn
-	    (if (or (string-equal (pathname-type tn) "fasl")
-		    (string-equal (pathname-type tn) "nfasl"))
-		(with-open-file (file tn
-				      :direction :input
-				      :element-type '(unsigned-byte 8))
-		  (fasload file))
-		(with-open-file (file tn :direction :input)
-		  (sloload file)))
-	    t)
-	   ((pathname-type pn)
-	    (let ((stream (open pn :direction :input
-				:if-does-not-exist if-does-not-exist)))
-	      (when stream
-		(sloload stream)
-		(close stream)
-		t)))
-	   (t
-	    (let* ((srcn (make-pathname :type "lisp" :defaults pn))
-		   (src (probe-file srcn))
-		   (objn (make-pathname :type "fasl" :defaults pn))
-		   (obj (probe-file objn)))
-	      (cond
-	       (obj
-		(cond ((and src (> (file-write-date src)
-				   (file-write-date obj)))
-		       (case *load-if-source-newer*
-			 (:load-object
-			  (warn "Loading object file ~A, which is~%  ~
-			         older than the presumed source, ~A."
-				(namestring obj)
-				(namestring src))
-			  (load obj))
-			 (:load-source
-			  (warn "Loading source file ~A, which is~%  ~
-			         newer than the presumed object file, ~A."
-				(namestring src)
-				(namestring obj))
-			  (load src))
-			 (:compile
-			  (compile-file (namestring src))
-			  (load obj))
-			 (:query
-			  (if (y-or-n-p "Load source file ~A which is newer~%  ~
-					 than presumed object file ~A? "
-					(namestring src)
-					(namestring obj))
-			      (load src)
-			      (load obj)))
-			 (T (error "*Load-if-source-newer* contains ~A which is not one of:~%  ~
-			            :load-object, :load-source, :compile, or :query."
-				   *load-if-source-newer*))))
-		      (T (load obj))))
-	       (t
-		(load srcn :if-does-not-exist if-does-not-exist))))))))))
-
-
-(eval-when (compile load eval)
-  (defconstant type-shift 11)
-  (defconstant type-space-shift 9)
-  (defconstant type-space-byte (byte 7 9))
-  (defconstant high-data-byte (byte 11 16))
-  (defconstant high-data-mask 511)
-  (defconstant space-right-shift -9)
-)
-
-(defvar *external-references* ()
-  "List of reference frobs made by assembler routines that have been cold loaded.")
-
-(defvar machine-code-buffer
-  (make-array 2048 :element-type '(unsigned-byte 8))
-  "Buffer for machine code for genesis of the Romp")
-
-(defconstant cold-i-vector-header-size 8
-  "Size of an i-vector.")
-
-(defvar *cold-map-file* nil)
-(defvar *defined-functions* nil)
-
-;;; Head of list of functions to be called when the Lisp starts up.
-;;;
-(defvar current-init-functions-cons)
-
-
-;;; True if we are in the cold loader.  Used by FOP-MAYBE-COLD-LOAD in
-;;; the normal loader.
-;;;
-(proclaim '(special *in-cold-load*))
-
-
-;;; Memory accessing.
-
-;;; The virtual address space is divided into 128 pieces.
-
-(defparameter number-of-spaces 512 "Number of pointer-type spaces.")
-
-;;; The initial size of spaces will be one megabyte.  If we need more than this,
-;;; the following constant will have to be changed.
-
-(defparameter space-size (ash 1 21) "Number of bytes in each space.")
-
-;;; Each space is represented as a structure containing the address of its
-;;; data in system space and the number of bytes used so far in it.
-
-(defstruct (space (:print-function print-a-space))
-  address
-  real-address
-  free-pointer)
-
-(defun print-a-space (space stream depth)
-  depth
-  (write-string "#<SPACE, address = " stream)
-  (prin1 (sap-int (space-address space)) stream)
-  (write-char #\> stream))
-
-;;; The type codes:
-
-(eval-when (compile load eval)
-  (defparameter +-fixnum-ltype 0)
-  (defparameter gc-forward-ltype 1) 
-  (defparameter trap-ltype 4)
-  (defparameter bignum-ltype 5)
-  (defparameter ratio-ltype 6)
-  (defparameter complex-ltype 7)
-  (defparameter short-float-low-ltype 8)
-  (defparameter short-float-high-ltype 9)
-  (defparameter short-float-4bit-ltype 4)
-  (defparameter long-float-ltype 10)
-  (defparameter string-ltype 11)
-  (defparameter bit-vector-ltype 12)
-  (defparameter integer-vector-ltype 13)
-  (defparameter code-ltype 14)
-  (defparameter general-vector-ltype 15)
-  (defparameter array-ltype 16)
-  (defparameter function-ltype 17)
-  (defparameter symbol-ltype 18)
-  (defparameter list-ltype 19)
-  (defparameter control-stack-ltype 20)
-  (defparameter binding-stack-ltype 21)
-  (defparameter assembly-code-ltype 0)
-
-  (defparameter string-char-ltype 26)
-  (defparameter bitsy-char-ltype 27)
-  (defparameter values-marker-ltype 28)
-  (defparameter catch-all-ltype 29)
-  (defparameter --fixnum-ltype 31)
-  (defparameter smallest-ltype +-fixnum-ltype)
-  (defparameter largest-ltype binding-stack-ltype)
-  (defparameter first-pointer-ltype 0))
-
-(defmacro space-to-highbits (space)
-  `(ash ,space 9))
-
-;;; The subspace codes:
-
-(defparameter dynamic-space 0)
-(defparameter static-space 2)
-(defparameter read-only-space 3)
-
-;;; Lispobj-Shift is the number of places we shift left to convert an index
-;;; into an offset we can do address calculation with.
-
-(defconstant lispobj-shift 2)
-
-;;; Lispobj-Size is the number of glomps it takes to represent a Lisp object.
-
-(defconstant lispobj-size 4)
-
-;;; Macros to construct space numbers from a type and subspace.
-
-(defmacro dynamic (type)
-  `(logior (ash ,type 2) dynamic-space))
-
-(defmacro static (type)
-  `(logior (ash ,type 2) static-space))
-
-(defmacro read-only (type)
-  `(logior (ash ,type 2) read-only-space))
-
-;;; Used-Spaces is a list of the spaces we allocate stuff for.
-
-(defparameter used-spaces
-  (list (dynamic code-ltype)
-	(dynamic bit-vector-ltype)
-	(dynamic integer-vector-ltype)
-	(dynamic string-ltype)
-	(dynamic bignum-ltype)
-	(static bignum-ltype)
-	(dynamic long-float-ltype)
-	(dynamic complex-ltype)
-	(dynamic ratio-ltype)
-	(dynamic general-vector-ltype)
-	(dynamic function-ltype)
-	(dynamic array-ltype)
-	(dynamic symbol-ltype)
-	(static symbol-ltype)
-	(dynamic list-ltype)
-	(static list-ltype)
-	(dynamic trap-ltype)
-	(dynamic assembly-code-ltype)))
-
-;;; Memory is a vector of these spaces.  If a space is non-existent or is not
-;;; used in cold load, NIL will be stored in the corresponding location instead
-;;; of a space structure.
-
-(defvar memory (make-array number-of-spaces))
-
-(defparameter code-space (dynamic assembly-code-ltype))
-
-(defvar *genesis-memory-initialized* nil)
-
-;;; In order to allow access of symbols that weren't dumped in normal load, we
-;;; maintain a back-translation from handles to symbols.  This is a vector of
-;;; vectors, indexed first by space code, and then by the offset (in units of
-;;; symbol size).
-;;;
-(defvar *space-to-symbol-array*)
-
-
-(defun initialize-memory ()
-  (unless *genesis-memory-initialized*
-    (setq *genesis-memory-initialized* t)
-    (setq *space-to-symbol-array* (make-array 4))
-    (setf (svref *space-to-symbol-array* 0) (make-array 10000))
-    (setf (svref *space-to-symbol-array* 1) nil)
-    (setf (svref *space-to-symbol-array* 2) (make-array 5000))
-    (setf (svref *space-to-symbol-array* 3) (make-array 500))
-    (do* ((spaces used-spaces (cdr spaces))
-	  (space (car spaces) (car spaces)))
-	 ((null spaces))
-      (declare (list spaces))
-      (multiple-value-bind (hunk addr)
-			   (get-valid-hunk
-			    (if (= space (dynamic code-ltype))
-				(ash space-size 3)
-				space-size))
-	(setf (svref memory space)
-	      (make-space :address (int-sap hunk)
-			  :real-address (int-sap addr)
-			  :free-pointer (cons (if (eq space code-space)
-						  clc::romp-code-base
-						  (space-to-highbits space))
-					      0)))))))
-
-
-(defun get-valid-hunk (size)
-  (let ((addr (do-validate 0 size -1)))
-    (values addr addr)))
-
-(defun initialize-spaces ()
-  (do* ((spaces used-spaces (cdr spaces))
-	(space (car spaces) (car spaces)))
-      ((null spaces))
-    (declare (list spaces))
-    (setf (space-free-pointer (svref memory space))
-	  (cons (if (eq space code-space)
-		    clc::romp-code-base
-		    (space-to-highbits space)) 0))))
-
-;;; Since Spice Lisp objects are 32-bits wide, and Spice Lisp integers are only
-;;; 28-bits wide, we use the following scheme to represent the 32-bit objects
-;;; in the image being built.  In the core image builder, we can have a handle
-;;; on a 32-bit object, which is a cons of two 16-bit numbers, the high order
-;;; word in the CAR, and the low order word in the CDR.  We provide some macros
-;;; to manipulate these handles.
-
-(defmacro handle-on (high low)
-  `(cons ,high ,low))
-
-(defun handle-beyond (handle offset)
-  (let ((new (+ (cdr handle) offset)))
-    (if (> new 65535)
-	(cons (+ (car handle) (ash new -16)) (logand new 65535))
-	(cons (car handle) new))))
-
-(defun bump-handle (handle offset)
-  (let ((new (+ (cdr handle) offset)))
-    (if (> new 65535)
-	(setf (car handle) (+ (car handle) (ash new -16))
-	      (cdr handle) (logand new 65535))
-	(setf (cdr handle) new))))
-
-(defun copy-handle (handle)
-  (cons (car handle) (cdr handle)))
-
-(defun handle< (han1 han2)
-  (or (< (car han1) (car han2))
-      (and (= (car han1) (car han2))
-	   (< (cdr han1) (cdr han2)))))
-
-;;; Handle-Offset is used to map a virtual address into an offset into the table
-;;; of 16-bit words we're building of objects of that type.  Blah blah.
-
-;;; The LDM is a byte-addressed machine, so we shift the offset bits right 1.
-
-(defun handle-offset (handle)
-  (logior (ash (logand (car handle) high-data-mask) 15) (ash (cdr handle) -1)))
-
-(defun handle-type (handle)
-  (ash (car handle) (- type-shift)))
-
-(defmacro build-object (type bits)
-  `(let ((bits ,bits))
-     (handle-on (logior (ash ,type type-shift) (ldb high-data-byte bits))
-		(logand bits 65535))))
-
-(defmacro build-sub-object (type subtype bits)
-  `(let ((bits ,bits))
-     (handle-on (logior (ash ,type type-shift)
-			(logior (ash ,subtype 8) (ldb (byte 8 16) bits)))
-		(logand bits 65535))))
-
-(defparameter trap-handle
-  (handle-on (space-to-highbits (dynamic trap-ltype)) 0000)
-  "Handle on the trap object.")
-
-(defparameter nil-handle (handle-on (space-to-highbits (static list-ltype)) 0000)
-  "Handle on Nil.")
-
-(defparameter zero-handle (handle-on 0 0))
-
-#|
-(defmacro byte-swap-16 (object)
-  `(let ((obj ,object))
-     (logior (ash (logand obj #xFF) 8)
-	     (logand (ash obj -8) #xFF))))
-|#
-
-(defmacro byte-swap-16 (object) object)
-
-;;; Write-Memory writes the Object (identified by a handle) into the given
-;;; Address (also a handle).
-
-(defun write-memory (address object)
-  (let* ((high (car address))
-	 (low (cdr address))
-	 (space-number (ldb type-space-byte high))
-	 (offset (handle-offset address))
-	 (space (svref memory space-number)))
-    (when (eq space-number code-space)
-      (decf offset (ash clc::romp-code-base 15)))
-    (if space
-	(if (handle< address (space-free-pointer space))
-	    (let ((saddress (space-address space)))
-	      (%primitive 16bit-system-set saddress offset
-			  (byte-swap-16 (car object)))
-	      (%primitive 16bit-system-set saddress (1+ offset)
-			  (byte-swap-16 (cdr object))))
-	    (error "No object at ~S,,~S has been allocated." high low))
-	(error "The space for address ~S,,~S does not exist." high low))))
-
-;;; Read-Memory returns a handle to an object read from the given Address.
-
-(defun read-memory (address)
-  (let* ((high (car address))
-	 (low (cdr address))
-	 (space-number (ldb type-space-byte high))
-	 (offset (handle-offset address))
-	 (space (svref memory space-number)))
-    (when (eq space-number code-space)
-      (decf offset (ash clc::romp-code-base 15)))
-    (if space
-	(if (handle< address (space-free-pointer space))
-	    (let ((saddress (space-address space)))
-	      (handle-on (byte-swap-16 (%primitive 16bit-system-ref
-						   saddress offset))
-			 (byte-swap-16 (%primitive 16bit-system-ref
-						   saddress (1+ offset)))))
-	    (error "No object at ~S,,~S has been allocated." high low))
-	(error "The space for address ~S,,~S does not exist." high low))))
-
-;;; Read-Indexed is used to read from g-vector-like things.
-
-(defun read-indexed (address index)
-  (read-memory (handle-beyond address
-			      (+ (ash index lispobj-shift) lispobj-size))))
-
-;;; Write-Indexed is used to write into g-vector-like things.
-
-(defun write-indexed (address index value)
-  (write-memory (handle-beyond address (+ (ash index lispobj-shift) lispobj-size))
-		value))
-
-;;; Allocating primitive objects.
-
-;;; Allocate-Boxed-Object returns a handle to an object allocated in the
-;;; space of the given Space-Number with the given Length.  No header words are
-;;; initialized, and the Length should include the length of the header.  The
-;;; free pointer for the Space is incremented and (on the Perq) quadword alligned.
-
-(defun allocate-boxed-object (space-number length)
-  (let ((space (svref memory space-number)))
-    (if space
-	(let* ((start (space-free-pointer space))
-	       (result (copy-handle start)))
-	  (bump-handle start (ash length lispobj-shift))
-	  result)
-	(error "Space ~S does not exist." space-number))))
-
-;;; Allocate-Unboxed-Object returns a handle to an object allocated in the
-;;; space of the given Space-Number with the given Byte-Size and Length in
-;;; bytes of that size.  The 2 unboxed object header words are initialized
-;;; with the optional Subtype code.
-
-(defun allocate-unboxed-object (space-number byte-size size subtype)
-  (let ((space (svref memory space-number)))
-    (if space
-	(let* ((start (space-free-pointer space))
-	       (result (copy-handle start))
-	       (length (+ 2 (ceiling size (/ 32 byte-size)))))
-	  (bump-handle start (ash length lispobj-shift))
-	  (write-memory result
-			(build-sub-object +-fixnum-ltype subtype length))
-	  (write-memory (handle-beyond result lispobj-size)
-			(handle-on (logior (ash (access-type byte-size) 12)
-					   (logand (ash size -16) #xFFF))
-				   (logand size #xFFFF)))
-	  result)
-	(error "Space ~S does not exist." space-number))))
-
-;;; Access-Type returns the I-Vector access type for a given Byte-Size.
-
-(defun access-type (byte-size)
-  (let ((access-type (cdr (assoc byte-size '((1 . 0) (2 . 1) (4 . 2)
-					     (8 . 3) (16 . 4) (32 . 5)
-					     (64 . 6) (128 . 7))))))
-    (if access-type access-type
-	(error "Invalid I-Vector byte size, ~S." byte-size))))
-
-;;; I-Vector-To-Core copies the contents of the given unboxed thing into
-;;; the virtual memory image in the space with the give Space-Number, returning
-;;; a handle to the new object.
-
-(defun i-vector-to-core (space-number byte-size size subtype thing)
-  (let* ((dest (allocate-unboxed-object space-number byte-size size subtype))
-	 (byte-count (ash (ceiling size (/ 16 byte-size)) 1))
-	 (offset (handle-offset dest))
-	 (dest-byte-addr (+ offset offset 8)))
-    (%primitive byte-blt
-		thing 0
-		(space-address (svref memory space-number))
-		dest-byte-addr (+ dest-byte-addr byte-count))
-    dest))
-
-;;; Dump a dynamic string.
-
-(defun string-to-core (string)
-  (i-vector-to-core (dynamic string-ltype) 8 (length string) 0 string))
-
-;;; Dump a bignum.
-(defun bignum-to-core (n)
-  (let* ((words (1+ (ceiling (1+ (integer-length n)) 32)))
-	 (handle (allocate-boxed-object (dynamic bignum-ltype) words)))
-    (declare (fixnum words))
-    (write-memory handle (build-sub-object (if (< n 0) --fixnum-ltype
-					       +-fixnum-ltype)
-					   0 words))
-    (do ((i 1 (1+ i))
-	 (half 2 (+ half 2)))
-	((= i words)
-	 handle)
-      (declare (fixnum i half))
-      (write-memory (handle-beyond handle (* lispobj-size i))
-		    (handle-on (%primitive 16bit-system-ref n half)
-			       (%primitive 16bit-system-ref n (1+ half)))))))
-			       
-;;; Number-To-Core copies the given number to the virtual memory image,
-;;; returning a handle to it.
-
-(defun number-to-core (thing)
-  (typecase thing
-    (fixnum (handle-on (logand (ash thing -16) 65535)
-		       (logand thing 65535)))
-    (bignum (bignum-to-core thing))
-    (short-float
-     (let ((fthing (%primitive make-fixnum thing)))
-       (handle-on (logior (ash short-float-4bit-ltype 12)
-			  (%primitive logldb 12 16 fthing)
-			  (if (< thing 0) #x800 0))
-		  (logand fthing #xFFFF))))
-    (long-float
-     (let* ((handle (allocate-boxed-object (dynamic long-float-ltype) 3)))
-       (write-memory handle zero-handle)
-       (write-memory (handle-beyond handle lispobj-size)
-		     (handle-on (%primitive 16bit-system-ref thing 2)
-				(%primitive 16bit-system-ref thing 3)))
-       (write-memory (handle-beyond handle (+ lispobj-size lispobj-size))
-		     (handle-on (%primitive 16bit-system-ref thing 4)
-				(%primitive 16bit-system-ref thing 5)))
-       handle))
-    (t (error "~S isn't a cold-loadable number at all!" thing))))
-
-;;; Allocate-G-Vector allocates a G-Vector of the given Length and writes
-;;; the header word.
-
-(defun allocate-g-vector (space-number length &optional (subtype 0))
-  (let* ((length (+ length 1))
-	 (dest (allocate-boxed-object space-number length)))
-    (write-memory dest (build-sub-object +-fixnum-ltype subtype length))
-    dest))
-
-;;; Cold-Set-Vector-Subtype frobs the subtype field of an already allocated
-;;; G-Vector.
-
-(defun cold-set-vector-subtype (vector subtype)
-  (let ((handle (read-memory vector)))
-    (write-memory vector (build-sub-object +-fixnum-ltype subtype
-					   (logior (logand high-data-mask
-							   (car handle))
-						   (cdr handle))))
-    vector))
-
-;;; Allocate-Cons allocates a cons and fills it with the given stuff.
-
-(defun allocate-cons (space-number car cdr)
-  (let ((dest (allocate-boxed-object space-number 2)))
-    (write-memory dest car)
-    (write-memory (handle-beyond dest lispobj-size) cdr)
-    dest))
-
-;;; Cold-Put  --  Internal
-;;;
-;;;    Add a property to a symbol in the core.  Assumes it doesn't exist.
-;;;
-(defun cold-put (symbol indicator value)
-  (let ((plist-handle (handle-beyond symbol (* 2 lispobj-size))))
-    (write-memory plist-handle
-		  (allocate-cons
-		   (dynamic list-ltype) indicator
-		   (allocate-cons
-		    (dynamic list-ltype) value
-		    (read-memory plist-handle))))))
-
-;;; Allocate-Symbol allocates a symbol and fills its print name cell and
-;;; property list cell.
-
-(defparameter *cold-symbol-allocation-space* (dynamic symbol-ltype))
-
-(defun allocate-symbol (name &optional (symbol nil defined))
-  (declare (simple-string name))
-  (let ((dest (allocate-boxed-object *cold-symbol-allocation-space* 5)))
-    (write-memory dest trap-handle)
-    (write-memory (handle-beyond dest lispobj-size) trap-handle)
-    (write-memory (handle-beyond dest (* 2 lispobj-size)) nil-handle)
-    (write-memory (handle-beyond dest (* 3 lispobj-size))
-      (i-vector-to-core (dynamic string-ltype) 8 (length name) 0 name))
-    (if defined
-	(add-symbol-to-handle-map dest symbol)
-	(write-memory (handle-beyond dest (* 4 lispobj-size)) nil-handle))
-    dest))
-
-
-(defmacro cold-push (thing list)
-  "Generates code to push the Thing onto the given cold load List."
-  `(setq ,list (allocate-cons (dynamic list-ltype) ,thing ,list)))
-
-
-;;;; Interning.
-
-;;;    In order to avoid having to know about the package format, we
-;;; build a data structure which we stick in *cold-symbols* that
-;;; holds all interned symbols along with info about their packages.
-;;; The data structure is a list of lists in the following format:
-;;;   (<make-package-arglist>
-;;;    <internal-symbols>
-;;;    <external-symbols>
-;;;    <imported-internal-symbols>
-;;;    <imported-external-symbols>
-;;;    <shadowing-symbols>)
-;;;
-;;;    Package manipulation forms are dumped magically by the compiler
-;;; so that we can eval them at Genesis time.  An eval-for-effect fop
-;;; is used, surrounded by fops that switch the fop table to the hot
-;;; fop table and back.
-;;;
-
-;;; An alist from packages to the list of symbols in that package to be
-;;; dumped.
-;;;
-(defvar *cold-packages*)
-
-
-;;; Symbols known to the microcode that must be allocated before all others.
-;;; DON'T CHANGE the order of these UNLESS you know what you are doing.
-(defparameter initial-symbols
-  '(t %sp-internal-apply %sp-internal-error %sp-software-interrupt-handler
-      %sp-internal-throw-tag %initial-function %link-table-header
-      current-allocation-space %sp-bignum/fixnum %sp-bignum/bignum
-      %sp-fixnum/bignum %sp-abs-ratio %sp-abs-complex %sp-negate-ratio
-      %sp-negate-complex %sp-integer+ratio %sp-ratio+ratio %sp-complex+number
-      %sp-number+complex %sp-complex+complex %sp-1+ratio %sp-1+complex
-      %sp-integer-ratio %sp-ratio-integer %sp-ratio-ratio %sp-complex-number 
-      %sp-number-complex %sp-complex-complex %sp-1-ratio %sp-1-complex
-      %sp-integer*ratio %sp-ratio*ratio %sp-number*complex %sp-complex*number
-      %sp-complex*complex %sp-integer/ratio %sp-ratio/integer %sp-ratio/ratio 
-      %sp-number/complex %sp-complex/number %sp-complex/complex
-      %sp-integer-truncate-ratio %sp-ratio-truncate-integer
-      %sp-ratio-truncate-ratio %sp-number-truncate-complex
-      %sp-complex-truncate-number %sp-complex-truncate-complex maybe-gc
-      lisp-environment-list call-lisp-from-c lisp-command-line-list
-      *nameserverport* *ignore-floating-point-underflow*
-      %sp-sin-rational %sp-sin-short %sp-sin-long %sp-sin-complex
-      %sp-cos-rational %sp-cos-short %sp-cos-long %sp-cos-complex
-      %sp-tan-rational %sp-tan-short %sp-tan-long %sp-tan-complex
-      %sp-atan-rational %sp-atan-short %sp-atan-long %sp-atan-complex
-      %sp-exp-rational %sp-exp-short %sp-exp-long %sp-exp-complex
-      %sp-log-rational %sp-log-short %sp-log-long %sp-log-complex
-      lisp::%sp-sqrt-rational lisp::%sp-sqrt-short
-      lisp::%sp-sqrt-long lisp::%sp-sqrt-complex
-      eval::*eval-stack-top*
-      ))
-
-
-;;; Cold-Intern  --  Internal
-;;;
-;;;    Return a handle on an interned symbol.  If necessary allocate
-;;; the symbol and record which package the symbol was referenced in.
-;;; When we allocate the symbol, make sure we record a reference to
-;;; the symbol in the home package so that the package gets set.
-;;;
-(defun cold-intern (symbol package)
-  (let ((cold-info (get symbol 'cold-info)))
-    (unless cold-info
-      (cond ((eq (symbol-package symbol) package)
-	     (let ((handle (allocate-symbol (symbol-name symbol) symbol)))
-	       (when (eq package *keyword-package*) (write-memory handle handle))
-	       (setq cold-info (setf (get symbol 'cold-info) (cons handle nil)))))
-	    (t
-	     (cold-intern symbol (symbol-package symbol))
-	     (setq cold-info (get symbol 'cold-info)))))
-    (unless (memq package (cdr cold-info))
-      (push package (cdr cold-info))
-      (push symbol (cdr (or (assq package *cold-packages*)
-			    (car (push (list package) *cold-packages*))))))
-    (car cold-info)))
-
-
-(defun add-symbol-to-handle-map (handle symbol)
-  (let* ((space (logand (ash (car handle) space-right-shift) #x3))
-	 (index (truncate (logior (ash (logand (car handle) #x007F) 16)
-				  (logand (cdr handle) #xFFFF))
-			  20))
-	 (vector (svref *space-to-symbol-array* space)))
-    (setf (svref vector index) symbol)))
-
-
-(defun find-cold-symbol (handle)
-  (let* ((space (logand (ash (car handle) space-right-shift) #x3))
-	 (index (truncate (logior (ash (logand (car handle) #x007F) 16)
-				  (logand (cdr handle) #xFFFF))
-			  20))
-	 (vector (svref *space-to-symbol-array* space)))
-    (svref vector index)))
-
-
-;;; Initialize-Symbols  --  Internal
-;;;
-;;;    Since the initial symbols must be allocated before we can intern
-;;; anything else, we intern those here.  We also set the values of T and Nil.
-;;;
-(defun initialize-symbols ()
-  "Initilizes the cold load symbol-hacking data structures."
-  ;; Special case NIL.
-  (let ((*cold-symbol-allocation-space* (static list-ltype))
-	(nil-fcn-handle (handle-beyond nil-handle lispobj-size)))
-    (cold-intern nil *lisp-package*)
-    (write-memory nil-fcn-handle nil-handle))
-  (let ((*cold-symbol-allocation-space* (static symbol-ltype)))
-    (dolist (symbol initial-symbols)
-      (cold-intern symbol *lisp-package*)))
-  (write-memory nil-handle nil-handle)
-  (write-memory (cold-intern t *lisp-package*) (cold-intern t *lisp-package*)))
-
-
-;;; Finish-Symbols  --  Internal
-;;;
-;;;    Scan over all the symbols referenced in each package in *cold-packages*
-;;; making the apropriate entry in the *initial-symbols* data structure to
-;;; intern the thing.
-;;;
-(defun finish-symbols ()
-  (let ((res nil-handle))
-    (dolist (cpkg *cold-packages*)
-      (let* ((pkg (car cpkg))
-	     (shadows (package-shadowing-symbols pkg)))
-	(let ((internal nil-handle)
-	      (external nil-handle)
-	      (imported-internal nil-handle)
-	      (imported-external nil-handle)
-	      (shadowing nil-handle))
-	  (dolist (sym (cdr cpkg))
-	    (let ((handle (car (get sym 'cold-info))))
-	      (multiple-value-bind (found where)
-				   (find-symbol (symbol-name sym) pkg)
-		(unless (and where (eq found sym))
-		  (error "Symbol ~S is not available in ~S." sym pkg))
-		(when (memq sym shadows)
-		  (cold-push handle shadowing))
-		(ecase where
-		  (:internal
-		   (if (eq (symbol-package sym) pkg)
-		       (cold-push handle internal)
-		       (cold-push handle imported-internal)))
-		  (:external
-		   (if (eq (symbol-package sym) pkg)
-		       (cold-push handle external)
-		       (cold-push handle imported-external)))
-		  (:inherited)))))
-	  (let ((r nil-handle))
-	    (cold-push shadowing r)
-	    (cold-push imported-external r)
-	    (cold-push imported-internal r)
-	    (cold-push external r)
-	    (cold-push internal r)
-	    (cold-push (make-make-package-args pkg) r)
-	    (cold-push r res)))))
-    
-    (write-memory (cold-intern '*initial-symbols* *lisp-package*) res)))
-
-
-;;; Make-Make-Package-Args  --  Internal
-;;;
-;;;    Make a cold list that can be used as the arglist to make-package to
-;;; make a similar package.
-;;;
-(defun make-make-package-args (package)
-  (let* ((use nil-handle)
-	 (nicknames nil-handle)
-	 (res nil-handle))
-    (dolist (u (package-use-list package))
-      (when (assoc u *cold-packages*)
-	(cold-push (string-to-core (package-name u)) use)))
-    (dolist (n (package-nicknames package))
-      (cold-push (string-to-core n) nicknames))
-    (cold-push (number-to-core (truncate (internal-symbol-count package) 0.8)) res)
-    (cold-push (cold-intern :internal-symbols *keyword-package*) res)
-    (cold-push (number-to-core (truncate (external-symbol-count package) 0.8)) res)
-    (cold-push (cold-intern :external-symbols *keyword-package*) res)
-
-    (cold-push nicknames res)
-    (cold-push (cold-intern :nicknames *keyword-package*) res)
-
-    (cold-push use res)
-    (cold-push (cold-intern :use *keyword-package*) res)
-    
-    (cold-push (string-to-core (package-name package)) res)
-    res))
-
-
-;;;; Static bignum initialization:
-
-;;; Initialize-bignums sets up the least-positive bignum and least-negative
-;;; bignum in static bignum space.
-
-(defun initialize-bignums ()
-  (let ((lpb-handle (allocate-boxed-object (static bignum-ltype) 2))
-	(lnb-handle (allocate-boxed-object (static bignum-ltype) 2))
-	(least-positive-bignum (1+ most-positive-fixnum))
-	(least-negative-bignum (1- most-negative-fixnum)))
-    (write-memory lpb-handle (build-sub-object +-fixnum-ltype 0 2))
-    (write-memory (handle-beyond lpb-handle 4)
-		  (handle-on (ash least-positive-bignum -16)
-			     (logand least-positive-bignum #xFFFF)))
-    (write-memory lnb-handle (build-sub-object --fixnum-ltype 0 2))
-    (write-memory (handle-beyond lnb-handle 4)
-		  (handle-on (ash least-negative-bignum -16)
-			     (logand least-negative-bignum #xFFFF)))))
-
-
-;;; Initialize-Trap-Object  --  Internal
-;;;
-;;;    Allocate the trap object and initialize it so that calls to it jump to
-;;; the TRAP-ERROR-HANDLER routine.
-;;;
-(defun initialize-trap-object ()
-  (let ((obj (allocate-g-vector (dynamic trap-ltype) 3))
-	(addr (miscop-address 'clc::trap-error-handler)))
-    (write-indexed obj %function-code-slot
-		   (handle-on (ldb (byte 16 16) addr)
-			      (ldb (byte 16 0) addr)))
-    (write-indexed obj %function-offset-slot (number-to-core 0))))
-
-
-;;; Reading FASL files.
-
-(defvar cold-fop-functions (replace (make-array 256) fop-functions)
-  "FOP functions for cold loading.")
-
-(defvar normal-fop-functions)
-
-;;; Define-Cold-FOP  --  Internal
-;;;
-;;;    Like Define-FOP in load, but looks up the code, and stores into
-;;; the cold-fop-functions vector.
-;;;
-(defmacro define-cold-fop ((name &optional (pushp t)) &rest forms)
-  (let ((fname (concat-pnames 'cold- name))
-	(code (get name 'fop-code)))
-    (unless code (error "~S is not a defined fop." name))
-    `(progn
-      (defun ,fname ()
-	,(if (eq pushp :nope)
-	     `(progn ,@forms)
-	     `(with-fop-stack ,pushp ,@forms)))
-      (setf (svref cold-fop-functions ,code) #',fname))))
-
-;;; Clone-Cold-FOP  --  Internal
-;;;
-;;;    Clone a couple of cold fops.
-;;;
-(defmacro clone-cold-fop ((name &optional (pushp t)) (small-name) &rest forms)
-  `(progn
-    (macrolet ((clone-arg () '(read-arg 4)))
-      (define-cold-fop (,name ,pushp) ,@forms))
-    (macrolet ((clone-arg () '(read-arg 1)))
-      (define-cold-fop (,small-name ,pushp) ,@forms))))
-
-;;; Not-Cold-Fop  --  Internal
-;;;
-;;;    Define a fop to be undefined in cold load.
-;;;
-(defmacro not-cold-fop (name)
-  `(define-cold-fop (,name)
-     (error "~S is not supported in cold load." ',name)))
-
-;;;; Random cold fops...
-
-(define-cold-fop (fop-misc-trap) trap-handle)
-
-(define-cold-fop (fop-character)
-  (build-object bitsy-char-ltype (read-arg 3)))
-(define-cold-fop (fop-short-character)
-  (build-object string-char-ltype (read-arg 1)))
-
-(define-cold-fop (fop-empty-list) nil-handle)
-(define-cold-fop (fop-truth) (cold-intern 't *lisp-package*))
-
-(define-cold-fop (fop-normal-load :nope)
-  (setq fop-functions normal-fop-functions))
-
-(define-cold-fop (fop-maybe-cold-load :nope))
-
-(define-cold-fop (fop-structure)
-  (cold-set-vector-subtype (pop-stack) 1))
-
-
-;;;; Loading symbols...
-
-;;; Cold-Load-Symbol loads a symbol N characters long from the File and interns
-;;; that symbol in the given Package.
-;;;
-(defun cold-load-symbol (size package)
-  (let ((string (make-string size)))
-    (read-n-bytes *fasl-file* string 0 size)
-    (cold-intern (intern string package) package)))
-
-(clone-cold-fop (fop-symbol-save)
-		(fop-small-symbol-save)
-  (push-table (cold-load-symbol (clone-arg) *package*)))
-
-(macrolet ((frob (name pname-len package-len)
-	     `(define-cold-fop (,name)
-		(let ((index (read-arg ,package-len)))
-		  (push-table
-		   (cold-load-symbol (read-arg ,pname-len)
-				     (svref *current-fop-table* index)))))))
-  (frob fop-symbol-in-package-save 4 4)
-  (frob fop-small-symbol-in-package-save 1 4)
-  (frob fop-symbol-in-byte-package-save 4 1)
-  (frob fop-small-symbol-in-byte-package-save 1 1))
-
-(clone-cold-fop (fop-lisp-symbol-save)
-		(fop-lisp-small-symbol-save)
-  (push-table (cold-load-symbol (clone-arg) *lisp-package*)))
-
-(clone-cold-fop (fop-keyword-symbol-save)
-		(fop-keyword-small-symbol-save)
-  (push-table (cold-load-symbol (clone-arg) *keyword-package*)))
-
-(clone-cold-fop (fop-uninterned-symbol-save)
-		(fop-uninterned-small-symbol-save)
-  (let* ((size (clone-arg))
-	 (name (make-string size)))
-    (read-n-bytes *fasl-file* name 0 size)
-    (let ((symbol (allocate-symbol name)))
-      (push-table symbol))))
-
-
-;;; Loading lists...
-
-;;; Cold-Stack-List makes a list of the top Length things on the Fop-Stack.
-;;; The last cdr of the list is set to Last.
-
-(defmacro cold-stack-list (length last)
-  `(do* ((index ,length (1- index))
-	 (result ,last (allocate-cons (dynamic list-ltype) (pop-stack) result)))
-	((= index 0) result)
-     (declare (fixnum index))))
-
-(define-cold-fop (fop-list)
-  (cold-stack-list (read-arg 1) nil-handle))
-(define-cold-fop (fop-list*)
-  (cold-stack-list (read-arg 1) (pop-stack)))
-(define-cold-fop (fop-list-1)
-  (cold-stack-list 1 nil-handle))
-(define-cold-fop (fop-list-2)
-  (cold-stack-list 2 nil-handle))
-(define-cold-fop (fop-list-3)
-  (cold-stack-list 3 nil-handle))
-(define-cold-fop (fop-list-4)
-  (cold-stack-list 4 nil-handle))
-(define-cold-fop (fop-list-5)
-  (cold-stack-list 5 nil-handle))
-(define-cold-fop (fop-list-6)
-  (cold-stack-list 6 nil-handle))
-(define-cold-fop (fop-list-7)
-  (cold-stack-list 7 nil-handle))
-(define-cold-fop (fop-list-8)
-  (cold-stack-list 8 nil-handle))
-(define-cold-fop (fop-list*-1)
-  (cold-stack-list 1 (pop-stack)))
-(define-cold-fop (fop-list*-2)
-  (cold-stack-list 2 (pop-stack)))
-(define-cold-fop (fop-list*-3)
-  (cold-stack-list 3 (pop-stack)))
-(define-cold-fop (fop-list*-4)
-  (cold-stack-list 4 (pop-stack)))
-(define-cold-fop (fop-list*-5)
-  (cold-stack-list 5 (pop-stack)))
-(define-cold-fop (fop-list*-6)
-  (cold-stack-list 6 (pop-stack)))
-(define-cold-fop (fop-list*-7)
-  (cold-stack-list 7 (pop-stack)))
-(define-cold-fop (fop-list*-8)
-  (cold-stack-list 8 (pop-stack)))
-
-
-;;;; Loading vectors...
-
-(clone-cold-fop (fop-string)
-		(fop-small-string)
-  (let* ((len (clone-arg))
-	 (string (make-string len)))
-    (read-n-bytes *fasl-file* string 0 len)
-    (i-vector-to-core (dynamic string-ltype) 8 len 0 string)))
-
-(clone-cold-fop (fop-vector)
-		(fop-small-vector)
-  (let ((size (clone-arg)))
-    (do ((index (1- size) (1- index))
-	 (result (allocate-g-vector (dynamic general-vector-ltype) size)))
-	((< index 0) result)
-      (declare (fixnum index))
-      (write-indexed result index (pop-stack)))))
-
-
-(define-cold-fop (fop-int-vector :nope)
-  (fop-int-vector)
-  (with-fop-stack t
-    (let ((res (pop-stack)))
-      (i-vector-to-core (if (typep res 'simple-bit-vector)
-			    (dynamic bit-vector-ltype)
-			    (dynamic integer-vector-ltype))
-			(ash 1 (%primitive get-vector-access-code res))
-			(length res)
-			0
-			res))))
-			
-
-(not-cold-fop fop-uniform-vector)
-(not-cold-fop fop-small-uniform-vector)
-(not-cold-fop fop-uniform-int-vector)
-(not-cold-fop fop-array)
-
-
-;;;; Fixing up circularities.
-
-(define-cold-fop (fop-rplaca nil)
-  (let ((obj (svref *current-fop-table* (read-arg 4)))
-	(idx (read-arg 4)))
-    (write-memory (cold-nthcdr idx obj) (pop-stack))))
-
-(define-cold-fop (fop-rplacd nil)
-  (let ((obj (svref *current-fop-table* (read-arg 4)))
-	(idx (read-arg 4)))
-    (write-memory (handle-beyond (cold-nthcdr idx obj) lispobj-size)
-		  (pop-stack))))
-
-(define-cold-fop (fop-svset nil)
-  (let ((obj (svref *current-fop-table* (read-arg 4)))
-	(idx (read-arg 4)))
-    (write-indexed obj idx (pop-stack))))
-
-(define-cold-fop (fop-nthcdr t)
-  (cold-nthcdr (read-arg 4) (pop-stack)))
-
-
-(defun cold-nthcdr (index obj)
-  (do ((i 0 (1+ i))
-       (r obj))
-      ((>= i index) r)
-    (setq r (read-memory (handle-beyond r lispobj-size)))))
-
-
-;;;; Calling (or not calling).
-
-(not-cold-fop fop-alter)
-(not-cold-fop fop-eval)
-(not-cold-fop fop-eval-for-effect)
-(not-cold-fop fop-funcall)
-
-(define-cold-fop (fop-funcall-for-effect nil)
-  (if (= (read-arg 1) 0)
-      (cold-push (pop-stack) current-init-functions-cons)
-      (error "Can't FOP-FUNCALL random stuff in cold load.")))
-
-
-
-;;; Loading assembler code:
-
-
-(defun maybe-grow-machine-code-buffer (length)
-  (if (> length (length machine-code-buffer))
-      (setq machine-code-buffer
-	    (make-array (logand (+ length 2047) (lognot 2047))
-			:element-type '(unsigned-byte 8)))))
-
-
-;;; Define-Cold-Labels  --  Internal
-;;;
-;;;    Stick the addresses of some labels on the plists.  We do this
-;;; in the core being built as well so that the normal loader can
-;;; load assembler code.  %Loaded-Address is a byte offset.
-;;;
-(defun define-cold-labels (start external-labels)
-  (let ((prop (cold-intern '%loaded-address *lisp-package*)))
-    (dolist (lab external-labels)
-      (let ((addr (+ start (cdr lab)))
-	    (name (car lab)))
-	(setf (get name '%address) addr)
-	(cold-put (cold-intern name (symbol-package name))
-		  prop (number-to-core (ash addr 1)))))))
-
-
-(defun miscop-address (name)
-  (ash (or (get name '%address)
-	   (error "Miscop ~A doesn't seem to be defined." name))
-       1))
-
-(define-cold-fop (fop-assembler-routine t)
-  (let* ((code-start (copy-handle
-		      (space-free-pointer
-		       (svref memory code-space))))
-	 (start (- (ash (handle-offset code-start) 1)
-		   (ash clc::romp-code-base 16)))
-	 (code-length (read-arg 4)))
-    (declare (fixnum code-length))
-    ;; Zap the code into the core image:
-    (maybe-grow-machine-code-buffer code-length)
-    (read-n-bytes *fasl-file* machine-code-buffer 0 code-length)
-    (%primitive byte-blt machine-code-buffer 0
-		(space-real-address (svref memory code-space))
-		start (+ start code-length))
-    (bump-handle (space-free-pointer (svref memory code-space)) code-length)
-    code-start))
-
-
-;;; Fixup-Assembler-Code  --  Internal
-;;;
-;;;    Since we now always access miscops through their name, we don't need to
-;;; discriminate between assembler routines and miscops.  So we have one
-;;; function that does both kinds of fixups.
-;;;
-(defun fixup-assembler-code ()
-  (with-fop-stack nil
-    (let* ((external-references (pop-stack))
-	   (external-labels (pop-stack))
-	   (name (pop-stack))
-	   (code-start (pop-stack))
-	   (start (handle-offset code-start)))
-      (define-cold-labels start external-labels)
-      (push (cons name external-references) *external-references*))))
-
-(define-cold-fop (fop-fixup-miscop-routine :nope)
-  (fixup-assembler-code))
-
-(define-cold-fop (fop-fixup-assembler-routine :nope)
-  (fixup-assembler-code))
-
-(not-cold-fop fop-fixup-user-miscop-routine)
-
-
-;;; Loading functions...
-
-
-;;; Cold-Load-Function loads a code object (constant pool and code vector).
-;;; Box-Num objects are popped off the stack for the boxed storage section,
-;;; then Code-Length bytes are read in and made into the code vector.
-
-(defun cold-load-function (box-num code-length)
-  (declare (fixnum box-num code-length))
-  (with-fop-stack t
-    (let ((function (allocate-g-vector (dynamic function-ltype) box-num))
-	  (code (%primitive alloc-i-vector code-length 3)))
-      ;;
-      ;; Pop boxed stuff, storing it in the allocated function object.
-      (do ((index (1- box-num) (1- index)))
-	  ((minusp index))
-	(write-indexed function index (pop-stack)))
-      ;;
-      ;; Set Code object subtype.
-      (cold-set-vector-subtype function %function-constants-subtype)
-      ;;
-      ;; Read in code, dump it, and store code pointer.
-      (read-n-bytes *fasl-file* code 0 code-length)
-      (let ((code-handle (i-vector-to-core (dynamic code-ltype)
-					   8 code-length 1 code)))
-	(write-indexed function %function-code-slot code-handle))
-      function)))
-
-(define-cold-fop (fop-code :nope)
-  (if (eql *current-code-format* c::target-fasl-code-format)
-      (cold-load-function (read-arg 4) (read-arg 4))
-      (error "~S: Bad code format for this implementation"
-	     *current-code-format*)))
-
-(define-cold-fop (fop-small-code :nope)
-  (if (eql *current-code-format* c::target-fasl-code-format)
-      (cold-load-function (read-arg 1) (read-arg 2))
-      (error "~S: Bad code format for this implementation"
-	     *current-code-format*)))
-
-
-;;; Kind of like Cold-Load-Function, except that we set the Code and Constants
-;;; slots from the Constants object that is our first stack argument.  The
-;;; subtype is set to the second stack argument.
-;;;
-;;; We make an entry in the *Defined-Functions* for benefit of the map file.
-;;; If the entry's Name is a symbol (meaning the function is a DEFUN), then
-;;; dump that name, otherwise we say UNKNOWN-FUNCTION.
-;;;
-(define-cold-fop (fop-function-entry)
-  (let* ((box-num (read-arg 1))
-	 (function (allocate-g-vector (dynamic function-ltype) box-num)))
-    ;;
-    ;; Pop boxed things, storing them in the allocated function object.
-    (do ((index (1- box-num) (1- index)))
-	((minusp index))
-      (write-indexed function index (pop-stack)))
-    ;;
-    ;; Set the subtype of the function object.  The subtype should be a small
-    ;; fixnum, so its value is the cdr of the handle...
-    (cold-set-vector-subtype function (cdr (pop-stack)))
-
-    (let* ((constants-handle (pop-stack))
-	   (code-handle (read-indexed constants-handle %function-code-slot))
-	   (offset-handle (read-indexed function %function-offset-slot))
-	   (offset (logior (ash (car offset-handle) 16) (cdr offset-handle))))
-      (write-indexed function %function-code-slot code-handle)
-      (write-indexed function %function-entry-constants-slot constants-handle)
-
-      (let ((name-handle (read-indexed function %function-name-slot)))
-	(push (list (if (= (handle-type name-handle) symbol-ltype)
-			(find-cold-symbol name-handle)
-			'unknown-function)
-		    function
-		    (handle-beyond code-handle offset))
-	      *defined-functions*)))
-
-    function))
-
-
-(define-cold-fop (fop-fset nil)
-  (let ((function (pop-stack)))
-    (write-memory (handle-beyond (pop-stack) lispobj-size) function)))
-
-
-(define-cold-fop (fop-user-miscop-fixup)
-  (let* ((name (find-cold-symbol (pop-stack)))
-	 (function-object (pop-stack))
-	 (offset (read-arg 4))
-	 (miscop-address (miscop-address name))
-	 (addr-high (ldb (byte 16 16) miscop-address))
-	 (addr-low (ldb (byte 16 0) miscop-address))
-	 (code-handle (read-indexed function-object %function-code-slot)))
-    
-    (bump-handle code-handle (+ cold-i-vector-header-size offset))
-    (let ((inst (read-memory code-handle)))
-      (write-memory code-handle
-		    (handle-on (logior (logand (car inst) #xFF00)
-				       (logand addr-high #xFF))
-			       addr-low)))
-    function-object))
-
-
-;;; Modify a slot in a Constants object.
-;;;
-(clone-cold-fop (fop-alter-code nil) (fop-byte-alter-code)
-  (let ((value (pop-stack))
-	(code (pop-stack))
-	(index (clone-arg)))
-    (write-indexed code index value)))
-
-
-;;; Loading numbers...
-
-(define-cold-fop (fop-float :nope)
-  (fop-float)
-  (with-fop-stack t (number-to-core (pop-stack))))
-
-(clone-cold-fop (fop-integer)
-		(fop-small-integer)
-  (number-to-core (load-s-integer (clone-arg))))
-
-(define-cold-fop (fop-word-integer)
-  (number-to-core (load-s-integer 4)))
-
-(define-cold-fop (fop-byte-integer)
-  (let ((byte (load-s-integer 1)))
-    (build-object (if (< byte 0) --fixnum-ltype +-fixnum-ltype) byte)))
-
-(define-cold-fop (fop-ratio)
-  (let ((dest (allocate-boxed-object (dynamic ratio-ltype) 2))
-	(den (pop-stack)))
-    (write-memory dest (pop-stack))
-    (write-memory (handle-beyond dest lispobj-size) den)
-    dest))
-
-(define-cold-fop (fop-complex)
-  (let ((dest (allocate-boxed-object (dynamic complex-ltype) 2))
-	(im (pop-stack)))
-    (write-memory dest (pop-stack))
-    (write-memory (handle-beyond dest lispobj-size) im)
-    dest))
-
-
-
-;;; Resolving all the assembler routines' references.
-
-(defmacro create-assembler-handle (address)
-  `(handle-on (logior (ash ,assembly-code-ltype type-shift)
-		      (logand (ash ,address -15) high-data-mask))
-	      (logand (ash ,address 1) #xFFFF)))
-
-;;; Recall that the format of a reference is (How Label Location),
-;;; where How is one of JI, BI, BA, or L, Label is the label's name, and
-;;; Location is the location of the reference.  These things are stored on
-;;; the list *external-references* as (Name . References), where Name is
-;;; the name of the referencing routine, and References is a list of references
-;;; in the above format.
-
-(defun resolve-references ()
-  (dolist (reflist *external-references*)
-    (let ((address (get (car reflist) '%address)))
-      (dolist (refs (cdr reflist))
-	(let ((how (car refs))
-	      (label (get (cadr refs) '%address))
-	      (location (caddr refs)))
-	  (if (null label)
-	      (format t "~A references ~A, which has not been defined.~%"
-		      (car reflist) (cadr refs))
-	      (ecase how
-		(clc::ji
-		 (resolve-ji-reference (car reflist) address (cadr refs)
-				       label location))
-		(clc::bi
-		 (resolve-bi-reference (car reflist) address (cadr refs)
-				       label location))
-		(clc::ba
-		 (resolve-ba-reference (car reflist) address (cadr refs)
-					  label location)))))))))
-
-
-(defun resolve-ji-reference (routine-name address label-name label location)
-  (let* ((handle (handle-beyond (create-assembler-handle address)
-			       (ash location 1)))
-	 (offset (- label (handle-offset handle)))
-	 (inst (read-memory handle)))
-    (if (or (< offset #x-80) (> offset #x7F))
-	(format t "Offset #X~X out of JI range for ~A to reference ~A.~%"
-		offset routine-name label-name))
-    (write-memory handle
-		  (handle-on (logior (logand (car inst) #xFF00)
-				     (logand offset #xFF))
-			     (cdr inst)))))
-
-(defun resolve-bi-reference (routine-name address label-name label location)
-  (let* ((handle (handle-beyond (create-assembler-handle address)
-				(ash location 1)))
-	 (offset (- label (handle-offset handle)))
-	 (inst (read-memory handle)))
-    (if (or (< offset #x-80000) (> offset #x7FFFF))
-	(format t "Offset #X~X out of BI range for ~A to reference ~A.~%"
-		offset routine-name label-name))
-    (write-memory handle (handle-on (logior (logand (car inst) #xFFF0)
-					    (logand (ash offset -16) #xF))
-				    (logand offset #xFFFF)))))
-
-(defun resolve-ba-reference (routine-name address label-name label location)
-  (let* ((handle (handle-beyond (create-assembler-handle address)
-				(ash location 1)))
-	 (l-handle (create-assembler-handle label))
-	 (l-addr (ash (logior (ash (car l-handle) 15) (cdr l-handle)) -1))
-	 (inst (read-memory handle)))
-    (if (> l-addr #xFFFFFF)
-	(format t "Address #X~X is out of BA range for ~A to reference ~A.~%"
-		l-addr routine-name label-name))
-    (write-memory handle
-		  (handle-on (logior (logand (car inst) #xFF00)
-				     (logand (ash l-addr -16) #xFF))
-			     (logand l-addr #xFFFF)))))
-
-;;; Writing the core file.
-
-;;; We assume here that the directory will fit on one page, make the
-;;; alloc table be the first data page, and make the escape routine table
-;;; the second data page.  So the length of the file is the length of all
-;;; of the stuff in the used spaces plus 3 pages.
-
-(eval-when (compile load eval)
-  (defconstant offset-to-page-shift -13)
-  (defconstant page-to-offset-shift 13)
-  (defconstant process-page-shift -4)
-  (defconstant extra-pages 1)
-  (defconstant alloc-table-data-start 4096)
-  (defconstant alloc-table-page (ash (ash clc::romp-data-base 16) offset-to-page-shift))
-  (defconstant interrupt-routine-offset (+ 2048 132))
-)
-
-(defun write-initial-core-file (name)
-  (format t "[Building Initial Core File in file ~S: ~%" name)
-  (force-output t)
-  (let ((data-pages (1+ extra-pages))
-	(nonempty-spaces 0)
-	(byte-length 0))
-    (do ((spaces used-spaces (cdr spaces)))
-	((null spaces) (setq byte-length (ash data-pages page-to-offset-shift)))
-      (let ((free (handle-offset
-		   (space-free-pointer (svref memory (car spaces))))))
-	(when (eq (car spaces) code-space)
-	  (decf free (ash clc::romp-code-base 15)))
-	(when (> free 0)
-	  (incf nonempty-spaces)
-	  (incf data-pages (1+ (ash free (1+ offset-to-page-shift)))))))
-    (multiple-value-bind (hunk addr) (get-valid-hunk byte-length)
-      (setq hunk (int-sap hunk))
-      (setq addr (int-sap addr))
-      ;; Write the CORE file password.
-      (%primitive 16bit-system-set hunk 0 (byte-swap-16 #x+434F))
-      (%primitive 16bit-system-set hunk 1 (byte-swap-16 #x+5245))
-      ;; Write the directory header entry.
-      (%primitive 16bit-system-set hunk 2 0)
-      (%primitive 16bit-system-set hunk 3 (byte-swap-16 3841))
-      (%primitive 16bit-system-set hunk 4 0)
-      (%primitive 16bit-system-set hunk 5
-		  (byte-swap-16 (+ 2 (* 3 (+ nonempty-spaces extra-pages)))))
-      ;; First, an entry for the alloc table.
-      (%primitive 16bit-system-set hunk 6 0)	; Data page
-      (%primitive 16bit-system-set hunk 7 0)
-      (%primitive 16bit-system-set hunk 8
-		  (byte-swap-16 (logand (ash alloc-table-page -16) #xFFFF)))
-      (%primitive 16bit-system-set hunk 9
-		  (byte-swap-16 (logand alloc-table-page #xFFFF)))
-      (%primitive 16bit-system-set hunk 10 0)
-      (%primitive 16bit-system-set hunk 11 (byte-swap-16 1))	; Page count
-      ;; Construct the alloc table, with both free and clean pointers.
-      (do ((space (ash first-pointer-ltype 2) (1+ space)))
-	  ((> space (+ (ash largest-ltype 2) 3)))
-	(let ((alloc-index (+ alloc-table-data-start (ash space 2))))
-	  (cond ((svref memory space)
-		 (let ((free (space-free-pointer (svref memory space))))
-		   (when (eq space code-space)
-		     (handle-on (- (car free) clc::romp-code-base)
-				(cdr free)))
-		   (%primitive 16bit-system-set hunk alloc-index
-			       (byte-swap-16 (car free)))
-		   (%primitive 16bit-system-set hunk (+ alloc-index 1)
-			       (byte-swap-16 (cdr free)))
-		   (%primitive 16bit-system-set hunk (+ alloc-index 2)
-			       (byte-swap-16 (ash space type-space-shift)))
-		   (%primitive 16bit-system-set hunk (+ alloc-index 3) 0)))
-		(t
-		 (%primitive 16bit-system-set hunk alloc-index
-			     (byte-swap-16 (ash space type-space-shift)))
-		 (%primitive 16bit-system-set hunk (+ alloc-index 1) 0)
-		 (%primitive 16bit-system-set hunk (+ alloc-index 2)
-			     (byte-swap-16 (ash space type-space-shift)))
-		 (%primitive 16bit-system-set hunk (+ alloc-index 3) 0)))))
-
-      (let ((index (+ alloc-table-data-start
-		      (ash interrupt-routine-offset -1)))
-	    (addr (miscop-address 'clc::interrupt-routine)))
-	(%primitive 16bit-system-set hunk index
-		    (byte-swap-16 (ldb (byte 16 16) addr)))
-	(%primitive 16bit-system-set hunk (1+ index)
-		    (byte-swap-16 (ldb (byte 16 0) addr))))
-
-      ;; Then, write entries for each space.
-      (do ((spaces used-spaces (cdr spaces))
-	   (index 12)
-	   (data-page extra-pages))
-	  ((null spaces)
-	   ;; Finally, the end of header code.
-	   (%primitive 16bit-system-set hunk index 0)
-	   (%primitive 16bit-system-set hunk (+ index 1) (byte-swap-16 3840))
-	   (%primitive 16bit-system-set hunk (+ index 2) 0)
-	   (%primitive 16bit-system-set hunk (+ index 3) (byte-swap-16 2)))
-	(let* ((space (car spaces))
-	       (free (handle-offset
-		      (space-free-pointer (svref memory space)))))
-	  (if (> free 0)
-	      (let ((page-count (1+ (ash free (1+ offset-to-page-shift))))
-		    (process-page (ash space process-page-shift))
-		    (process-page-low (ash (logand space (1- (ash 1 (- process-page-shift))))
-					   (+ 16 process-page-shift))))
-		(when (eq space code-space)
-		  (let ((ppage (ash (ash clc::romp-code-base 16) offset-to-page-shift)))
-		    (setq process-page (ash ppage -16))
-		    (setq process-page-low (logand ppage #xFFFF)))
-		  (decf page-count (ash (ash clc::romp-code-base 16) offset-to-page-shift)))
-		;; Make the directory entry.
-		(%primitive 16bit-system-set hunk index 0)
-		(%primitive 16bit-system-set hunk (+ index 1)
-			    (byte-swap-16 data-page))
-		(%primitive 16bit-system-set hunk (+ index 2)
-			    (byte-swap-16 process-page))
-		(%primitive 16bit-system-set hunk (+ index 3)
-			    (byte-swap-16 process-page-low))
-		(%primitive 16bit-system-set hunk (+ index 4) 0)
-		(%primitive 16bit-system-set hunk (+ index 5)
-			    (byte-swap-16 page-count))
-		(format t "	~S page~:P, page ~S, from space #X~X.~%"
-			page-count (1+ data-page) space)
-		;; Move the words into the file.
-		(%primitive byte-blt (space-real-address (svref memory space))
-			    0 addr
-			    (ash (1+ data-page) page-to-offset-shift)
-			    (+ (ash (1+ data-page) page-to-offset-shift)
-			       (ash page-count page-to-offset-shift)))
-		(incf data-page page-count)
-		(incf index 6)))))
-      (let ((name (predict-name name nil)))
-	(format t "Writing ~A.~%" name)
-	(multiple-value-bind (fd err) (mach:unix-creat name #o644)
-	  (when (null fd)
-	    (error "Open on ~A failed, unix error ~S."
-		   name (mach:get-unix-error-msg err)))
-	  (multiple-value-bind (res err) (mach:unix-write fd addr 0 byte-length)
-	    (when (null res)
-	      (error "Write of core file ~S failed, unix error ~S."
-		     name (mach:get-unix-error-msg err))))
-	  (unless (eq (mach:unix-close fd) T)
-	    (error "Close of core file ~S failed, unix error ~S."
-		   name (mach:get-unix-error-msg err)))))
-      (write-line "Done!]")
-      t)))
-
-
-;;; Top level.
-
-
-(defun clean-up-genesis ()
-  (when (boundp '*cold-packages*)
-    (dolist (p *cold-packages*)
-      (dolist (symbol (cdr p))
-	(remprop symbol 'cold-info))))
-  (setq *defined-functions* nil)
-  (setq *external-references* nil)
-  (setq *cold-packages* ())
-  (setq *cold-map-file* nil)
-  (setq current-init-functions-cons nil-handle))
-
-
-(defun genesis (file-list core-name &optional map-file)
-  "Builds a kernel Lisp image from the .FASL files specified in the given
-  File-List and writes it to a file named by Core-Name."
-  (fresh-line)
-  (clean-up-genesis)
-  (when (eq map-file t)
-    (setq map-file (make-pathname :defaults core-name :type "map")))
-
-  (when map-file
-    (setq *cold-map-file* (open map-file :direction :output
-				:if-exists :supersede))
-    (format *cold-map-file* "Map file for ~A:" core-name))
-  (initialize-memory)
-  (initialize-spaces)
-  (initialize-symbols)
-  (initialize-bignums)
-  (dolist (file file-list)
-    (write-line file)
-    (let* ((normal-fop-functions fop-functions)
-	   (fop-functions cold-fop-functions)
-	   (*in-cold-load* t))
-      (load file)))
-  (initialize-trap-object)
-  (finish-symbols)
-  (resolve-references)
-  (write-memory (cold-intern '*lisp-initialization-functions* *lisp-package*)
-		current-init-functions-cons)
-  (write-map-file)
-  (write-initial-core-file core-name))
-
-
-;;;; Writing the map file:
-
-
-(defun write-map-file ()
-  (when *cold-map-file*
-    (let* ((file *cold-map-file*)
-	   (reflist *external-references*)
-	   (*print-pretty* nil)
-	   (*print-case* :upcase))
-      (declare (stream file))
-      (format file "~%~|Functions defined in core image:~%~%")
-      (dolist (info (nreverse *defined-functions*))
-	(let ((name (first info))
-	      (funobj (second info))
-	      (code (third info)))
-	  (format file "~X,,~4,'0X	~X,,~4,'0X	~S~%"
-		  (car funobj) (cdr funobj)
-		  (car code) (cdr code)
-		  name)))
-      
-      (format file "~%~|Assembler routine locations:~%~%")
-      (let ((refs NIL))
-	(dolist (ref reflist) (push (car ref) refs))
-	(setq refs
-	      (sort refs #'(lambda (x y)
-			     (< (get x '%address) (get y '%address)))))
-	(dolist (ref refs)
-	  (format file "~X  ~50S~%" (ash (get ref '%address) 1) ref))))
-    (close *cold-map-file*)))
diff --git a/compiler/old-rt/memory.lisp b/compiler/old-rt/memory.lisp
deleted file mode 100644
index 3459222b56bbd6fe33275eccbcabdb6d80a05925..0000000000000000000000000000000000000000
--- a/compiler/old-rt/memory.lisp
+++ /dev/null
@@ -1,147 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    This file contains the RT definitions of some general purpose memory
-;;; reference VOPs inherited by basic memory reference operations.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-
-;;; Cell-Ref and Cell-Set are used to define VOPs like CAR, where the offset to
-;;; be read or written is a property of the VOP used.  Cell-Setf is similar to
-;;; Cell-Set, but delivers the new value as the result.
-;;;
-(define-vop (cell-ref)
-  (:args (object :scs (descriptor-reg)))
-  (:results (value :scs (descriptor-reg any-reg)))
-  (:variant-vars offset)
-  (:policy :fast-safe)
-  (:generator 4
-    (loadw value object offset)))
-;;;
-(define-vop (cell-set)
-  (:args (object :scs (descriptor-reg))
-	 (value :scs (descriptor-reg any-reg)))
-  (:variant-vars offset)
-  (:policy :fast-safe)
-  (:generator 4
-    (storew value object offset)))
-;;;
-(define-vop (cell-setf)
-  (:args (object :scs (descriptor-reg))
-	 (value :scs (descriptor-reg any-reg)
-		:target result))
-  (:results (result :scs (descriptor-reg any-reg)))
-  (:variant-vars offset)
-  (:policy :fast-safe)
-  (:generator 4
-    (storew value object offset)
-    (unless (location= value result)
-      (inst lr result value))))
-
-;;; Define-Cell-Accessors  --  Interface
-;;;
-;;;    Define accessor VOPs for some cells in an object.  If the operation name
-;;; is NIL, then that operation isn't defined.  If the translate function is
-;;; null, then we don't define a translation.
-;;;
-(defmacro define-cell-accessors (offset ref-op ref-trans set-op set-trans)
-  `(progn
-     ,@(when ref-op
-	 `((define-vop (,ref-op cell-ref)
-	     (:variant ,offset)
-	     ,@(when ref-trans
-		 `((:translate ,ref-trans))))))
-     ,@(when set-op
-	 `((define-vop (,set-op cell-setf)
-	     (:variant ,offset)
-	     ,@(when set-trans
-		 `((:translate ,set-trans))))))))
-
-
-;;; Slot-Ref and Slot-Set are used to define VOPs like Closure-Ref, where the
-;;; offset is constant at compile time, but varies for different uses.  We add
-;;; in the stardard g-vector overhead.
-;;;
-(define-vop (slot-ref)
-  (:args (object :scs (descriptor-reg)))
-  (:results (value :scs (descriptor-reg any-reg)))
-  (:info offset)
-  (:generator 4
-    (load-slot value object offset)))
-;;;
-(define-vop (slot-set)
-  (:args (object :scs (descriptor-reg))
-	 (value :scs (descriptor-reg any-reg)))
-  (:info offset)
-  (:generator 4
-    (store-slot value object offset)))
-
-
-
-;;;; Indexed references:
-
-
-;;; Define-Indexer  --  Internal
-;;;
-;;;    Define some VOPs for indexed memory reference.  Unless the index is
-;;; constant, we must compute an intermediate result in a boxed temporary,
-;;; since the RT doesn't have any indexed addressing modes.  This means that GC
-;;; has to adjust the "raw" pointer in Index-Temp by observing that Index-Temp
-;;; points within Object-Temp.  After we are done, we clear Index-Temp so that
-;;; we don't raw pointers lying around.
-;;;
-(defmacro define-indexer (name write-p op shift)
-  `(define-vop (,name)
-     (:args (object :scs (descriptor-reg) :target object-temp)
-	    (index :scs (any-reg descriptor-reg short-immediate
-				 unsigned-immediate)
-		   :target index-temp)
-	    ,@(when write-p
-		'((value :scs (any-reg descriptor-reg) :target result))))
-     (:results (,(if write-p 'result 'value)
-		:scs (any-reg descriptor-reg)))
-     (:variant-vars offset)
-     (:temporary (:scs (descriptor-reg)
-		       :from (:argument 0))
-		 object-temp)
-     (:temporary (:scs (descriptor-reg)
-		       :from (:argument 1))
-		 index-temp)
-     (:policy :fast-safe)
-     (:generator 5
-       (sc-case index
-	 ((short-immediate unsigned-immediate)
-	  (,op value object (+ (tn-value index) offset)))
-	 (t
-	  (unless (location= object object-temp)
-	    (inst lr object-temp object))
-	  (unless (location= index index-temp)
-	    (inst lr index-temp index))
-	  
-	  ,@(unless (zerop shift)
-	      `((inst sli index-temp ,shift)))
-	  
-	  (inst a index-temp object-temp)
-	  (,op value index-temp offset)
-	  (loadi index-temp 0)))
-       
-       ,@(when write-p
-	   `((unless (location= value result)
-	       (inst lr result value)))))))
-
-(define-indexer word-index-ref nil loadw 2)
-(define-indexer word-index-set t storew 2)
-(define-indexer halfword-index-ref nil loadh 1)
-(define-indexer signed-halfword-index-ref nil loadha 1)
-(define-indexer halfword-index-set t storeha 1)
-(define-indexer byte-index-ref nil loadc 0)
-(define-indexer byte-index-set t storec 0)
diff --git a/compiler/old-rt/miscop.lisp b/compiler/old-rt/miscop.lisp
deleted file mode 100644
index 22a8b3e0479de4fc30ceb979b60e38a6a1b90746..0000000000000000000000000000000000000000
--- a/compiler/old-rt/miscop.lisp
+++ /dev/null
@@ -1,180 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    We have a few general-purpose VOPs that are used to implement all the
-;;; miscop VOPs using the variant mechanism.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-    
-(define-vop (miscop)
-  (:temporary (:sc any-reg  :offset 0
-	       :from (:eval 0)  :to (:eval 1))
-	      nl0)
-  (:temporary (:sc any-reg  :offset 1
-	       :from (:eval 0)  :to (:eval 1))
-	      a0)
-  (:temporary (:sc any-reg  :offset 2
-	       :from (:eval 0)  :to (:eval 1))
-	      nl1)
-  (:temporary (:sc any-reg  :offset 3
-	       :from (:eval 0)  :to (:eval 1))
-	      a1)
-  (:temporary (:sc any-reg  :offset 4
-	       :from (:eval 0)  :to (:eval 1))
-	      a3)
-  (:temporary (:sc any-reg  :offset 5
-	       :from (:eval 0)  :to (:eval 1))
-	      a2)
-  (:temporary (:sc any-reg  :offset 15
-	       :from (:eval 0)  :to (:eval 1))
-	      misc-pc)
-  (:note "miscop call")
-  (:variant-vars miscop-name)
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:policy :safe))
-
-(eval-when (compile load eval)
-  (defconstant reg-arg-count 4)
-  (defconstant arg-names '(x y z arg3 arg4 arg5 arg6 arg7 arg8))
-  (defconstant temp-names '(a0 a1 a2 a3 s3 s4 s5 s6 s7))
-  (defconstant temp-offsets '(1 3 5 4 3 4 5 6 7))
-  (defconstant result-names '(r r1 r2 r3 r4 r5 r6 r7 r8))
-); eval-when (compile load eval)
-
-
-;;; Make-Miscop  --  Internal
-;;;
-;;;    Make a miscop with the specified numbers of arguments and results,
-;;; conditional flag, etc.
-;;;
-(defmacro make-miscop (nargs nresults &key conditional)
-  (collect ((args)
-	    (results)
-	    (temps)
-	    (arg-moves)
-	    (result-moves))
-    (let ((max-ops (max nargs nresults)))
-      (dotimes (i nargs)
-	(let ((arg (elt arg-names i))
-	      (temp (elt temp-names i)))
-	  (args
-	   `(,arg :target ,temp :scs (any-reg descriptor-reg)))
-	  (arg-moves
-	   (if (>= i reg-arg-count)
-	       `(store-stack-tn ,temp ,arg)
-	       `(unless (location= ,arg ,temp)
-		  (inst lr ,temp ,arg))))))
-      
-      (dotimes (i nresults)
-	(let ((result (elt result-names i))
-	      (temp (elt temp-names i)))
-	  (results
-	   `(,result :scs (any-reg descriptor-reg)))
-	  (result-moves
-	   (if (>= i reg-arg-count)
-	       `(load-stack-tn ,result ,temp)
-	       `(unless (location= ,result ,temp)
-		  (inst lr ,result ,temp))))))
-      
-      (dotimes (i (max nargs nresults))
-	(temps
-	 `(:temporary (:sc ,(if (>= i reg-arg-count) 'stack 'any-reg)
-			   :offset ,(elt temp-offsets i)
-			   :from ,(if (>= i nargs) '(:eval 0) `(:argument ,i))
-			   :to ,(if (>= i nresults) '(:eval 1) `(:result ,i))
-			   ,@(unless (>= i nresults)
-			       `(:target ,(elt result-names i))))
-		      ,(elt temp-names i))))
-      
-      `(define-vop (,(miscop-name nargs nresults conditional) miscop)
-	 (:args ,@(args))
-	 ,@(unless conditional `((:results ,@(results))))
-	 ,@(temps)
-	 ,@(when conditional
-	     '((:conditional t)
-	       (:variant-vars miscop-name condition)
-	       (:info target not-p)))
-	 (:ignore nl0 nl1 misc-pc
-		  ,@(if (>= max-ops reg-arg-count)
-			()
-			(subseq temp-names max-ops reg-arg-count)))
-	 (:generator 20
-	   ,@(arg-moves)
-	   (inst miscop miscop-name)
-	   (note-this-location vop :known-return)
-	   ,@(result-moves)
-	   ,@(when conditional
-	       '((if not-p
-		     (inst bnb condition target)
-		     (inst bb condition target)))))))))
-
-(make-miscop 1 0 :conditional t)
-(make-miscop 2 0 :conditional t)
-
-(make-miscop 0 0)
-(make-miscop 1 0)
-(make-miscop 2 0)
-(make-miscop 3 0)
-(make-miscop 4 0)
-
-(make-miscop 0 1)
-(make-miscop 1 1)
-(make-miscop 2 1)
-(make-miscop 3 1)
-(make-miscop 4 1)
-(make-miscop 5 1)
-
-(make-miscop 0 2)
-(make-miscop 1 2)
-(make-miscop 2 2)
-(make-miscop 3 2)
-(make-miscop 4 2)
-(make-miscop 5 2)
-
-(make-miscop 1 3)
-
-(define-vop (effectless-unaffected-one-arg-miscop one-arg-miscop)
-  (:effects)
-  (:affected))
-
-(define-vop (effectless-unaffected-two-arg-miscop two-arg-miscop)
-  (:effects)
-  (:affected))
-
-(define-vop (n-arg-miscop zero-arg-miscop)
-  (:args (passed-args :more t))
-  (:ignore passed-args a1 a2 a3 nl1 misc-pc)
-  (:temporary (:sc descriptor-reg :offset argument-pointer-offset) args)
-  (:info nargs)
-  (:generator 40
-    (inst lr args cont-tn)
-    (inst miscopx miscop-name)
-    (inst cal nl0 zero-tn nargs)
-    (note-this-location vop :known-return)
-    (unless (location= r a0)
-      (inst lr r a0))))
-
-(define-vop (n-arg-two-value-miscop zero-arg-two-value-miscop)
-  (:args (passed-args :more t))
-  (:ignore passed-args a2 a3 nl1 misc-pc)
-  (:temporary (:sc descriptor-reg :offset argument-pointer-offset) args)
-  (:info nargs)
-  (:generator 40
-    (inst lr args cont-tn)
-    (inst miscopx miscop-name)
-    (inst cal nl0 zero-tn nargs)
-    (note-this-location vop :known-return)
-    (unless (location= r a0)
-      (inst lr r a0))
-    (unless (location= r1 a1)
-      (inst lr r1 a1))))
diff --git a/compiler/old-rt/nlx.lisp b/compiler/old-rt/nlx.lisp
deleted file mode 100644
index a4ed6e6348022ea17dd2f534810e7e571b4e2979..0000000000000000000000000000000000000000
--- a/compiler/old-rt/nlx.lisp
+++ /dev/null
@@ -1,211 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    This file contains the definitions of VOPs used for non-local exit
-;;; (throw, lexical exit, etc.)
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-
-;;; Save and restore dynamic environment.
-;;;
-;;;    These VOPs are used in the reentered function to restore the appropriate
-;;; dynamic environment.  Currently we only save the Current-Catch and binding
-;;; stack pointer.  We don't need to save/restore the current unwind-protect,
-;;; since unwind-protects are implicitly processed during unwinding.  If there
-;;; were any additional stacks, then this would be the place to restore the top
-;;; pointers.
-
-
-;;; Make-Dynamic-State-TNs  --  Interface
-;;;
-;;;    Return a list of TNs that can be used to snapshot the dynamic state for
-;;; use with the Save/Restore-Dynamic-Environment VOPs.
-;;;
-(defun make-dynamic-state-tns ()
-  (make-n-tns 3 *any-primitive-type*))
-
-(define-vop (save-dynamic-state)
-  (:results (catch :scs (descriptor-reg))
-	    (special :scs (descriptor-reg))
-	    (eval :scs (descriptor-reg)))
-  (:generator 13
-    (load-global catch clc::current-catch-block)
-    (inst lr special bs-tn)
-    (inst cau eval zero-tn clc::t-16)
-    (inst l eval eval (+ clc::*eval-stack-top*-offset clc::symbol-value))))
-
-(define-vop (restore-dynamic-state one-arg-no-value-miscop)
-  (:args (catch :scs (descriptor-reg))
-	 (special :scs (descriptor-reg) :target a0)
-	 (eval :scs (descriptor-reg)))
-  (:temporary (:scs (descriptor-reg)) temp)
-  (:variant-vars)
-  (:generator 10
-    (store-global catch clc::current-catch-block temp)
-    (inst cau temp zero-tn clc::t-16)
-    (inst st eval temp (+ clc::*eval-stack-top*-offset clc::symbol-value))
-    (let ((skip (gen-label)))
-      (inst c special bs-tn)
-      (inst bb :eq skip)
-      (unless (location= special a0)
-	(inst lr a0 special))
-      (inst miscop 'clc::unbind-to-here)
-      (emit-label skip))))
-
-(define-vop (current-stack-pointer)
-  (:results (res :scs (any-reg descriptor-reg)))
-  (:generator 1
-    (inst lr res sp-tn)))
-
-
-;;;; Unwind miscop VOPs:
-
-(define-vop (unwind three-arg-no-value-miscop)
-  (:variant 'clc::unwind)
-  (:translate %continue-unwind))
-
-(define-vop (throw three-arg-no-value-miscop)
-  (:variant 'clc::throw))
-
-
-;;;; Unwind block hackery:
-
-;;; Compute the address of the catch block from its TN, then store into the
-;;; block the current Cont, Env, Unwind-Protect, and the entry PC.
-;;;
-(define-vop (make-unwind-block)
-  (:args (tn)
-	 (entry-offset :scs (any-reg descriptor-reg)))
-  (:results (block :scs (descriptor-reg)))
-  (:temporary (:scs (descriptor-reg)) temp)
-  (:temporary (:scs (descriptor-reg) :target block) result)
-  (:generator 22
-    (inst ai result cont-tn (* (tn-offset tn) 4))
-    (load-global temp clc::current-unwind-protect-block)
-    (storew temp result system:%unwind-block-current-uwp)
-    (storew cont-tn result system:%unwind-block-current-cont)
-    (storew env-tn result system:%unwind-block-current-env)
-    (storew entry-offset result system:%unwind-block-entry-pc)
-    (unless (location= result block)
-      (inst lr block result))))
-
-
-;;; Like Make-Unwind-Block, except that we also store in the specified tag, and
-;;; link the block into the Current-Catch list.
-;;;
-(define-vop (make-catch-block)
-  (:args (tn)
-	 (tag :scs (any-reg descriptor-reg))
-	 (entry-offset :scs (any-reg descriptor-reg)))
-  (:results (block :scs (descriptor-reg)))
-  (:temporary (:scs (descriptor-reg)) temp)
-  (:temporary (:scs (descriptor-reg) :target block) result)
-  (:generator 44
-    (inst ai result cont-tn (* (tn-offset tn) 4))
-    (load-global temp clc::current-unwind-protect-block)
-    (storew temp result system:%unwind-block-current-uwp)
-    (storew cont-tn result system:%unwind-block-current-cont)
-    (storew env-tn result system:%unwind-block-current-env)
-    (storew entry-offset result system:%unwind-block-entry-pc)
-
-    (storew tag result system:%catch-block-tag)
-    (load-global temp clc::current-catch-block)
-    (storew temp result system:%catch-block-previous-catch)
-    (store-global result clc::current-catch-block temp)
-    
-    (unless (location= result block)
-      (inst lr block result))))
-
-
-;;; Just set the current unwind-protect to TN's address.  This instantiates an
-;;; unwind block as an unwind-protect.
-;;;
-(define-vop (set-unwind-protect)
-  (:args (tn))
-  (:temporary (:scs (descriptor-reg)) temp new-uwp)
-  (:generator 7
-    (inst ai new-uwp cont-tn (* (tn-offset tn) 4))
-    (store-global new-uwp clc::current-unwind-protect-block temp)))
-
-
-(define-vop (unlink-unwind-block)
-  (:temporary (:scs (descriptor-reg)) block temp)
-  (:variant-vars global slot)
-  (:policy :fast-safe)
-  (:generator 17
-    (load-global block global)
-    (loadw block block slot)
-    (store-global block global temp)))
-
-(define-vop (unlink-catch-block unlink-unwind-block)
-  (:variant clc::current-catch-block system:%catch-block-previous-catch)
-  (:translate %catch-breakup))
-
-(define-vop (unlink-unwind-protect unlink-unwind-block)
-  (:variant clc::current-unwind-protect-block system:%unwind-block-current-uwp)
-  (:translate %unwind-protect-breakup))
-
-
-;;;; NLX entry VOPs:
-;;;
-;;;    We can't just make these miscop variants, since they take funny wired
-;;; operands.
-;;;
-
-(define-vop (nlx-entry two-arg-no-value-miscop)
-  (:args (top :scs (descriptor-reg)
-	      :target a0)
-	 (start)
-	 (count))
-  (:results (values :more t))
-  (:info nvals)
-  (:ignore start count values nl0 nl1 a2 a3 misc-pc)
-  (:variant-vars)
-  (:save-p :force-to-stack)
-  (:vop-var vop)
-  (:generator 30
-    (note-this-location vop :non-local-exit)
-    (unless (location= a0 top)
-      (inst lr a0 top))
-    (inst miscopx 'clc::nlx-entry-default-values)
-    (inst cal a1 zero-tn nvals)))
-
-
-(define-vop (nlx-entry-multiple two-arg-two-value-miscop)
-  (:args (top :scs (descriptor-reg)
-	      :target a0)
-	 (start)
-	 (count))
-  (:ignore start count nl0 nl1 a2 a3 misc-pc)
-  (:variant-vars)
-  (:save-p :force-to-stack)
-  (:vop-var vop)
-  (:generator 30
-    (note-this-location vop :non-local-exit)
-    (unless (location= a0 top)
-      (inst lr a0 top))
-    (inst miscop 'clc::nlx-entry-receive-values)
-    (unless (location= a0 r)
-      (inst lr r a0))
-    (unless (location= a1 r1)
-      (inst lr r1 a1))))
-
-
-;;; This VOP is just to force the TNs used in the cleanup onto the stack.
-;;;
-(define-vop (uwp-entry)
-  (:save-p :force-to-stack)
-  (:results (block) (start) (count))
-  (:ignore block start count)
-  (:vop-var vop)
-  (:generator 0
-    (note-this-location vop :non-local-exit)))
diff --git a/compiler/old-rt/odump.lisp b/compiler/old-rt/odump.lisp
deleted file mode 100644
index 33e557e3427b411247a82e3c840f8e2aa1c97f88..0000000000000000000000000000000000000000
--- a/compiler/old-rt/odump.lisp
+++ /dev/null
@@ -1,852 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;
-;;;    This file contains stuff that knows about dumping code both to files to
-;;; the running Lisp.
-;;;
-(in-package 'c)
-
-(proclaim '(special compiler-version))
-
-(import '(system:%primitive system:%array-data-slot
-			    system:%array-displacement-slot
-			    system:%g-vector-structure-subtype
-			    system:%function-constants-constants-offset))
-
-
-
-;;;; Fasl dumper state:
-
-;;; The Fasl-File structure represents everything we need to know about dumping
-;;; to a fasl file.  We need to objectify the state, since the fasdumper must
-;;; be reentrant.
-;;;
-(defstruct (fasl-file
-	    (:print-function
-	     (lambda (s stream d)
-	       (declare (ignore d))
-	       (format stream "#<Fasl-File ~S>"
-		       (namestring (fasl-file-stream s))))))
-  ;;
-  ;; The stream we dump to.
-  (stream nil :type stream)
-  ;;
-  ;; A hashtable we use to keep track of dumped constants so that we can get
-  ;; them from the table rather than dumping them again.
-  (table (make-hash-table :test #'equal) :type hash-table)
-  ;;
-  ;; The table's current free pointer: the next offset to be used.
-  (table-free 0 :type unsigned-byte)
-  ;;
-  ;; Alist (Package . Offset) of the table offsets for each package we have
-  ;; currently located.
-  (packages () :type list)
-  ;;
-  ;; Table mapping from the Entry-Info structures for dumped XEPs to the table
-  ;; offsets of the corresponding code pointers.
-  (entry-table (make-hash-table :test #'eq) :type hash-table)
-  ;;
-  ;; Table holding back-patching info for forward references to XEPs.  The key
-  ;; is the Entry-Info structure for the XEP, and the value is a list of conses
-  ;; (<code-handle> . <offset>), where <code-handle> is the offset in the table
-  ;; of the code object needing to be patched, and <offset> is the offset that
-  ;; must be patched.
-  (patch-table (make-hash-table :test #'eq) :type hash-table)
-  ;;
-  ;; A list of the table handles for all of the DEBUG-INFO structures dumped in
-  ;; this file.  These structures must be back-patched with source location
-  ;; information when the compilation is complete.
-  (debug-info () :type list)
-  ;;
-  ;; Used to keep track of objects that we are in the process of dumping so that
-  ;; circularities can be preserved.  The key is the object that we have
-  ;; previously seen, and the value is the object that we reference in the table
-  ;; to find this previously seen object.  (The value is never NIL.)
-  ;;
-  ;; Except with list objects, the key and the value are always the same.  In a
-  ;; list, the key will be some tail of the value.
-  ;;
-  (circularity-table (make-hash-table :test #'eq) :type hash-table)
-  ;;
-  ;; A list of the Circularity structures for all of the circiuarities detected
-  ;; in the the current top-level call to Dump-Object.
-  (circularities nil :type list))
-
-
-;;; This structure holds information about a circularity.
-;;;
-(defstruct circularity
-  ;;
-  ;; Kind of modification to make to create circularity.
-  (type nil :type (member :rplaca :rplacd :svset))
-  ;;
-  ;; Object containing circularity.
-  object
-  ;;
-  ;; Index in object for circularity.
-  (index nil :type unsigned-byte)
-  ;;
-  ;; The object to be stored at Index in Object.  This is that the key that we
-  ;; were using when we discovered the circularity.
-  value
-  ;;
-  ;; The value that was associated with Value in the CIRCULARITY-TABLE.  This
-  ;; is the object that we look up in the table to locate Value.
-  enclosing-object)
-
-
-;;;; Utilities:
-
-;;; Dump-Byte  --  Internal
-;;;
-;;;    Write the byte B to the specified fasl-file stream.
-;;;
-(proclaim '(inline dump-byte))
-(defun dump-byte (b file)
-  (declare (type (unsigned-byte 8) b) (type fasl-file file))
-  (write-byte b (fasl-file-stream file))
-  (undefined-value))
-
-
-;;; Dump-FOP  --  Internal
-;;;
-;;;    Dump the FOP code for the named FOP to the specified fasl-file.
-;;;
-(defun dump-fop (fs file)
-  (declare (symbol fs) (type fasl-file file))
-  (let ((val (get fs 'lisp::fop-code)))
-    (assert val () "Compiler bug: ~S not a legal fasload operator." fs)
-    (dump-byte val file))
-  (undefined-value))
-
-
-;;; Dump-FOP*  --  Internal
-;;;
-;;;    Dump a FOP-Code along with an integer argument, choosing the FOP based
-;;; on whether the argument will fit in a single byte.
-;;;
-(defmacro dump-fop* (n byte-fop word-fop file)
-  (once-only ((n-n n)
-	      (n-file file))
-    `(cond ((< ,n-n 256)
-	    (dump-fop ',byte-fop ,n-file)
-	    (dump-byte ,n-n ,n-file))
-	   (t
-	    (dump-fop ',word-fop ,n-file)
-	    (quick-dump-number ,n-n 4 ,n-file)))))
-
-
-;;; Quick-Dump-Number  --  Internal
-;;;
-;;;    Dump Num to the fasl stream, represented by the specified number of
-;;; bytes.
-;;;
-(defun quick-dump-number (num bytes file)
-  (declare (type unsigned-byte num bytes) (type fasl-file file))
-  (let ((stream (fasl-file-stream file)))
-    (do ((n num (ash n -8))
-	 (i bytes (1- i)))
-	((= i 0))
-      (write-byte (logand n #xFF) stream)))
-  (undefined-value))
-
-
-;;; Dump-Push  --  Internal
-;;;
-;;;    Push the object at table offset Handle on the fasl stack.
-;;;
-(defun dump-push (handle file)
-  (declare (type unsigned-byte handle) (type fasl-file file))
-  (dump-fop* handle lisp::fop-byte-push lisp::fop-push file)
-  (undefined-value))
-
-
-;;; Dump-Pop  --  Internal
-;;;
-;;;    Pop the object currently on the fasl stack top into the table, and
-;;; return the table index, incrementing the free pointer.
-;;;
-(defun dump-pop (file)
-  (prog1 (fasl-file-table-free file)
-    (dump-fop 'lisp::fop-pop file)
-    (incf (fasl-file-table-free file))))
-
-
-;;; Used to inhibit table access when dumping forms to be read by the cold
-;;; loader.
-;;;
-(defvar *cold-load-dump* nil)
-
-;;; Fasl-Dump-Cold-Load-Form  --  Interface
-;;;
-;;;    Dump Form to a fasl file so that it evaluated at load time in normal
-;;; load and at cold-load time in cold load.  This is used to dump package
-;;; frobbing forms.
-;;;
-(defun fasl-dump-cold-load-form (form file)
-  (declare (type fasl-file file))
-  (dump-fop 'lisp::fop-normal-load file)
-  (let ((*cold-load-dump* t))
-    (dump-object form file))
-  (dump-fop 'lisp::fop-eval-for-effect file)
-  (dump-fop 'lisp::fop-maybe-cold-load file)
-  (undefined-value))
-
-
-;;;; Opening and closing:
-
-;;; Open-Fasl-File  --  Interface
-;;;
-;;;    Return a Fasl-File object for dumping to the named file.  Some
-;;; information about the source is specified by the string Where.
-;;;
-(defun open-fasl-file (name where)
-  (declare (type pathname name))
-  (let* ((stream (open name :direction :output
-		       :if-exists :new-version
-		       :element-type '(unsigned-byte 8)))
-	 (res (make-fasl-file :stream stream)))
-    (format stream
-	    "FASL FILE output from ~A.~@
-	    Compiled ~A on ~A~@
-	    Compiler ~A, Lisp ~A~@
-	    Targeted for ~A, FASL code format ~D~%"
-	    where
-	    (ext:format-universal-time nil (get-universal-time))
-	    (machine-instance) compiler-version
-	    (lisp-implementation-version) vm-version target-fasl-code-format)
-    ;;
-    ;; Terminate header.
-    (dump-byte 255 res)
-    ;;
-    ;; Specify code format.
-    (dump-fop 'lisp::fop-code-format res)
-    (dump-byte target-fasl-code-format res)
-
-    res))
-
-
-;;; Close-Fasl-File  --  Interface
-;;;
-;;;    Close the specified Fasl-File, aborting the write if Abort-P is true.
-;;; We do various sanity checks, then end the group.
-;;;
-(defun close-fasl-file (file abort-p)
-  (declare (type fasl-file file))
-  (dump-fop 'lisp::fop-verify-empty-stack file)
-  (dump-fop 'lisp::fop-verify-table-size file)
-  (quick-dump-number (fasl-file-table-free file) 4 file)
-  (dump-fop 'lisp::fop-end-group file)
-  (close (fasl-file-stream file) :abort abort-p)
-  (undefined-value))
-
-
-;;;; Component (function) dumping:
-
-
-;;; Dump-Code-Object  --  Internal
-;;;
-;;;    Dump out the constant pool and code-vector for component, push the
-;;; result in the table and return the offset.
-;;;
-;;;    The only tricky thing is handling constant-pool references to functions.
-;;; If we have already dumped the function, then we just push the code pointer.
-;;; Otherwise, we must create back-patching information so that the constant
-;;; will be set when the function is eventually dumped.  This is a bit awkward,
-;;; since we don't have the handle for the code object being dumped while we
-;;; are dumping its constants.
-;;;
-;;;    We dump a trap object as a placeholder for the code vector, which is
-;;; actually filled in by the loader.
-;;;
-(defun dump-code-object (component code-vector code-length node-vector
-				   nodes-length file)
-  (declare (type component component) (type fasl-file file)
-	   (simple-vector node-vector)
-	   (type unsigned-byte code-length nodes-length))
-  (let* ((2comp (component-info component))
-	 (constants (ir2-component-constants 2comp))
-	 (num-consts (length constants)))
-    (collect ((patches))
-      (dump-object (component-name component) file)
-      (dump-fop 'lisp::fop-misc-trap file)
-
-      (let ((info (debug-info-for-component component node-vector
-					    nodes-length)))
-	(dump-object info file)
-	(let ((info-handle (dump-pop file)))
-	  (dump-push info-handle file)
-	  (push info-handle (fasl-file-debug-info file))))
-
-      (do ((i %function-constants-constants-offset (1+ i)))
-	  ((= i num-consts))
-	(let ((entry (aref constants i)))
-	  (etypecase entry
-	    (constant
-	     (dump-object (constant-value entry) file))
-	    (cons
-	     (ecase (car entry)
-	       (:entry
-		(let* ((info (leaf-info (cdr entry)))
-		       (handle (gethash info (fasl-file-entry-table file))))
-		  (cond
-		   (handle
-		    (dump-push handle file))
-		   (t
-		    (patches (cons info i))
-		    (dump-fop 'lisp::fop-misc-trap file)))))
-	       (:label
-		(dump-object (+ (label-location (cdr entry))
-				clc::i-vector-header-size)
-			     file))))
-	    (null
-	     (dump-fop 'lisp::fop-misc-trap file)))))
-
-      (cond ((and (< num-consts #x100) (< code-length #x10000))
-	     (dump-fop 'lisp::fop-small-code file)
-	     (dump-byte num-consts file)
-	     (quick-dump-number code-length 2 file))
-	    (t
-	     (dump-fop 'lisp::fop-code file)
-	     (quick-dump-number num-consts 4 file)
-	     (quick-dump-number code-length 4 file)))
-      
-      (write-string code-vector (fasl-file-stream file) :end code-length)
-      
-      (let ((handle (dump-pop file)))
-	(dolist (patch (patches))
-	  (push (cons handle (cdr patch))
-		(gethash (car patch) (fasl-file-patch-table file))))
-	handle))))
-
-
-;;; Dump-Fixups  --  Internal
-;;;
-;;;    Dump all the fixups.  Currently there are only miscop fixups, and we
-;;; always access them by name rather than number.  There is no reason for
-;;; using miscop numbers other than a minor load-time efficiency win.
-;;;
-(defun dump-fixups (code-handle fixups file)
-  (declare (type unsigned-byte code-handle) (list fixups)
-	   (type fasl-file file))
-  (dump-push code-handle file)
-  (dolist (fixup fixups)
-    (let ((offset (second fixup))
-	  (value (third fixup)))
-      (ecase (first fixup)
-	(:miscop
-	 (assert (symbolp value))
-	 (dump-object value file)
-	 (dump-fop 'lisp::fop-user-miscop-fixup file)
-	 (quick-dump-number offset 4 file)))))
-
-  (dump-fop 'lisp::fop-pop-for-effect file)
-  (undefined-value))
-
-
-;;; Dump-One-Entry  --  Internal
-;;;
-;;;    Dump a function-entry data structure corresponding to Entry to File.
-;;; Code-Handle is the table offset of the code object for the component.
-;;;
-;;; If the entry is a DEFUN, then we also dump a FOP-FSET so that the cold
-;;; loader can instantiate the definition at cold-load time, allowing forward
-;;; references to functions in top-level forms.
-;;;
-(defun dump-one-entry (entry code-handle file)
-  (declare (type entry-info entry) (type unsigned-byte code-handle)
-	   (type fasl-file file))
-  (let ((name (entry-info-name entry)))
-    (dump-push code-handle file)
-    (dump-object (if (entry-info-closure-p entry)
-		     system:%function-closure-entry-subtype
-		     system:%function-entry-subtype)
-		 file)
-
-    (dump-object name file)
-    (dump-fop 'lisp::fop-misc-trap file)
-    (dump-object (+ (label-location (entry-info-offset entry))
-		    clc::i-vector-header-size)
-		 file)
-    (dump-fop 'lisp::fop-misc-trap file)
-    (dump-object (entry-info-arguments entry) file)
-    (dump-object (entry-info-type entry) file)
-    (dump-fop 'lisp::fop-function-entry file)
-    (dump-byte 6 file)
-
-    (let ((handle (dump-pop file)))
-      (when (and name (symbolp name))
-	(dump-object name file)
-	(dump-push handle file)
-	(dump-fop 'lisp::fop-fset file))
-      handle)))
-
-
-;;; Alter-Code-Object  --  Internal
-;;;
-;;;    Alter the code object referenced by Code-Handle at the specified Offset,
-;;; storing the object referenced by Entry-Handle.
-;;;
-(defun alter-code-object (code-handle offset entry-handle file)
-  (dump-push code-handle file)
-  (dump-push entry-handle file)
-  (dump-fop* offset lisp::fop-byte-alter-code lisp::fop-alter-code file)
-  (undefined-value))
-
-
-;;; Fasl-Dump-Component  --  Interface
-;;;
-;;;    Dump the code, constants, etc. for component.  Code-Vector is a vector
-;;; holding the assembled code.  Length is the number of elements of Vector
-;;; that are actually in use.  If the component is a top-level component, then
-;;; the top-level lambda will be called after the component is loaded.
-;;;
-(defun fasl-dump-component (component code-vector code-length
-				      node-vector nodes-length
-				      fixups file)
-  (declare (type component component) (type unsigned-byte length)
-	   (list fixups) (type fasl-file file))
-
-  (dump-fop 'lisp::fop-verify-empty-stack file)
-  (dump-fop 'lisp::fop-verify-table-size file)
-  (quick-dump-number (fasl-file-table-free file) 4 file)
-
-  (let ((code-handle (dump-code-object component code-vector code-length
-				       node-vector nodes-length file))
-	(2comp (component-info component)))
-    (dump-fixups code-handle fixups file)
-    (dump-fop 'lisp::fop-verify-empty-stack file)
-
-    (dolist (entry (ir2-component-entries 2comp))
-      (let ((entry-handle (dump-one-entry entry code-handle file)))
-	(setf (gethash entry (fasl-file-entry-table file)) entry-handle)
-
-	(let ((old (gethash entry (fasl-file-patch-table file))))
-	  (when old
-	    (dolist (patch old)
-	      (alter-code-object (car patch) (cdr patch) entry-handle file))
-	    (remhash entry (fasl-file-patch-table file)))))))
-
-  (assert (zerop (hash-table-count (fasl-file-patch-table file))))
-
-  (undefined-value))
-
-
-;;; Call-Top-Level-Lambda  --  Interface
-;;;
-;;;    Dump a FOP-FUNCALL to call an already dumped top-level lambda at load
-;;; time.  
-;;;
-(defun call-top-level-lambda (fun file)
-  (declare (type clambda fun) (type fasl-file file))
-  (let ((handle (gethash (leaf-info fun) (fasl-file-entry-table file))))
-    (assert handle)
-    (dump-push handle file)
-    (dump-fop 'lisp::fop-funcall-for-effect file)
-    (dump-byte 0 file))
-  (undefined-value))
-
-
-;;; FASL-DUMP-SOURCE-INFO  --  Interface
-;;;
-;;;    Compute the correct list of DEBUG-SOURCE structures and backpatch all of
-;;; the dumped DEBUG-INFO structures.  We clear the FASL-FILE-DEBUG-INFO,
-;;; so that subsequent components with different source info may be dumped.
-;;;
-(defun fasl-dump-source-info (info file)
-  (declare (type source-info info) (type fasl-file file))
-  (let ((res (debug-source-for-info info)))
-    (dump-object res file)
-    (let ((res-handle (dump-pop file)))
-      (dolist (info-handle (fasl-file-debug-info file))
-	(dump-push res-handle file)
-	(dump-fop 'lisp::fop-svset file)
-	(quick-dump-number info-handle 4 file)
-	(quick-dump-number 2 4 file))))
-
-  (setf (fasl-file-debug-info file) ())
-  (undefined-value))
-
-
-;;; Dump-Circularities  --  Internal
-;;;
-;;;    Dump stuff to backpatch already dumped objects.  Infos is the list of
-;;; Circularity structures describing what to do.  The patching FOPs take the
-;;; value to store on the stack.  We compute this value by fetching the
-;;; enclosing object from the table, and then CDR'ing it if necessary.
-;;;
-(defun dump-circularities (infos)
-  (dolist (info infos)
-    (let* ((value (circularity-value info))
-	   (enclosing (circularity-enclosing-object info)))
-      (dump-fop* (gethash enclosing *table-table*)
-		 lisp::fop-byte-push lisp::fop-push)
-      (unless (eq enclosing value)
-	(do ((current enclosing (cdr current))
-	     (i 0 (1+ i)))
-	    ((eq current value)
-	     (dump-fop 'lisp::fop-nthcdr)
-	     (quick-dump-number i 4)))))
-
-    (dump-fop (case (circularity-type info)
-		(:rplaca 'lisp::fop-rplaca)
-		(:rplacd 'lisp::fop-rplacd)
-		(:svset 'lisp::fop-svset)))
-    (quick-dump-number (gethash (circularity-object info) *table-table*) 4)
-    (quick-dump-number (circularity-index info) 4)))
-
-
-;;; Dump-Object  -- Internal
-;;;
-;;;    Dump an object of any type.  This function dispatches to the correct
-;;; type-specific dumping function.  For non-trivial objects, we check to see
-;;; if the object has already been dumped (and is in the table).  Symbols are a
-;;; special case, since we have -SAVE variants.
-;;;
-(defun dump-object (x file)
-  (declare (type fasl-file file))
-  (cond
-   ((null x)
-    (dump-fop 'lisp::fop-empty-list file))
-   ((eq x t) 
-    (dump-fop 'lisp::fop-truth file))
-   ((typep x 'fixnum) (dump-integer x file))
-   (t
-    (let ((index (gethash x (fasl-file-table file))))
-      (cond
-       ((and index (not *cold-load-dump*))
-	(dump-push index file))
-       ((symbolp x)
-	(dump-symbol x file))
-       (t
-	(typecase x
-	  (list
-	   (dump-list x file))
-	  (vector
-	   (cond ((stringp x) (dump-string x file))
-		 ((subtypep (array-element-type x) '(unsigned-byte 16))
-		  (dump-i-vector x file))
-		 (t
-		  (dump-vector x file))))
-	  (array (dump-array x file))
-	  (number
-	   (etypecase x
-	     (ratio (dump-ratio x file))
-	     (complex (dump-complex x file))
-	     (float (dump-float x file))
-	     (integer (dump-integer x file))))
-	  (character
-	   (dump-character x file))
-	  (t
-	   (compiler-error-message
-	    "This object cannot be dumped into a fasl file:~%  ~S"
-	    x)
-	   (dump-fop 'lisp::fop-misc-trap file)))
-	;;
-	;; If wasn't in the table, put it there...
-	(unless *cold-load-dump*
-	  (let ((handle (dump-pop file)))
-	    (dump-push handle file)
-	    (setf (gethash x (fasl-file-table file)) handle)))))))))
-
-
-#|
-;;; Load-Time-Eval  --  Internal
-;;;
-;;;    This guy deals with the magical %Eval-At-Load-Time marker that
-;;; #, turns into when the *compiler-is-reading* and a fasl file is being
-;;; written.
-;;;
-(defun load-time-eval (x file)
-  (when *compile-to-lisp*
-    (clc-error "#,~S in a bad place." (third x)))
-  (assemble-one-lambda (cadr x))
-  (dump-fop 'lisp::fop-funcall file)
-  (dump-byte 0 file))
-|#
-
-
-;;;; Number Dumping:
-
-;;; Dump a ratio
-
-(defun dump-ratio (x file)
-  (dump-object (numerator x) file)
-  (dump-object (denominator x) file)
-  (dump-fop 'lisp::fop-ratio file))
-
-;;; Or a complex...
-
-(defun dump-complex (x file)
-  (dump-object (realpart x) file)
-  (dump-object (imagpart x) file)
-  (dump-fop 'lisp::fop-complex file))
-
-;;; Dump an integer.
-
-
-;;; Compute how many bytes it will take to represent signed integer N.
-
-(defun compute-bytes (n)
-  (truncate (+ (integer-length n) 8) 8))
-
-
-(defun dump-integer (n file)
-  (let* ((bytes (compute-bytes n)))
-    (cond ((= bytes 1)
-	   (dump-fop 'lisp::fop-byte-integer file)
-	   (dump-byte n file))
-	  ((< bytes 5)
-	   (dump-fop 'lisp::fop-word-integer file)
-	   (quick-dump-number n 4 file))
-	  ((< bytes 256)
-	   (dump-fop 'lisp::fop-small-integer file)
-	   (dump-byte bytes file)
-	   (quick-dump-number n bytes file))
-	  (t
-	   (dump-fop 'lisp::fop-integer file)
-	   (quick-dump-number bytes 4 file)
-	   (quick-dump-number n bytes file)))))
-
-
-(defun dump-float (x file)
-  (multiple-value-bind (f exponent sign) (decode-float x)
-    (let ((mantissa (truncate (scale-float (* f sign) (float-precision f)))))
-      (dump-fop 'lisp::fop-float file)
-      (dump-byte (1+ (integer-length exponent)) file)
-      (quick-dump-number exponent (compute-bytes exponent) file)
-      (dump-byte (1+ (integer-length mantissa)) file)
-      (quick-dump-number mantissa (compute-bytes mantissa) file))))
-
-
-;;;; Symbol Dumping:
-
-
-;;; Dump-Package  --  Internal
-;;;
-;;;    Return the table index of Pkg, adding the package to the table if
-;;; necessary.  During cold load, we read the string as a normal string so that
-;;; we can do the package lookup at cold load time.
-;;;
-(defun dump-package (pkg file)
-  (cond ((cdr (assoc pkg (fasl-file-packages file))))
-	(t
-	 (unless *cold-load-dump*
-	   (dump-fop 'lisp::fop-normal-load file))
-	 (dump-string (package-name pkg) file)
-	 (dump-fop 'lisp::fop-package file)
-	 (unless *cold-load-dump*
-	   (dump-fop 'lisp::fop-maybe-cold-load file))
-	 (let ((entry (dump-pop file)))
-	   (push (cons pkg entry) (fasl-file-packages file))
-	   entry))))
-
-
-;;; Dump-Symbol  --  Internal
-;;;
-;;;    If we get here, it is assumed that the symbol isn't in the table, but we
-;;; are responsible for putting it there when appropriate.  To avoid too much
-;;; special-casing, we always push the symbol in the table, but forget that we
-;;; have done so if *Cold-Load-Dump* is true.
-;;;
-(defun dump-symbol (s file)
-  (let* ((pname (symbol-name s))
-	 (pname-length (length pname))
-	 (pkg (symbol-package s)))
-
-    (cond ((null pkg)
-	   (dump-fop* pname-length lisp::fop-uninterned-small-symbol-save
-		      lisp::fop-uninterned-symbol-save file))
-	  ((eq pkg *package*)
-	   (dump-fop* pname-length lisp::fop-small-symbol-save
-		      lisp::fop-symbol-save file))
-	  ((eq pkg ext:*lisp-package*)
-	   (dump-fop* pname-length lisp::fop-lisp-small-symbol-save
-		      lisp::fop-lisp-symbol-save file))
-	  ((eq pkg ext:*keyword-package*)
-	   (dump-fop* pname-length lisp::fop-keyword-small-symbol-save
-		      lisp::fop-keyword-symbol-save file))
-	  ((< pname-length 256)
-	   (dump-fop* (dump-package pkg file)
-		      lisp::fop-small-symbol-in-byte-package-save
-		      lisp::fop-small-symbol-in-package-save file)
-	   (dump-byte pname-length file))
-	  (t
-	   (dump-fop* (dump-package pkg file)
-		      lisp::fop-symbol-in-byte-package-save
-		      lisp::fop-symbol-in-package-save file)
-	   (quick-dump-number pname-length 4 file)))
-
-    (write-string pname (fasl-file-stream file))
-
-    (unless *cold-load-dump*
-      (setf (gethash s (fasl-file-table file)) (fasl-file-table-free file)))
-
-    (incf (fasl-file-table-free file)))
-
-  (undefined-value))
-
-
-;;; Dumper for lists.
-
-(defun dump-list (list file)
-  (do ((l list (cdr l))
-       (n 0 (1+ n)))
-      ((atom l)
-       (cond ((null l)
-	      (terminate-undotted-list n file))
-	     (t (dump-object l file)
-		(terminate-dotted-list n file))))
-    (dump-object (car l) file)))
-
-
-(defun terminate-dotted-list (n file)
-  (case n
-    (1 (dump-fop 'lisp::fop-list*-1 file))
-    (2 (dump-fop 'lisp::fop-list*-2 file))
-    (3 (dump-fop 'lisp::fop-list*-3 file))
-    (4 (dump-fop 'lisp::fop-list*-4 file))
-    (5 (dump-fop 'lisp::fop-list*-5 file))
-    (6 (dump-fop 'lisp::fop-list*-6 file))
-    (7 (dump-fop 'lisp::fop-list*-7 file))
-    (8 (dump-fop 'lisp::fop-list*-8 file))
-    (T (do ((nn n (- nn 255)))
-	   ((< nn 256)
-	    (dump-fop 'lisp::fop-list* file)
-	    (dump-byte nn file))
-	 (dump-fop 'lisp::fop-list* file)
-	 (dump-byte 255 file)))))
-
-;;; If N > 255, must build list with one list operator, then list* operators.
-
-(defun terminate-undotted-list (n file)
-  (case n
-    (1 (dump-fop 'lisp::fop-list-1 file))
-    (2 (dump-fop 'lisp::fop-list-2 file))
-    (3 (dump-fop 'lisp::fop-list-3 file))
-    (4 (dump-fop 'lisp::fop-list-4 file))
-    (5 (dump-fop 'lisp::fop-list-5 file))
-    (6 (dump-fop 'lisp::fop-list-6 file))
-    (7 (dump-fop 'lisp::fop-list-7 file))
-    (8 (dump-fop 'lisp::fop-list-8 file))
-    (T (cond ((< n 256)
-	      (dump-fop 'lisp::fop-list file)
-	      (dump-byte n file))
-	     (t (dump-fop 'lisp::fop-list file)
-		(dump-byte 255 file)
-		(do ((nn (- n 255) (- nn 255)))
-		    ((< nn 256)
-		     (dump-fop 'lisp::fop-list* file)
-		     (dump-byte nn file))
-		  (dump-fop 'lisp::fop-list* file)
-		  (dump-byte 255 file)))))))
-
-;;;; Array dumping:
-
-;;; Named G-vectors get their subtype field set at load time.
-
-(defun dump-vector (obj file)
-  (cond ((and (simple-vector-p obj)
-	      (= (%primitive get-vector-subtype obj)
-		 %g-vector-structure-subtype))
-	 (normal-dump-vector obj file)
-	 (dump-fop 'lisp::fop-structure file))
-	(t
-	 (normal-dump-vector obj file))))
-
-(defun normal-dump-vector (v file)
-  (do ((index 0 (1+ index))
-       (length (length v)))
-      ((= index length)
-       (dump-fop* length lisp::fop-small-vector lisp::fop-vector file))
-    (dump-object (aref v index) file)))
-
-;;; Dump a string.
-
-(defun dump-string (s file)
-  (let ((length (length s)))
-    (dump-fop* length lisp::fop-small-string lisp::fop-string file)
-    (dotimes (i length)
-      (dump-byte (char-code (char s i)) file))))
-
-
-;;; Dump-Array  --  Internal
-;;;
-;;;    Dump a multi-dimensional array.  Someday when we figure out what
-;;; a displaced array looks like, we can fix this.
-;;;
-(defun dump-array (array file)
-  (unless (zerop (%primitive header-ref array %array-displacement-slot))
-    (compiler-error-message "Cannot dump displaced array:~%  ~S" array)
-    (dump-fop 'lisp::fop-misc-trap file)
-    (return-from dump-array nil))
-
-  (let ((rank (array-rank array)))
-    (dotimes (i rank)
-      (dump-integer (array-dimension array i) file))
-    (dump-object (%primitive header-ref array %array-data-slot) file)
-    (dump-fop 'lisp::fop-array file)
-    (quick-dump-number rank 4 file)))
-
-
-;;; Dump-I-Vector  --  Internal  
-;;;
-;;;    Dump an I-Vector using the Guy Steele memorial fasl-operation.
-;;;
-(defun dump-i-vector (vec file)
-  (let* ((len (length vec))
-	 (ac (%primitive get-vector-access-code
-			 (if #-new-compiler (%primitive complex-array-p vec)
-			     #+new-compiler (array-header-p vec)
-			     (%primitive header-ref vec %array-data-slot)
-			     vec)))
-	 (size (ash 1 ac))
-	 (count (ceiling size 8))
-	 (ints-per-entry (floor (* count 8) size)))
-    (declare (fixnum len ac size count ints-per-entry))
-    (dump-fop 'lisp::fop-int-vector file)
-    (quick-dump-number len 4 file)
-    (dump-byte size file)
-    (dump-byte count file)
-    (if (> ints-per-entry 1)
-	(do ((prev 0 end)
-	     (end ints-per-entry (the fixnum (+ end ints-per-entry))))
-	    ((>= end len)
-	     (unless (= prev len)
-	       (do ((pos (* (1- ints-per-entry) size) (- pos size))
-		    (idx prev (1+ idx))
-		    (res 0))
-		   ((= idx len)
-		    (dump-byte res file))
-		 (setq res (dpb (aref vec idx) (byte size pos) res)))))
-	  (declare (fixnum prev end))
-	  (do* ((idx prev (1+ idx))
-		(res 0))
-	       ((= idx end)
-		(dump-byte res file))
-	    (declare (fixnum idx))
-	    (setq res (logior (ash res size) (aref vec idx)))))
-	(dotimes (i len)
-	  (declare (fixnum i))
-	  (quick-dump-number (aref vec i) count file)))))
-
-
-;;; Dump a character.
-
-(defun dump-character (ch file)
-  (cond
-   ((string-char-p ch)
-    (dump-fop 'lisp::fop-short-character file)
-    (dump-byte (char-code ch) file))
-   (t
-    (dump-fop 'lisp::fop-character file)
-    (dump-byte (char-code ch) file)
-    (dump-byte (char-bits ch) file)
-    (dump-byte (char-font ch) file))))
diff --git a/compiler/old-rt/pred.lisp b/compiler/old-rt/pred.lisp
deleted file mode 100644
index ba3e1ae22b0e09ba2432298f3b4d3ef1a54b8a32..0000000000000000000000000000000000000000
--- a/compiler/old-rt/pred.lisp
+++ /dev/null
@@ -1,48 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    This file contains the VM definition of predicate VOPs for the RT.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-
-;;;; The Branch VOP.
-
-;;; The unconditional branch, emitted when we can't drop through to the desired
-;;; destination.  Dest is the continuation we transfer control to.
-;;;
-(define-vop (branch)
-  (:info dest)
-  (:generator 5
-    (inst bnb :pz dest)))
-
-
-;;;; Conditional VOPs:
-
-;if-true (???), if-eql, ...
-
-(define-vop (if-eq)
-  (:args (x :scs (any-reg descriptor-reg))
-	 (y :scs (any-reg descriptor-reg)))
-  (:conditional)
-  (:info target not-p)
-  (:policy :fast-safe)
-  (:translate eq)
-  (:generator 3
-    (inst c x y)
-    (if not-p
-	(inst bnb :eq target)
-	(inst bb :eq target))))
-
-
-(define-vop (if-eql two-arg-conditional-miscop)
-  (:variant 'eql :eq)
-  (:translate eql))
diff --git a/compiler/old-rt/print.lisp b/compiler/old-rt/print.lisp
deleted file mode 100644
index 24fe117ad8664fbf01eeb1fd7d2e3fc6546ae9a2..0000000000000000000000000000000000000000
--- a/compiler/old-rt/print.lisp
+++ /dev/null
@@ -1,27 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    Debugging versions of Print, Write-String and Read-Char that call
-;;; miscops.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-(define-vop (print one-arg-miscop)
-  (:variant 'print))
-
-(define-vop (read-char zero-arg-miscop)
-  (:variant 'read-char))
-
-(define-vop (write-string three-arg-miscop)
-  (:variant 'write-string))
-
-(define-vop (halt zero-arg-miscop)
-  (:variant 'clc::halt))
diff --git a/compiler/old-rt/subprim.lisp b/compiler/old-rt/subprim.lisp
deleted file mode 100644
index 449ddf8bac4a1c61fd3c1fb470777306d6327d8c..0000000000000000000000000000000000000000
--- a/compiler/old-rt/subprim.lisp
+++ /dev/null
@@ -1,163 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    Linkage information for standard miscops, both primitive and
-;;; sub-primitive.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-
-;;;; Subprimitive miscops:
-
-#| Inline versions exist, and we can't currently support multiple
-implementations, since they are accessed through %primitive.
-
-(define-miscop 16bit-system-ref (s i))
-(define-miscop 16bit-system-set (s i v))
-(define-miscop 8bit-system-ref (s i))
-(define-miscop 8bit-system-set (s i v))
-|#
-
-(define-miscop active-call-frame ())
-(define-miscop active-catch-frame ())
-(define-miscop alloc-array (n))
-(define-miscop alloc-bit-vector (n))
-(define-miscop alloc-code (n))
-(define-miscop alloc-function (n))
-(define-miscop alloc-g-vector (n i))
-(define-miscop alloc-i-vector (n a))
-(define-miscop alloc-static-g-vector (len))
-(define-miscop alloc-string (n))
-(define-miscop bit-bash (v1 v2 res op) :results ())
-(define-miscop break-return (stack) :results ())
-(define-miscop call-foreign (cfcn args nargs))
-#|Inline implementation...
-(define-miscop check-<= (n l))
-|#
-(define-miscop collect-garbage () :results ())
-(define-miscop current-binding-pointer ())
-(define-miscop current-stack-pointer ())
-(define-miscop dynamic-space-in-use ())
-(define-miscop error0 (code) :results ())
-(define-miscop error1 (code x) :results ())
-(define-miscop error2 (code x y) :results ())
-(define-miscop find-character (string start end character))
-(define-miscop find-character-with-attribute (a b c d e))
-(define-miscop float-long (x))
-(define-miscop float-short (x))
-(define-miscop get-allocation-space ())
-(define-miscop get-space (x))
-(define-miscop get-type (x))
-(define-miscop get-vector-access-code (v))
-#|Inline implementation...
-(define-miscop get-vector-subtype (v))
-|#
-(define-miscop halt ())
-#|Inline implementation...
-(define-miscop header-length (x))
-(define-miscop header-ref (x i))
-(define-miscop header-set (x i v))
-|#
-(define-miscop logdpb (v s p n))
-(define-miscop logldb (s p n))
-(define-miscop long-float-ref (l i))
-(define-miscop long-float-set (l i x))
-(define-miscop lsh (n b))
-(define-miscop make-complex (re im))
-(define-miscop make-immediate-type (obj type))
-(define-miscop make-ratio (num den))
-(define-miscop negate (n))
-(define-miscop newspace-bit ())
-(define-miscop pointer-system-set (s i p))
-(define-miscop purify () :results ())
-(define-miscop read-binding-stack (b))
-(define-miscop read-control-stack (f))
-(define-miscop reset-c-stack (sp) :results ())
-(define-miscop return-to-c (sp value) :results ())
-(define-miscop sap-system-ref (s i))
-(define-miscop save (x y z))
-(define-miscop set-allocation-space (space) :results ())
-(define-miscop set-c-procedure-pointer (s o v))
-(define-miscop set-call-frame (p))
-(define-miscop set-catch-frame (x))
-(define-miscop set-vector-subtype (v x))
-(define-miscop shrink-vector (v n))
-#|Inline implementation...
-(define-miscop signed-16bit-system-ref (s i))
-|#
-(define-miscop signed-32bit-system-ref (s i))
-(define-miscop signed-32bit-system-set (s i v) :translate (setf sap-ref-32))
-(define-miscop sxhash-simple-string (string))
-(define-miscop sxhash-simple-substring (string length))
-(define-miscop syscall0 (n) :results (res err))
-(define-miscop syscall1 (n x) :results (res err))
-(define-miscop syscall2 (n x y) :results (res err))
-(define-miscop syscall3 (n x y z) :results (res err))
-(define-miscop syscall4 (n x y z xx) :results (res err))
-(define-miscop typed-vref (a v i))
-(define-miscop typed-vset (a v i x))
-(define-miscop unbind-to-here (x) :results ())
-(define-miscop unix-fork (code-ptr) :results (res err))
-(define-miscop unix-pipe () :results (res err))
-(define-miscop unix-wait () :results (res err))
-(define-miscop unix-write (fd buf offset len) :results (res err))
-(define-miscop unsigned-32bit-system-ref (s i) :translate sap-ref-32)
-(define-miscop vector-length (vec))
-(define-miscop write-binding-stack (b v))
-(define-miscop write-control-stack (f v))
-
-(define-vop (syscall n-arg-two-value-miscop)
-  (:variant 'clc::syscall))
-
-(def-primitive-translator float-single (x)
-  `(%primitive float-short ,x))
-
-
-;;;; Primitive miscops:
-
-(defknown ext:assq (t list) list (foldable flushable))
-(defknown ext:memq (t list) list (foldable flushable))
-
-(define-miscop abs (num) :translate abs)
-(define-miscop alloc-symbol (name) :translate make-symbol)
-(define-miscop ash (i n) :translate ash)
-(define-miscop assq (key alist) :translate ext:assq)
-(define-miscop atan (x) :translate atan)
-(define-miscop cos (x) :translate cos)
-(define-miscop decode-float (f) :results (frac exp sign) :translate decode-float)
-(define-miscop exp (x) :translate exp)
-(define-miscop gcd (x y) :translate gcd)
-(define-miscop get-real-time () :translate get-internal-real-time)
-(define-miscop get-run-time () :translate get-internal-run-time)
-(define-miscop integer-length (i) :translate integer-length)
-(define-miscop last (l) :translate last)
-(define-miscop log (n) :translate log)
-(define-miscop logcount (i) :translate logcount)
-(define-miscop memq (item list) :translate ext:memq)
-(define-miscop nthcdr (n l) :translate nthcdr)
-(define-miscop put (sym prop val) :translate %put)
-(define-miscop sap-int (sap) :translate sap-int)
-(define-miscop scale-float (f exp) :translate scale-float)
-(define-miscop sin (x) :translate sin)
-(define-miscop sqrt (x) :translate sqrt)
-(define-miscop tan (x) :translate tan)
-
-(define-vop (list n-arg-miscop)
-  (:variant 'list))
-
-(define-vop (list* n-arg-miscop)
-  (:variant 'list*))
-
-;;; Continuation to allow %sp-byte-blt for now...
-(defknown lisp::%sp-byte-blt (t index t index index) void ())
-(define-miscop byte-blt (src src-start dst dst-start dst-end)
-  :translate lisp::%sp-byte-blt)
-
diff --git a/compiler/old-rt/type-vops.lisp b/compiler/old-rt/type-vops.lisp
deleted file mode 100644
index 55c37560b568270ecc1c7b001d7e327318d67678..0000000000000000000000000000000000000000
--- a/compiler/old-rt/type-vops.lisp
+++ /dev/null
@@ -1,259 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    This file contains the VM definition of type testing and checking VOPs
-;;; for the RT.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-;;;; Simple type checking and testing:
-;;;
-;;;    These types are represented by a single type code, so are easily
-;;; open-coded as non-shifting type test.
-
-(define-vop (check-simple-type)
-  (:args
-   (value :target result
-	  :scs (any-reg descriptor-reg)))
-  (:results
-   (result :scs (any-reg descriptor-reg)))
-  (:variant-vars type-code error-code)
-  (:vop-var vop)
-  (:save-p :compute-only)
-  (:temporary (:type random  :scs (non-descriptor-reg)) temp)
-  (:generator 4
-    (let ((err-lab (generate-error-code vop error-code value)))
-      (test-simple-type value temp err-lab t type-code)
-      (unless (location= value result)
-	(inst lr result value)))))
-
-(define-vop (simple-type-predicate)
-  (:args
-   (value :scs (any-reg descriptor-reg)))
-  (:conditional)
-  (:info target not-p)
-  (:variant-vars type-code)
-  (:policy :fast-safe)
-  (:temporary (:type random  :scs (non-descriptor-reg)) temp)
-  (:generator 4
-    (test-simple-type value temp target not-p type-code)))
-
-
-(macrolet ((frob (pred-name check-name ptype type-code error-code)
-	     `(progn
-		(define-vop (,pred-name simple-type-predicate)
-		  (:variant ,type-code)
-		  (:translate ,pred-name))
-
-		,@(when check-name
-		    `((define-vop (,check-name check-simple-type)
-			(:variant ,type-code ,error-code))
-		      (primitive-type-vop ,check-name (:check) ,ptype))))))
-
-  (frob array-header-p nil nil system:%array-type nil)
-
-  (frob simple-string-p check-simple-string simple-string
-    system:%string-type clc::error-object-not-simple-string)
-
-  (frob simple-vector-p check-simple-vector simple-vector
-    system:%general-vector-type clc::error-object-not-simple-vector)
-
-  (frob simple-bit-vector-p check-simple-bit-vector simple-bit-vector
-    system:%bit-vector-type clc::error-object-not-simple-bit-vector)
-
-  (frob functionp check-function function
-    system:%function-type clc::error-illegal-function)
-
-  (frob listp check-list list system:%list-type clc::error-not-list)
-
-  (frob long-float-p check-long-float long-float
-    system:%long-float-type clc::error-object-not-long-float)
-
-  (frob %string-char-p check-string-char string-char
-    system:%string-char-type clc::error-object-not-string-char)
-
-  (frob bignump nil bignum system:%bignum-type nil)
-  (frob ratiop nil ratio system:%ratio-type nil)
-  (frob complexp nil complex system:%complex-type nil))
-
-#|
-simple-integer-vector-p?
-|#
-
-
-
-;;;; Type checking and testing via miscops:
-;;;
-;;;    These operations seem too complex to be worth open-coding.
-
-(macrolet ((frob (name)
-	     `(define-vop (,name one-arg-conditional-miscop)
-		(:translate ,name)
-		(:variant ',name :eq))))
-  (frob vectorp)
-  (frob stringp)
-  (frob bit-vector-p))
-
-
-;;;; Hairy type tests:
-;;;
-;;;    These types are represented by a union of type codes.  
-;;;
-
-(define-vop (hairy-type-predicate)
-  (:args
-   (obj :scs (any-reg descriptor-reg)
-	:target temp))
-  (:conditional)
-  (:info target not-p)
-  (:policy :fast-safe)
-  (:temporary (:scs (any-reg)
-		    :type fixnum
-		    :from (:argument 0))
-	      temp))
-
-(define-vop (check-hairy-type)
-  (:args
-   (obj :scs (any-reg descriptor-reg)
-	:target res))
-  (:results
-   (res :scs (any-reg descriptor-reg)))
-  (:temporary (:scs (any-reg) :type fixnum) temp)
-  (:vop-var vop)
-  (:save-p :compute-only))
-
-  
-(macrolet ((frob (pred-name check-name error-code &rest types)
-	     (let ((cost (* (+ (length types)
-			       (count-if #'consp types))
-			    4)))
-	       `(progn
-		  ,@(when pred-name
-		      `((define-vop (,pred-name hairy-type-predicate)
-			  (:translate ,pred-name)
-			  (:generator ,cost
-			    (test-hairy-type obj temp target not-p ,@types)))))
-			
-		  ,@(when check-name
-		      `((define-vop (,check-name check-hairy-type)
-			  (:generator ,cost
-			    (let ((err-lab (generate-error-code
-					    vop ,error-code obj)))
-			      (test-hairy-type obj temp err-lab t ,@types))
-			    (unless (location= obj res)
-			      (inst lr res obj))))))))))
-
-  (frob nil check-function-or-symbol clc::error-object-not-function-or-symbol
-    system:%function-type system:%symbol-type)
-
-  (frob arrayp nil nil (system:%string-type system:%array-type))
-
-  (frob numberp nil nil
-    system:%+-fixnum-type system:%--fixnum-type
-    (system:%bignum-type system:%long-float-type))
-
-  (frob rationalp nil nil
-    system:%+-fixnum-type system:%--fixnum-type
-    system:%ratio-type system:%bignum-type)
-
-  (frob floatp nil nil (system:%short-+-float-type system:%long-float-type))
-
-  (frob integerp nil nil
-    system:%+-fixnum-type system:%--fixnum-type system:%bignum-type)
-
-  (frob characterp nil nil system:%bitsy-char-type system:%string-char-type)
-  
-  (frob fixnump check-fixnum clc::error-object-not-fixnum
-    system:%+-fixnum-type system:%--fixnum-type)
-
-  (frob short-float-p check-short-float clc::error-object-not-short-float
-    system:%short---float-type system:%short-+-float-type))
-
-(primitive-type-vop check-fixnum (:check) fixnum)
-(primitive-type-vop check-short-float (:check) short-float)
-
-
-;;;; List/symbol types:
-
-
-;;; symbolp (or symbol (eq nil))
-;;; consp (and list (not (eq nil)))
-
-(define-vop (list-symbol-predicate)
-  (:args
-   (obj :scs (any-reg descriptor-reg)))
-  (:conditional)
-  (:info target not-p)
-  (:policy :fast-safe)
-  (:temporary (:type random  :scs (non-descriptor-reg)) temp)))
-
-(define-vop (check-list-symbol check-hairy-type)
-  (:temporary (:type random  :scs (non-descriptor-reg)) temp))
-
-
-(macrolet ((frob (pred-name check-name error-code &rest body)
-	     `(progn
-		(define-vop (,pred-name list-symbol-predicate)
-		  (:translate ,pred-name)
-		  (:generator 12
-		    ,@body))
-		(define-vop (,check-name check-list-symbol)
-		  (:generator 12
-		    (let ((target (generate-error-code vop ,error-code obj))
-			  (not-p t))
-		      ,@body
-		      (unless (location= obj res)
-			(inst lr res obj))))))))
-
-  (frob symbolp check-symbol clc::error-not-symbol
-    (let* ((drop-thru (gen-label))
-	   (in-lab (if not-p drop-thru target)))
-      (test-simple-type obj temp in-lab nil system:%symbol-type)
-      (test-special-value obj temp nil target not-p)
-      (emit-label drop-thru)))
-
-  (frob consp check-cons clc::error-object-not-cons
-    (let* ((drop-thru (gen-label))
-	   (out-lab (if not-p target drop-thru)))
-      (test-simple-type obj temp out-lab t system:%list-type)
-      (test-special-value obj temp nil target (not not-p))
-      (emit-label drop-thru))))
-
-
-;;;; Function coercion:
-
-;;; If not a function, get the symbol value and test for that being a function.
-;;; Since we test for a function rather than the unbound marker, this works on
-;;; NIL.
-;;;
-(define-vop (coerce-to-function)
-  (:args (thing :scs (descriptor-reg)
-		:target res))
-  (:results (res :scs (descriptor-reg)))
-  (:node-var node)
-  (:temporary (:type random  :scs (non-descriptor-reg)) temp)
-  (:temporary (:scs (descriptor-reg)) thing-temp)
-  (:generator 0
-    (let ((not-fun-lab (gen-label))
-	  (done-lab (gen-label)))
-      (test-simple-type thing temp not-fun-lab t system:%function-type)
-      (unless (location= thing res)
-	(inst lr res thing))
-      (emit-label done-lab)
-
-      (unassemble
-	(assemble-elsewhere node
-	  (emit-label not-fun-lab)
-	  (inst lr thing-temp thing)
-	  (loadw res thing (/ clc::symbol-definition 4))
-	  (test-simple-type res temp done-lab nil system:%function-type)
-	  (error-call clc::error-symbol-undefined thing-temp))))))
-
diff --git a/compiler/old-rt/values.lisp b/compiler/old-rt/values.lisp
deleted file mode 100644
index 9875b207a1e0dbfa3b182db258db4899efa08b7f..0000000000000000000000000000000000000000
--- a/compiler/old-rt/values.lisp
+++ /dev/null
@@ -1,64 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    This file contains the implementation of unknown-values VOPs.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-(define-vop (reset-stack-pointer)
-  (:args (ptr :scs (any-reg)))
-  (:generator 1
-    (inst lr sp-tn ptr)))
-
-
-;;; Push some values onto the stack, returning the start and number of values
-;;; pushed as results.  It is assumed that the Vals are wired to the standard
-;;; argument locations.  Nvals is the number of values to push.
-;;;
-;;; The generator cost is pseudo-random.  We could get it right by defining a
-;;; bogus SC that reflects the costs of the memory-to-memory moves for each
-;;; operand, but this seems unworthwhile.
-;;;
-(define-vop (push-values)
-  (:args
-   (vals :more t))
-  (:results
-   (start :scs (descriptor-reg))
-   (count :scs (any-reg descriptor-reg)))
-  (:info nvals)
-  (:temporary (:scs (descriptor-reg)) temp)
-  (:temporary (:scs (descriptor-reg)
-	       :to (:result 0)
-	       :target start)
-	      start-temp)
-  (:generator 20
-    (inst lr start-temp sp-tn)
-    (inst cal sp-tn sp-tn (* nvals 4))
-    (do ((val vals (tn-ref-across val))
-	 (i 0 (1+ i)))
-	((null val))
-      (let ((tn (tn-ref-tn val)))
-	(sc-case tn
-	  (descriptor-reg
-	   (storew tn start-temp i))
-	  (stack
-	   (load-stack-tn temp tn)
-	   (storew temp start-temp i)))))
-    (unless (location= start-temp start)
-      (inst lr start start-temp))
-    (loadi count nvals)))
-
-
-;;; Push a list of values on the stack, returning Start and Count as used in
-;;; unknown values continuations.
-;;;
-(define-vop (values-list one-arg-two-value-miscop)
-  (:variant 'clc::values-list))
diff --git a/compiler/old-rt/vm-tran.lisp b/compiler/old-rt/vm-tran.lisp
deleted file mode 100644
index 73afd5c20acfc2ded79a828b9f48c363f1d018a3..0000000000000000000000000000000000000000
--- a/compiler/old-rt/vm-tran.lisp
+++ /dev/null
@@ -1,33 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    This file contains impelemtentation-dependent transforms.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-;;; We need to define these predicates, since the TYPEP source transform picks
-;;; whichever predicate was defined last when there are multiple predicates for
-;;; equivalent types.
-;;;
-(def-source-transform single-float-p (x) `(short-float-p ,x))
-(def-source-transform double-float-p (x) `(long-float-p ,x))
-
-(def-source-transform structurep (x)
-  (once-only ((n-x x))
-    `(and (simple-vector-p ,n-x)
-	  (eql (%primitive get-vector-subtype ,n-x)
-	       system:%g-vector-structure-subtype))))
-
-(def-source-transform compiled-function-p (x)
-  `(functionp ,x))
-
-(def-source-transform char-int (x)
-  `(truly-the char-int (%primitive make-fixnum ,x)))
diff --git a/compiler/old-rt/vm-type.lisp b/compiler/old-rt/vm-type.lisp
deleted file mode 100644
index 608b34f2b8caaf3824b7bad5cddc5e08e632e9ab..0000000000000000000000000000000000000000
--- a/compiler/old-rt/vm-type.lisp
+++ /dev/null
@@ -1,137 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    This file contains implementation-dependent parts of the type support
-;;; code.  This is stuff which deals with the mapping from types defined in
-;;; Common Lisp to types actually supported by an implementation.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-;;;; Implementation dependent deftypes:
-
-;;; Make double-float a synonym for long-float, single-float for Short-Float.
-;;; This is be expanded before the translator gets a chance, so we will get
-;;; precedence.
-;;;
-(deftype double-float (&optional low high)
-  `(long-float ,low ,high))
-;;;
-(deftype single-float (&optional low high)
-  `(short-float ,low ,high))
-
-;;; Compiled-function is the same as function in this implementation.
-;;;
-(deftype compiled-function () 'function)
-
-;;;
-;;; An index into an integer.
-(deftype bit-index () `(integer 0 ,most-positive-fixnum))
-;;;
-;;; Offset argument to Ash (a signed bit index).
-(deftype ash-index () 'fixnum)
-;;;
-;;; A lexical environment for macroexpansion.
-(deftype lexical-environment () '(or list lisp::lexical-environment))
-;;;
-;;; A full lexical environment.
-(deftype full-lexical-environment () 'lisp::lexical-environment)
-;;;
-;;; Worst case values for float attributes.
-;;; ### long-float exponent range seems to be this, but I don't know why.
-;;; Perhaps IEEE double uses some of the negative exponents for NAN, etc?
-;;;
-(deftype float-exponent () '(integer -1021 1024))
-(deftype float-digits () '(unsigned-byte 6))
-(deftype float-radix () '(integer 2 2))
-;;;
-;;; A code for Boole.
-(deftype boole-code () '(unsigned-byte 4))
-;;;
-;;; A byte-specifier.
-(deftype byte-specifier () 'cons)
-;;;
-;;; Result of Char-Int...
-(deftype char-int () '(unsigned-byte 16))
-;;;
-;;; Legal character bit names:
-(deftype bit-names () '(member :control :meta :super :hyper))
-;;;
-;;; Pathname pieces, as returned by the PATHNAME-xxx functions.
-(deftype pathname-host () '(or simple-string null)); Host not really supported...
-(deftype pathname-device () '(or simple-string (member :absolute nil)))
-(deftype pathname-directory () '(or simple-vector null))
-(deftype pathname-name () '(or simple-string null))
-(deftype pathname-type () '(or simple-string null))
-(deftype pathname-version () '(or simple-string (member nil :newest)))
-;;;
-;;; Internal time format.  Not a fixnum (blag...)
-(deftype internal-time () 'unsigned-byte)
-
-
-;;;; Hooks into type system:
-
-;;; The kinds of specialised array that actually exist in this implementation.
-;;;
-(defparameter specialized-array-element-types
-  '(bit (unsigned-byte 2) (unsigned-byte 4) (unsigned-byte 8) (unsigned-byte 16)
-	(unsigned-byte 32) string-char))
-
-;;; Float-Format-Name  --  Internal
-;;;
-;;;    Return the symbol that describes the format of Float.
-;;;
-(proclaim '(function float-format-name (float) symbol))
-(defun float-format-name (x)
-  (etypecase x
-    (short-float 'short-float)
-    (long-float 'long-float)))
-
-;;; Specialize-Array-Type  --  Internal
-;;;
-;;;    This function is called when the type code wants to find out how an
-;;; array will actually be implemented.  We set the Specialized-Element-Type to
-;;; correspond to the actual specialization used in this implementation.
-;;;
-(proclaim '(function specialize-array-type (array-type) array-type))
-(defun specialize-array-type (type)
-  (let ((eltype (array-type-element-type type)))
-
-    (setf (array-type-specialized-element-type type)
-	  (if (eq eltype *wild-type*)
-	      *wild-type*
-	      (dolist (stype-name specialized-array-element-types
-				  (specifier-type 't))
-		(let ((stype (specifier-type stype-name)))
-		  (when (csubtypep eltype stype)
-		    (return stype))))))
-
-    type))
-
-
-;;; Hairy-Type-Check-Template  --  Interface
-;;;
-;;;    If Type has a CHECK-xxx template, but doesn't have a corresponding
-;;; primitive-type, then return the template's name.  Otherwise, return NIL.
-;;;
-(defun hairy-type-check-template (type)
-  (declare (type ctype type))
-  (typecase type
-    (named-type
-     (case (named-type-name type)
-       (cons 'check-cons)
-       (symbol 'check-symbol)
-       (t nil)))
-    (union-type
-     (if (type= type (specifier-type '(or function symbol)))
-	 'check-function-or-symbol
-	 nil))
-    (t
-     nil)))
diff --git a/compiler/pack.lisp b/compiler/pack.lisp
deleted file mode 100644
index a7af596c3d56c0ab29db3f60195e16ed9f5c5c7a..0000000000000000000000000000000000000000
--- a/compiler/pack.lisp
+++ /dev/null
@@ -1,1037 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    This file contains the implementation independent code for Pack phase in
-;;; the compiler and utilities used for manipulating TNs.  Pack is responsible
-;;; for assigning TNs to storage allocations or "register allocation".
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-
-;;;; Conflict determination:
-
-
-;;; Offset-Conflicts-In-SB  --  Internal
-;;;
-;;; Return true if the element at the specified offset in SB has a conflict
-;;; with TN:
-;;; -- If an environment-live TN (:environment kind), then iterate over all the
-;;;    blocks in its environment.  If the element at Offset is used anywhere in
-;;;    any of the environment's blocks (always-live /= 0), then there is a
-;;;    conflict.
-;;; -- If TN is global (Confs true), then iterate over the blocks TN is live in
-;;;    (using TN-Global-Conflicts).  If the TN is live everywhere in the block
-;;;    (:Live), then there is a conflict if the element at offset is used
-;;;    anywhere in the block (Always-Live /= 0).  Otherwise, we use the local
-;;;    TN number for TN in block to find whether TN has a conflict at Offset in
-;;;    that block.
-;;; -- If TN is local, then we just check for a conflict in the block it is
-;;;    local to.
-;;;
-(defun offset-conflicts-in-sb (tn sb offset)
-  (declare (type tn tn) (type finite-sb sb) (type unsigned-byte offset))
-  (let ((confs (tn-global-conflicts tn)))
-    (cond
-     ((eq (tn-kind tn) :environment)
-      (let ((loc-live (svref (finite-sb-always-live sb) offset)))
-	(do ((env-block (ir2-environment-blocks (tn-environment tn))
-			(ir2-block-environment-next env-block)))
-	    ((null env-block)
-	     nil)
-	  (when (/= (sbit loc-live (ir2-block-number env-block)) 0)
-	    (return t)))))
-     (confs
-      (let ((loc-confs (svref (finite-sb-conflicts sb) offset))
-	    (loc-live (svref (finite-sb-always-live sb) offset)))
-	(do ((conf confs (global-conflicts-tn-next conf)))
-	    ((null conf)
-	     nil)
-	  (let* ((block (global-conflicts-block conf))
-		 (num (ir2-block-number block)))
-	    (if (eq (global-conflicts-kind conf) :live)
-		(when (/= (sbit loc-live num) 0)
-		  (return t))
-		(when (/= (sbit (svref loc-confs num)
-				(global-conflicts-number conf))
-			  0)
-		  (return t)))))))
-     (t
-      (/= (sbit (svref (svref (finite-sb-conflicts sb) offset)
-		       (ir2-block-number (tn-local tn)))
-		(tn-local-number tn))
-	  0)))))
-
-
-;;; Conflicts-In-SC  --  Internal
-;;;
-;;;    Return true if TN has a conflict in SC at the specified offset.
-;;;
-(defun conflicts-in-sc (tn sc offset)
-  (declare (type tn tn) (type sc sc) (type unsigned-byte offset))
-  (let ((sb (sc-sb sc)))
-    (dotimes (i (sc-element-size sc) nil)
-      (when (offset-conflicts-in-sb tn sb (+ offset i))
-	(return t)))))
-
-
-;;; Add-Location-Conflicts  --  Internal
-;;;
-;;;    Add TN's conflicts into the conflicts for the location at Offset in SC.
-;;; We iterate over each location in TN, adding to the conflicts for that
-;;; location:
-;;; -- If TN is a :Environment TN, then iterate over all the blocks in the
-;;;    environment, setting all of the local conflict bits and the always-live
-;;;    bit.  This records a conflict with any TN that has a LTN number in the
-;;;    block, as well as with :Always-Live and :Environment TNs.
-;;; -- If TN is global, then iterate over the blocks TN is live in.  In
-;;;    addition to setting the always-live bit to represent the conflict with
-;;;    TNs live throughout the block, we also set bits in the local conflicts.
-;;;    If TN is :Always-Live in the block, we set all the bits, otherwise we or
-;;;    in the local conflict bits.
-;;; -- If the TN is local, then we just do the block it is local to, setting
-;;;    always-live and OR'ing in the local conflicts.
-;;;
-(defun add-location-conflicts (tn sc offset)
-  (declare (type tn tn) (type sc sc) (type unsigned-byte offset))
-  (let ((confs (tn-global-conflicts tn))
-	(sb (sc-sb sc)))
-    (dotimes (i (sc-element-size sc))
-      (let* ((this-offset (+ offset i))
-	     (loc-confs (svref (finite-sb-conflicts sb) this-offset))
-	     (loc-live (svref (finite-sb-always-live sb) this-offset)))
-	(cond
-	 ((eq (tn-kind tn) :environment)
-	  (do ((env-block (ir2-environment-blocks (tn-environment tn))
-			  (ir2-block-environment-next env-block)))
-	      ((null env-block))
-	    (let ((num (ir2-block-number env-block)))
-	      (setf (sbit loc-live num) 1)
-	      (set-bit-vector (svref loc-confs num)))))
-	 (confs
-	  (do ((conf confs (global-conflicts-tn-next conf)))
-	      ((null conf))
-	    (let* ((block (global-conflicts-block conf))
-		   (num (ir2-block-number block))
-		   (local-confs (svref loc-confs num)))
-	      (setf (sbit loc-live num) 1)
-	      (if (eq (global-conflicts-kind conf) :live)
-		  (set-bit-vector local-confs)
-		  (bit-ior local-confs (global-conflicts-conflicts conf) t)))))
-	 (t
-	  (let ((num (ir2-block-number (tn-local tn))))
-	    (setf (sbit loc-live num) 1)
-	    (bit-ior (svref loc-confs num) (tn-local-conflicts tn) t))))))))
-
-
-;;; Init-SB-Vectors  --  Internal
-;;;
-;;;    Ensure that the conflicts vectors for each :Finite SB are large enough
-;;; for the number of blocks allocated.  Also clear any old conflicts and reset
-;;; the current size to the initial size.
-;;;
-(defun init-sb-vectors (component)
-  (let ((nblocks (1+ (ir2-block-number
-		      (block-info
-		       (block-next
-			(component-head component)))))))
-    (dolist (sb *sb-list*)
-      (unless (eq (sb-kind sb) :non-packed)
-	(let* ((conflicts (finite-sb-conflicts sb))
-	       (always-live (finite-sb-always-live sb))
-	       (current-size (length (svref conflicts 0))))
-	  (when (> nblocks current-size)
-	    (let ((new-size (max nblocks (* current-size 2))))
-	      (dotimes (i (length conflicts))
-		(let ((new-vec (make-array new-size)))
-		  (dotimes (j new-size)
-		    (setf (svref new-vec j)
-			  (make-array local-tn-limit :element-type 'bit)))
-		  (setf (svref conflicts i) new-vec))
-		(setf (svref always-live i)  
-		      (make-array new-size :element-type 'bit)))))
-
-	  (dotimes (i (length conflicts))
-	    (let ((conf (svref conflicts i)))
-	      (dotimes (j (length conf))
-		(clear-bit-vector (svref conf j))))
-	    (clear-bit-vector (svref always-live i))))
-
-	(setf (finite-sb-current-size sb) (sb-size sb))
-	(setf (finite-sb-last-offset sb) 0)))))
-
-
-;;; Grow-SC  --  Internal
-;;;
-;;;    Expand the :Unbounded SB backing SC by either the initial size or the SC
-;;; element size, whichever is larger.  If Needed-Size is larger, then use that
-;;; size.
-;;;
-(defun grow-sc (sc &optional (needed-size 0))
-  (declare (type sc sc))
-  (let* ((sb (sc-sb sc))
-	 (size (finite-sb-current-size sb))
-	 (inc (max (sb-size sb) (sc-element-size sc) (- needed-size size)))
-	 (new-size (+ size inc))
-	 (conflicts (finite-sb-conflicts sb))
-	 (block-size (length (svref conflicts 0))))
-    (assert (eq (sb-kind sb) :unbounded))
-
-    (when (> new-size (length conflicts))
-      (let ((new-conf (make-array new-size)))
-	(replace new-conf conflicts)
-	(do ((i size (1+ i)))
-	    ((= i new-size))
-	  (let ((loc-confs (make-array block-size)))
-	    (dotimes (j block-size)
-	      (setf (svref loc-confs j)
-		    (make-array local-tn-limit
-				:initial-element 0
-				:element-type 'bit)))
-	    (setf (svref new-conf i) loc-confs)))
-	(setf (finite-sb-conflicts sb) new-conf))
-      
-      (let ((new-live (make-array new-size)))
-	(replace new-live (finite-sb-always-live sb))
-	(do ((i size (1+ i)))
-	    ((= i new-size))
-	  (setf (svref new-live i)
-		(make-array block-size
-			    :initial-element 0
-			    :element-type 'bit)))
-	(setf (finite-sb-always-live sb) new-live))
-
-      (let ((new-tns (make-array new-size :initial-element nil)))
-	(replace new-tns (finite-sb-live-tns sb))
-	(fill (finite-sb-live-tns sb) nil) 
-	(setf (finite-sb-live-tns sb) new-tns)))
-
-    (setf (finite-sb-current-size sb) new-size))
-  (undefined-value))
-
-
-;;; This variable is true whenever we are in pack (and thus the per-SB
-;;; conflicts information is in use.)
-;;;
-(defvar *in-pack* nil)
-
-
-;;; Pack-Before-GC-Hook  --  Internal
-;;;
-;;;    In order to prevent the conflict data structures from growing
-;;; arbitrarily large, we clear them whenever a GC happens and we aren't
-;;; currently in pack.  We revert to the initial number of locations and 0
-;;; blocks.
-;;;
-(defun pack-before-gc-hook ()
-  (unless *in-pack*
-    (dolist (sb *sb-list*)
-      (unless (eq (sb-kind sb) :non-packed)
-	(let ((size (sb-size sb)))
-	  (fill nil (finite-sb-always-live sb))
-	  (setf (finite-sb-always-live sb)
-		(make-array size :initial-element #*))
-	  
-	  (fill nil (finite-sb-conflicts sb))
-	  (setf (finite-sb-conflicts sb)
-		(make-array size :initial-element '#()))
-	  
-	  (fill nil (finite-sb-live-tns sb))
-	  (setf (finite-sb-live-tns sb)
-		(make-array size :initial-element nil))))))
-  (undefined-value))
-
-(pushnew 'pack-before-gc-hook ext:*before-gc-hooks*)
-
-
-;;;; Cost determination:
-
-;;; Add-Cost-Vector  --  Internal
-;;;
-;;;    Add the cost vector Costs into the costs for TN.  The TN cost vector may
-;;; have null entries, which we leave null to represent forbidden SCs.  The
-;;; Costs vector must not have any null entries for SCs allowed by the TN's
-;;; primitive type.
-;;;
-(defun add-cost-vector (tn costs)
-  (declare (type tn tn) (type sc-vector costs))
-  (let ((old-costs (tn-costs tn)))
-    (dolist (scn (primitive-type-scs (tn-primitive-type tn)))
-      (let ((old-cost (svref old-costs scn)))
-	(when old-cost
-	  (setf (svref old-costs scn)
-		(the cost (+ (the cost old-cost)
-			     (the cost (svref costs scn))))))))))
-
-
-;;; Add-Operand-Costs  --  Internal
-;;;
-;;;    Given a list of costs vectors, a more-operand cost vector (or NIL) and a
-;;; Tn-Ref list threaded by Across, add the costs into the TN-Costs for the
-;;; referenced TNs.
-;;;
-(defun add-operand-costs (costs more-cost refs)
-  (declare (list costs) (type (or tn-ref null) refs)
-	   (type (or sc-vector null) more-cost))
-  (do ((ref refs (tn-ref-across ref))
-       (cost costs (rest cost)))
-      ((null cost)
-       (do ((ref ref (tn-ref-across ref)))
-	   ((null ref))
-	 (add-cost-vector (tn-ref-tn ref) more-cost)))
-    (add-cost-vector (tn-ref-tn ref) (first cost))))
-
-       
-;;; Compute-Costs-And-Target  --  Internal
-;;;
-;;;    Loop over the VOPs in Block, adding the operand-specific costs into the
-;;; TN-Costs and calling any target functions.
-;;;
-(defun compute-costs-and-target (block)
-  (declare (type ir2-block block))
-  (do ((vop (ir2-block-start-vop block) (vop-next vop)))
-      ((null vop))
-    (let ((info (vop-info vop)))
-      (when (eq (vop-info-save-p info) t)
-	(do-live-tns (tn (vop-save-set vop) block)
-	  (add-cost-vector tn *save-costs*)
-	  (add-cost-vector tn *restore-costs*)))
-
-      (add-operand-costs (vop-info-arg-costs info)
-			 (vop-info-more-arg-costs info)
-			 (vop-args vop))
-      (add-operand-costs (vop-info-result-costs info)
-			 (vop-info-more-result-costs info)
-			 (vop-results vop))
-      
-      (let ((target-fun (vop-info-target-function info)))
-	(when target-fun
-	  (funcall target-fun vop))))))
-
-
-;;;; Register saving:
-
-;;; Orignal-TN  --  Internal
-;;;
-;;;    If a save TN, return the saved TN, otherwise return TN.  Useful for
-;;; getting the conflicts of a TN that might be a save TN.
-;;;
-(defun original-tn (tn)
-  (declare (type tn tn))
-  (if (member (tn-kind tn) '(:save :save-once))
-      (tn-save-tn tn)
-      tn))
-
-#|
-    (setf (tn-local res) (tn-local tn))
-    (bit-vector-replace (tn-local-conflicts res) (tn-local-conflicts tn))
-    (setf (tn-local-number res) (tn-local-number tn))
-    (setf (tn-global-conflicts res) (tn-global-conflicts tn))
-|#
-
-;;; Pack-Save-TN  --  Internal
-;;;
-;;;    Make a save TN for TN, pack it, and return it.  We copy various conflict
-;;; information from the TN so that pack does the right thing.
-;;;    
-(defun pack-save-tn (tn)
-  (declare (type tn tn))
-  (let ((res (make-tn 0 :save (tn-primitive-type tn) nil))
-	(sc (svref *save-scs* (sc-number (tn-sc tn)))))
-    (setf (tn-save-tn tn) res)
-    (setf (tn-save-tn res) tn)
-    (setf (svref (tn-costs res) (sc-number sc)) 0)
-    (pack-tn res)
-    res))
-
-
-;;; Save-Complex-Writer-TN  --  Internal
-;;;
-;;;    For TNs that have other than one writer, we save the TN before each
-;;; call.
-;;;
-(defun save-complex-writer-tn (tn vop)
-  (let ((save (or (tn-save-tn tn)
-		  (pack-save-tn tn)))
-	(node (vop-node vop))
-	(block (vop-block vop))
-	(next (vop-next vop)))
-    (emit-move-template node block
-			(template-or-lose 'save-reg)
-			tn save
-			vop)
-    (emit-move-template node block
-			(template-or-lose 'restore-reg)
-			save tn
-			next)))
-
-
-;;; Save-Single-Writer-TN  --  Internal
-;;;
-;;;    For TNs that have a single writer, we save the TN at the writer, and
-;;; only restore after the call.
-;;;
-(defun save-single-writer-tn (tn vop)
-  (let* ((old-save (tn-save-tn tn))
-	 (save (or old-save (pack-save-tn tn))))
-
-    (unless old-save
-      (let ((writer (tn-ref-vop (tn-writes tn))))
-	(emit-move-template (vop-node writer) (vop-block writer)
-			    (template-or-lose 'save-reg)
-			    tn save
-			    (vop-next writer)))
-      (setf (tn-kind save) :save-once))
-
-    (emit-move-template (vop-node vop) (vop-block vop)
-			(template-or-lose 'restore-reg)
-			save tn
-			(vop-next vop)))
-
-  (undefined-value))
-
-
-;;; Emit-Saves  --  Internal
-;;;
-;;;    Scan over the VOPs in Block, emiting saving code for TNs noted in the
-;;; codegen info that are packed into saved SCs.
-;;;
-(defun emit-saves (block)
-  (declare (type ir2-block block))
-  (do ((vop (ir2-block-start-vop block) (vop-next vop)))
-      ((null vop))
-    (when (eq (vop-info-save-p (vop-info vop)) t)
-      (do-live-tns (tn (vop-save-set vop) block)
-	(when (svref *save-scs* (sc-number (tn-sc tn)))
-	  (let ((writes (tn-writes tn))
-		(save (tn-save-tn tn)))
-	    (if (or (and save (eq (tn-kind save) :save-once))
-		    (and writes (null (tn-ref-next writes))))
-		(save-single-writer-tn tn vop)
-		(save-complex-writer-tn tn vop)))))))
-
-  (undefined-value))
-
-
-;;;; Targeting:
-
-;;; Target-If-Desirable  --  Internal
-;;;
-;;;    Link the TN-Refs Read and Write together using the TN-Ref-Target when
-;;; this seems like a good idea.  Our current criterion is that the referenced
-;;; TNs not conflict.  This is called by VOP target functions.
-;;;
-(defun target-if-desirable (read write)
-  (declare (type tn-ref read write))
-  (let ((rtn (tn-ref-tn read))
-	(wtn (tn-ref-tn write)))
-    (when (or (eq (tn-kind rtn) :constant)
-	      (not (tns-conflict rtn wtn)))
-      (setf (tn-ref-target read) write)
-      (setf (tn-ref-target write) read))))
-
-
-;;; Check-OK-Target  --  Internal
-;;;
-;;;    If TN can be packed into SC so as to honor a preference to Target, then
-;;; return the offset to pack at, otherwise return NIL.  Target must be already
-;;; packed.  We can honor a preference if:
-;;; -- Target's location is in SC's locations.
-;;; -- The element sizes of the two SCs are the same.
-;;; -- TN doesn't conflict with target's location.
-;;; 
-(defun check-ok-target (target tn sc)
-  (declare (type tn target tn)
-	   (type sc sc))
-  (let* ((loc (tn-offset target))
-	 (target-sc (tn-sc target))
-	 (target-sb (sc-sb target-sc)))
-    (if (and (eq target-sb (sc-sb sc))
-	     (or (eq (sb-kind target-sb) :unbounded)
-		 (member loc (sc-locations sc)))
-	     (= (sc-element-size target-sc) (sc-element-size sc))
-	     (not (conflicts-in-sc tn sc loc)))
-	loc
-	nil)))
-
-
-;;; Find-OK-Target-Offset  --  Internal
-;;;
-;;;    Scan along the target path from TN, looking at readers or writers.  When
-;;; we find a packed TN, return Check-OK-Target of that TN.  If there is no
-;;; target, or if the TN has multiple readers (writers), then we return NIL.
-;;; We also always return NIL after 10 iterations to get around potential
-;;; circularity problems.
-;;;
-(macrolet ((frob (slot)
-	     `(let ((count 10)
-		    (current tn))
-		(loop
-		  (let ((refs (,slot current)))
-		    (unless (and (plusp count) refs (not (tn-ref-next refs)))
-		      (return nil))
-		    (let ((target (tn-ref-target refs)))
-		      (unless target (return nil))
-		      (setq current (tn-ref-tn target))
-		      (when (tn-offset current)
-			(return (check-ok-target current tn sc)))
-		      (decf count)))))))
-  (defun find-ok-target-offset (tn sc)
-    (declare (type tn tn) (type sc sc))
-    (or (frob tn-reads)
-	(frob tn-writes))))
-
-
-
-;;;; Location selection:
-
-;;; Select-Location  --  Internal
-;;;
-;;;    Select some location for TN in SC, returning the offset if we succeed,
-;;; and NIL if we fail.  We start scanning at the Last-Offset in an attempt
-;;; to distribute the TNs across all storage.
-;;;
-;;; We call Offset-Conflicts-In-SB directly, rather than using Conflicts-In-SC.
-;;; This allows us to more efficient in packing multi-location TNs: we don't
-;;; have to multiply the number of tests by the TN size.  This falls out
-;;; natually, since we have to be aware of TN size anyway so that we don't call
-;;; Conflicts-In-SC on a bogus offset.
-;;;
-;;; We give up on finding a location after our current pointer has wrapped
-;;; twice.  This will result in testing some locations twice in the case that
-;;; we fail, but is simpler than trying to figure out the soonest failure
-;;; point.
-;;;
-;;; ### Note that we actually try to pack as many consecutive TNs as possible
-;;; in the same location, since we start scanning at the same offset that the
-;;; last TN was successfully packed in.  This is a weakening of the scattering
-;;; hueristic that was put in to prevent restricted VOP temps from hogging all
-;;; of the registers.  This way, all of these temps probably end up in one
-;;; register.
-;;;
-(defun select-location (tn sc)
-  (declare (type tn tn) (type sc sc))
-  (let* ((sb (sc-sb sc))
-	 (element-size (sc-element-size sc))
-	 (size (finite-sb-current-size sb))
-	 (start-offset (finite-sb-last-offset sb)))
-    (let ((current-start start-offset)
-	  (wrap-p nil))
-      (loop
-	(when (> (+ current-start element-size) size)
-	  (cond (wrap-p (return nil))
-		(t
-		 (setq current-start 0)
-		 (setq wrap-p t))))
-
-	(if (or (eq (sb-kind sb) :unbounded)
-		(member current-start (sc-locations sc)))
-	    (dotimes (i element-size
-			(progn
-			  (when (and (eq (sb-name sb) 'stack)
-				     (= current-start 0))
-			    (error "Baz!  Just selected OLD-CONT: ~S ~S."
-				   tn sc))
-			  (return-from select-location current-start)))
-	      (let ((offset (+ current-start i)))
-		(when (offset-conflicts-in-sb tn sb offset)
-		  (setq current-start (1+ offset))
-		  (return))))
-	    (incf current-start))))))
-
-
-;;; Find-Best-SC  --  Internal
-;;;
-;;;    Return the SC with lowest cost for TN, based on the TN-Costs.
-;;;
-(defun find-best-sc (tn)
-  (declare (type tn tn))
-  (let ((costs (tn-costs tn))
-	(best-cost most-positive-cost)
-	(best-scn nil))
-    (dolist (scn (primitive-type-scs (tn-primitive-type tn)))
-      (let ((cost (svref costs scn)))
-	(when (and cost (< (the cost cost) best-cost))
-	  (setq best-cost cost  best-scn scn))))
-    (assert best-scn () "No legal SCS?")
-    (svref *sc-numbers* best-scn)))
-
-
-
-
-;;;; Load TN packing:
-
-
-;;; These variables indicate the last location at which we computed the
-;;; Live-TNs.  They hold the Block and VOP values that were passed to
-;;; Compute-Live-TNs.
-;;;
-(defvar *live-block*)
-(defvar *live-vop*)
-
-
-;;; Init-Live-TNs  --  Internal
-;;;
-;;;    Set the Live-TNs vectors in all :Finite SBs to represent the TNs live at
-;;; the end of Block.
-;;;
-(defun init-live-tns (block)
-  (dolist (sb *sb-list*)
-    (when (eq (sb-kind sb) :finite)
-      (fill (finite-sb-live-tns sb) nil)))
-
-  (let ((live (ir2-block-live-in block)))  
-    (do ((conf (ir2-block-global-tns block) (global-conflicts-next conf)))
-	((null conf))
-      (when (or (eq (global-conflicts-kind conf) :live)
-		(/= (sbit live (global-conflicts-number conf)) 0))
-	(let* ((tn (global-conflicts-tn conf))
-	       (sb (sc-sb (tn-sc tn))))
-	  (when (eq (sb-kind sb) :finite)
-	    (setf (svref (finite-sb-live-tns sb) (tn-offset tn)) tn))))))
-
-  (setq *live-block* block)
-  (setq *live-vop* (ir2-block-last-vop block))
-
-  (undefined-value))
-
-
-;;; Compute-Live-TNs  --  Internal
-;;;
-;;;    Set the Live-TNs in :Finite SBs to represent the TNs live immediately
-;;; after the evaluation of VOP in Block.  If VOP is null, then compute the
-;;; live TNs at the beginning of the block.  Sequential calls on the same block
-;;; must be in reverse VOP order.
-;;;
-(defun compute-live-tns (block vop)
-  (unless (eq block *live-block*)
-    (init-live-tns block))
-  
-  (do ((current *live-vop* (vop-prev current)))
-      ((eq current vop))
-    (do ((ref (vop-refs current) (tn-ref-next-ref ref)))
-	((null ref))
-      (let* ((tn (tn-ref-tn ref))
-	     (sb (sc-sb (tn-sc tn))))
-	(when (eq (sb-kind sb) :finite)
-	  (let ((tns (finite-sb-live-tns sb))
-		(offset (tn-offset tn)))
-	    (if (tn-ref-write-p ref)
-		(setf (svref tns offset) nil)
-		(let ((old (svref tns offset)))
-		  (assert (or (null old) (eq old tn)) (old tn))
-		  (setf (svref tns offset) tn))))))))
-
-  (setq *live-vop* vop)
-  (undefined-value))
-
-
-;;; Find-Operand-Costs  --  Internal
-;;;
-;;;    Return the Costs vector representing the operand-specific costs for the
-;;; operand OP.
-;;;
-(defun find-operand-costs (op)
-  (declare (type tn-ref op))
-  (let* ((write-p (tn-ref-write-p op))
-	 (vop (tn-ref-vop op))
-	 (info (vop-info vop)))
-    (do ((ops (if write-p (vop-results vop) (vop-args vop))
-	      (tn-ref-across ops))
-	 (costs (if write-p
-		    (vop-info-result-costs info)
-		    (vop-info-arg-costs info))
-		(cdr costs)))
-	((eq ops op)
-	 (car costs)))))
-
-
-;;; Find-Load-SC  --  Internal
-;;;
-;;;    Return the lowest cost SC for operand that is allowed by SCs.  If there
-;;; is no legal SC, then return NIL.
-;;;
-;;; [### The minimization is gratuitous, since legal SCs always have a cost of
-;;; 0.  Maybe this shouldn't be the case?]
-;;;
-(defun find-load-sc (scs op)
-  (declare (type sc-bit-vector scs) (type tn-ref op))
-  (let ((costs (find-operand-costs op))
-	(tn (tn-ref-tn op))
-	(best-cost most-positive-cost)
-	(best-sc nil))
-    (dolist (scn (primitive-type-scs (tn-primitive-type tn)))
-      (let ((cost (svref costs scn))
-	    (sc (svref *sc-numbers* scn)))
-	(when (and cost (< (the cost cost) best-cost)
-		   (eq (sb-kind (sc-sb sc)) :finite)
-		   (/= (sbit scs scn) 0))
-	  (setq best-cost cost  best-sc sc))))
-    best-sc))
-
-
-;;; Load-TN-Conflicts-In-SB  --  Internal
-;;;
-;;;    Kind of like Offset-Conflicts-In-SB, except that it uses the Live-TNs
-;;; (must already be computed) and the VOP refs to determine whether a Load-TN
-;;; for OP could be packed in the specified location.  There is a conflict if
-;;; either:
-;;;  1] Live-TNs is non-null for that location.  For result, this means
-;;;     that the location has a live non-load TN in it after the VOP.  For an
-;;;     argument, this means that the location as a live non-load TN before the
-;;;     VOP.
-;;;  2] The reference is a result, and the same location is either:
-;;;     -- Used in a write (other than by OP) any time after the first result
-;;;        write (inclusive).
-;;;     -- Used in a read after OP (exclusive).
-;;;  3] The reference is an argument, and the same location is either:
-;;;     -- Used in a read (other than by OP) any time before the last argument
-;;;        (inclusive).
-;;;     -- Used in a write before the reference (exclusive).
-;;;
-;;;    In 2 (and 3) above, the first bullet corresponds to a conflict with a
-;;; result (argument).  Only load-TNs should hit this test, since original
-;;; operands will be in the live-TNs.
-;;;
-;;;    In 2 and 3 above, the second bullet corresponds to a conflict with a
-;;; temporary.  Note that this time interval overlaps with the previous case:
-;;; during the overlap, any reference causes a conflict.
-;;;
-(defun load-tn-conflicts-in-sb (op sb offset)
-  (assert (eq (sb-kind sb) :finite))
-  (or (svref (finite-sb-live-tns sb) offset)
-      (let ((vop (tn-ref-vop op)))
-	(macrolet ((frob (first end on-match)
-		     `(let ((end ,end))
-			(do ((ref ,first (tn-ref-next-ref ref))
-			     (before-op nil))
-			    ((eq ref end)
-			     nil)
-			  (let ((tn (tn-ref-tn ref)))
-			    (cond ((eq ref op)
-				   (setq before-op t))
-				  ((and (eq (sc-sb (tn-sc tn)) sb)
-					(eql (tn-offset tn) offset))
-				   ,on-match)))))))
-	  (if (tn-ref-write-p op)
-	      (frob (vop-refs vop)
-		    (tn-ref-next-ref (vop-results vop))
-		    (if (tn-ref-write-p ref)
-			(return t)
-			(unless before-op
-			  (return t))))
-	      (frob (do ((ref (vop-args vop) (tn-ref-across ref))
-			 (prev nil ref))
-			((null ref) prev))
-		    nil
-		    (if (tn-ref-write-p ref)
-			(when before-op
-			  (return t))
-			(return t))))))))
-
-
-;;; Find-Load-TN-Target  --  Internal
-;;;
-;;;    If a load-TN for Op is targeted to a legal location in SC, then return
-;;; the offset, otherwise return NIL.  We see if the target of the operand is
-;;; packed, and try that location.  There isn't any need to chain down the
-;;; target path, since everything is packed now.
-;;;
-(defun find-load-tn-target (op sc)
-  (let ((target (tn-ref-target op)))
-    (when target
-      (let* ((tn (tn-ref-tn target))
-	     (loc (tn-offset tn))
-	     (sb (sc-sb (tn-sc tn))))
-	(if (and (eq (sc-sb sc) sb)
-		 (member loc (sc-locations sc))
-		 (not (load-tn-conflicts-in-sb op sb loc)))
-	    loc
-	    nil)))))
-
-
-;;; Select-Load-Tn-Location  --  Internal
-;;;
-;;;    Select a legal location for a load TN for Op in SC.  We just iterate
-;;; over the SCs locations.  If we can't find a legal location, return NIL.
-;;;
-(defun select-load-tn-location (op sc)
-  (declare (type tn-ref op) (type sc sc))
-  (assert (= (sc-element-size sc) 1))
-  (let ((sb (sc-sb sc)))
-    (dolist (loc (sc-locations sc) nil)
-      (unless (load-tn-conflicts-in-sb op sb loc)
-	(return loc)))))
-
-
-;;; Failed-To-Pack-Load-TN-Error  --  Internal
-;;;
-;;;    If load TN packing fails, try to give a helpful error message.  We find
-;;; which operand is losing, and flame if there is no way the restriction could
-;;; ever be satisfied.
-;;;
-(defun failed-to-pack-load-tn-error (scs op)
-  (declare (type sc-bit-vector scs) (type tn-ref op))
-  (let* ((vop (tn-ref-vop op))
-	 (write-p (tn-ref-write-p op))
-	 (tn (tn-ref-tn op))
-	 (pos (1+ (or (position-in #'tn-ref-across op
-				   (if write-p
-				       (vop-results vop)
-				       (vop-args vop)))
-		      (error "Couldn't find ~S in its VOP!" op)))))
-
-    (if (dolist (scn (primitive-type-scs (tn-primitive-type tn)) nil)
-	  (when (/= (sbit scs scn) 0)
-	    (return t)))
-	(error "Failed to satisfy SC restrictions for ~:R ~
-	        ~:[argument to~;result of~]~%~S." pos write-p vop)
-	(error "No intersection between primitive-type SCs and restriction ~
-	        for ~:R ~:[argument to~;result of~]~%~S." pos write-p
-		(template-name (vop-info vop)))))
-  (undefined-value))
-
-
-(defevent spill-tn "Spilled a TN to satisfy operand SC restriction.")
-
-;;; Spill-And-Pack-Load-TN  --  Internal
-;;;
-;;;     Handle the case of Pack-Load-TN where there isn't any location free
-;;; that we can pack into.  What we do is spill some live TN to memory, and
-;;; then pack the load TN in the freed location.
-;;;
-;;;     We iterate over the feasible SCs in the same way as Pack-Load-TN, but
-;;; when we find any location in a feasible SC that isn't in use within the
-;;; VOP, we spill the TN in that location.  There must be some TN live in every
-;;; feasible location, since normal load TN packing failed.
-;;;
-;;;     Spilling is done using the same mechanism as register saving.
-;;;
-(defun spill-and-pack-load-tn (scs op)
-  (declare (type sc-bit-vector scs) (type tn-ref op))
-  (let ((tn (tn-ref-tn op))
-	(vop (tn-ref-vop op))
-	(ok-scs scs))
-    (event spill-tn (vop-node vop))
-    (loop
-      (let* ((sc (or (find-load-sc ok-scs op)
-		     (failed-to-pack-load-tn-error scs op)))
-	     (sb (sc-sb sc)))
-
-	(dolist (loc (sc-locations sc))
-	  (when (do ((ref (vop-refs vop) (tn-ref-next-ref ref)))
-		    ((null ref) t)
-		  (let ((tn (tn-ref-tn ref)))
-		    (when (and (eq (sc-sb (tn-sc tn)) sb)
-			       (eql (tn-offset tn) loc))
-		      (return nil))))
-
-	    (let ((victim (svref (finite-sb-live-tns sb) loc)))
-	      (assert victim)
-	      (save-complex-writer-tn victim vop))
-
-	    (let ((res (make-tn 0 :load (tn-primitive-type tn) sc)))
-	      (setf (tn-offset res) loc)
-	      (return-from spill-and-pack-load-tn res))))
-
-	(setq ok-scs (bit-vector-copy ok-scs))
-	(setf (sbit ok-scs (sc-number sc)) 0)))))
-
-
-;;; Pack-Load-TN  --  Internal
-;;;
-;;;    Loop over the possible load SCs in order of desirability, trying to find
-;;; a location to pack a Load-TN for Op into.  If we run out of SCs, then we
-;;; let Spill-And-Pack-Load-TN do its thing.  We return the packed load TN.
-;;;
-(defun pack-load-tn (scs op)
-  (declare (type sc-bit-vector scs) (type tn-ref op))
-  (let ((tn (tn-ref-tn op))
-	(ok-scs scs))
-    (loop
-      (let ((sc (find-load-sc ok-scs op)))
-	(cond ((not sc)
-	       (return (spill-and-pack-load-tn scs op)))
-	      (t
-	       (let ((loc (or (find-load-tn-target op sc)
-			      (select-load-tn-location op sc))))
-		 (cond
-		  (loc
-		   (let ((res (make-tn 0 :load (tn-primitive-type tn) sc)))
-		     (setf (tn-offset res) loc)
-		     (return res)))
-		  (t
-		   (setq ok-scs (bit-vector-copy ok-scs))
-		   (setf (sbit ok-scs (sc-number sc)) 0))))))))))
-
-
-;;; Load-Operand  --  Internal
-;;;
-;;;    Emit code to load the operand Op into the specified Load-TN.
-;;;
-(defun load-operand (op load-tn)
-  (declare (type tn-ref op) (type tn load-tn))
-  (let* ((tn (tn-ref-tn op))
-	 (vop (tn-ref-vop op))
-	 (node (vop-node vop))
-	 (block (vop-block vop)))
-    (change-tn-ref-tn op load-tn)
-    (if (tn-ref-write-p op)
-	(emit-move-template node block
-			    (template-or-lose 'store-operand)
-			    load-tn tn (vop-next vop))
-	(emit-move-template node block
-			    (template-or-lose 'load-operand)
-			    tn load-tn vop)))
-  (undefined-value))
-
-
-;;; Check-Operand-Restrictions  --  Internal
-;;;
-;;;    Scan a list of SC restriction bit-vectors and a list of TN-Refs threaded
-;;; by TN-Ref-Across.  When we find a reference whoes TN doesn't satisfy the
-;;; restriction, we pack a Load-TN and load the operand into it.
-;;;
-;;;    We compute the live TNs here so that we do it only once per VOP, and
-;;; thus don't get confused when code is inserted for loading or saving of
-;;; multiple operands.  That is, we don't want to scan the MOVE VOPs result
-;;; saving until we are done saving all results, and don't want to scan the
-;;; argument loading MOVEs until we are done loading all arguments.  This way,
-;;; the live-TNs are guaranteed to represent any conflicts between load TNs
-;;; and TNs that were originally operands, but were substituted for by load
-;;; TNs.
-;;;
-(proclaim '(inline check-operand-restrictions))
-(defun check-operand-restrictions (restr ops)
-  (declare (list restr) (type (or tn-ref null) ops))
-  (let ((computed nil))
-    (do ((restr restr (cdr restr))
-	 (op ops (tn-ref-across op)))
-	((null restr))
-      (when (zerop (sbit (car restr) (sc-number (tn-sc (tn-ref-tn op)))))
-	(unless computed
-	  (let ((vop (tn-ref-vop op)))
-	    (compute-live-tns (vop-block vop)
-			      (if (tn-ref-write-p op)
-				  vop
-				  (vop-prev vop))))
-	  (setq computed t))
-	(load-operand op (pack-load-tn (car restr) op)))))
-  (undefined-value))
-	
-
-;;; Pack-Load-TNs  --  Internal
-;;;
-;;;    Scan the VOPs in Block, looking for operands whose SC restrictions
-;;; aren't statisfied.  We do the results first, since they are evaluated
-;;; later, and our conflict analysis is a backward scan.
-;;;
-(defun pack-load-tns (block)
-  (do ((vop (ir2-block-last-vop block) (vop-prev vop)))
-      ((null vop))
-    (let ((info (vop-info vop)))
-      (check-operand-restrictions (vop-info-result-restrictions info)
-				  (vop-results vop))
-      (check-operand-restrictions (vop-info-arg-restrictions info)
-				  (vop-args vop))))
-  (undefined-value))
-
-
-;;; Pack-TN  --  Internal
-;;;
-;;;    Attempt to pack TN in all possible SCs, in order of decreasing
-;;; desirability (according to the costs.)
-;;;
-(defun pack-tn (tn)
-  (declare (type tn tn))
-  (loop
-    (let* ((fsc (find-best-sc tn))
-	   (original (original-tn tn))
-	   (loc (or (find-ok-target-offset original fsc)
-		    (select-location original fsc))))
-      (cond (loc
-	     (add-location-conflicts original fsc loc)
-	     (setf (tn-sc tn) fsc)
-	     (setf (tn-offset tn) loc)
-	     (return))
-	    ((eq (sb-kind (sc-sb fsc)) :unbounded)
-	     (grow-sc fsc))
-	    (t
-	     (setf (svref (tn-costs tn) (sc-number fsc)) nil)))))
-  (undefined-value))
-
-
-(defun pack-targeting-tns (tn)
-  )
-
-;;; Pack-Wired-TN  --  Internal
-;;;
-;;;    Pack a wired TN, checking that the offset is in bounds for the SB, and
-;;; that the TN doesn't conflict with some other TN already packed in that
-;;; location.  If the TN is wired to a location beyond the end of a :Unbounded
-;;; SB, then grow the SB enough to hold the TN.
-;;;
-(defun pack-wired-tn (tn)
-  (declare (type tn tn))
-  (let* ((sc (tn-sc tn))
-	 (sb (sc-sb sc))
-	 (offset (tn-offset tn))
-	 (end (+ offset (sc-element-size sc))))
-    (when (> end (finite-sb-current-size sb))
-      (unless (eq (sb-kind sb) :unbounded)
-	(error "~S wired to a location that is out of bounds." tn))
-      (grow-sc sc end))
-    (when (conflicts-in-sc tn sc offset)
-      (error "~S wired to a location that it conflicts with." tn))
-    (add-location-conflicts tn sc offset)))
-
-
-;;; Pack  --  Interface
-;;;
-(defun pack (component)
-  (let ((*in-pack* t))
-    (init-sb-vectors component)
-    
-    (do-ir2-blocks (block component)
-      (compute-costs-and-target block))
-    
-    (let ((2comp (component-info component)))
-      (do ((tn (ir2-component-wired-tns 2comp) (tn-next tn)))
-	  ((null tn))
-	(pack-wired-tn tn))
-      
-      (do ((tn (ir2-component-restricted-tns 2comp) (tn-next tn)))
-	  ((null tn))
-	(pack-tn tn))
-      
-      (do ((tn (ir2-component-normal-tns 2comp) (tn-next tn)))
-	  ((null tn))
-	(when (or (tn-global-conflicts tn)
-		  (eq (tn-kind tn) :environment))
-	  (pack-tn tn)
-	  (pack-targeting-tns tn))))
-    
-    (let ((*live-block* nil)
-	  (*live-vop* nil))
-      (do-ir2-blocks (block component)
-	(let ((ltns (ir2-block-local-tns block)))
-	  (dotimes (i (ir2-block-local-tn-count block))
-	    (let ((tn (svref ltns i)))
-	      (unless (or (null tn)
-			  (eq tn :more)
-			  (tn-global-conflicts tn)
-			  (tn-offset tn))
-		(pack-tn tn)
-		(pack-targeting-tns tn)))))
-	
-	(pack-load-tns block)
-	(emit-saves block)))
-    
-    (undefined-value)))
diff --git a/compiler/proclaim.lisp b/compiler/proclaim.lisp
deleted file mode 100644
index 01f44f4de531241f417202ca87bc671784b7a5bb..0000000000000000000000000000000000000000
--- a/compiler/proclaim.lisp
+++ /dev/null
@@ -1,260 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    This file contains load-time support for declaration processing.  It is
-;;; split off from the compiler so that the compiler doesn'thave to be in the
-;;; cold load.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-;;; The Cookie holds information about the compilation environment for a node.
-;;; See the Node definition for a description of how it is used.
-;;;
-(defstruct cookie
-  (speed nil :type (or (rational 0 3) null))
-  (space nil :type (or (rational 0 3) null))
-  (safety nil :type (or (rational 0 3) null))
-  (cspeed nil :type (or (rational 0 3) null))
-  (brevity nil :type (or (rational 0 3) null))
-  (debug nil :type (or (rational 0 3) null)))
-
-
-;;; The *default-cookie* represents the current global compiler policy
-;;; information.  Whenever the policy is changed, we copy the structure so that
-;;; old uses will still get the old values.
-;;;
-(proclaim '(type cookie *default-cookie*))
-(defvar *default-cookie* (make-cookie :safety 1 :speed 1 :space 1 :cspeed 1
-				      :brevity 1 :debug 1))
-
-
-;;; Check-Function-Name  --  Interface
-;;;
-;;;    Check that Name is a valid function name, returning the name if OK, and
-;;; doing an error if not.  In addition to checking for basic well-formedness,
-;;; we also check that symbol names are not NIL or the name of a special form.
-;;;
-(defun check-function-name (name)
-  (typecase name
-    (list
-     (unless (and (consp name) (consp (cdr name))
-		  (null (cddr name)) (eq (car name) 'setf)
-		  (symbolp (cadr name)))
-       (compiler-error "Illegal function name: ~S." name))
-     name)
-    (symbol
-     (when (eq (info function kind name) :special-form)
-       (compiler-error "Special form is an illegal function name: ~S." name))
-     name)
-    (t
-     (compiler-error "Illegal function name: ~S." name))))
-
-
-;;; Define-Function-Name  --  Interface
-;;;
-;;;    Check the legality of a function name that is being introduced.  If it
-;;; names a macro, then give a warning and blast the macro information.
-;;;
-(proclaim '(function define-function-name (t) void))
-(defun define-function-name (name)
-  (check-function-name name)
-  (ecase (info function kind name)
-    (:function)
-    (:special-from
-     (compiler-error "~S names a special form, so cannot be a function." name))
-    (:macro
-     (compiler-warning "~S previously defined as a macro." name)
-     (setf (info function kind name) :function)
-     (setf (info function where-from name) :assumed)
-     (clear-info function macro-function name))
-    ((nil)
-     (setf (info function kind name) :function)))
-  name)
-
-
-;;; Process-Optimize-Declaration  --  Interface
-;;;
-;;;    Return a new cookie containing the policy information represented by the
-;;; optimize declaration Spec.  Any parameters not specified are defaulted from
-;;; Cookie.
-;;;
-(proclaim '(function process-optimize-declaration (list cookie) cookie))
-(defun process-optimize-declaration (spec cookie)
-  (let ((res (copy-cookie cookie)))
-    (dolist (quality (cdr spec))
-      (let ((quality (if (atom quality) (list quality 3) quality)))
-	(if (and (consp (cdr quality)) (null (cddr quality))
-		 (rationalp (second quality)) (<= 0 (second quality) 3))
-	    (let ((value (second quality)))
-	      (case (first quality)
-		(speed (setf (cookie-speed res) value))
-		(space (setf (cookie-space res) value))
-		(safety (setf (cookie-safety res) value))
-		(compilation-speed (setf (cookie-cspeed res) value))
-		(brevity (setf (cookie-brevity res) value))
-		(debug-info (setf (cookie-debug res) value))
-		(t
-		 (compiler-warning "Unknown optimization quality ~S in ~S."
-				   (car quality) spec))))
-	    (compiler-warning
-	     "Malformed optimization quality specifier ~S in ~S."
-	     quality spec))))
-    res))
-
-  
-;;; %Proclaim  --  Interface
-;;;
-;;;    This function is the guts of proclaim, since it does the global
-;;; environment updating.
-;;;
-;;; ### At least for now, ignore type proclamations when compiled under the new
-;;; compiler.  This allows us to delay putting the type system into the cold
-;;; load.
-;;;
-(defun %proclaim (form)
-  (unless (consp form)
-    (error "Malformed PROCLAIM spec: ~S." form))
-  
-  (let ((kind (first form))
-	(args (rest form)))
-    (case kind
-      (special
-       (dolist (name args)
-	 (unless (symbolp name)
-	   (error "Variable name is not a symbol: ~S." name))
-	 (clear-info variable constant-value name)
-	 (setf (info variable kind name) :special)))
-      (type
-       #-new-compiler
-       (let ((type (specifier-type (first args))))
-	 (dolist (name (rest args))
-	 (unless (symbolp name)
-	   (error "Variable name is not a symbol: ~S." name))
-	   (setf (info variable type name) type)
-	   (setf (info variable where-from name) :declared))))
-      (ftype
-       #-new-compiler
-       (let ((type (specifier-type (first args))))
-	 (unless (function-type-p type)
-	   (error "Declared functional type is not a function type: ~S."
-		  (first args)))
-	 (dolist (name (rest args))
-	   (define-function-name name)
-	   (setf (info function type name) type)
-	   (setf (info function where-from name) :declared))))
-      (function
-       #-new-compiler
-       (%proclaim `(ftype (function . ,(rest args)) ,(first args))))
-      (optimize
-       (setq *default-cookie* (process-optimize-declaration form *default-cookie*)))
-      ((inline notinline maybe-inline)
-       (dolist (name args)
-	 (define-function-name name)
-	 (setf (info function inlinep name)
-	       (case kind
-		 (inline :inline)
-		 (notinline :notinline)
-		 (maybe-inline :maybe-inline)))))
-      (declaration
-       (dolist (decl args)
-	 (unless (symbolp decl)
-	   (error "Declaration to be RECOGNIZED is not a symbol: ~S." decl))
-	 (setf (info declaration recognized decl) t)))
-      (t
-       (if (member kind type-specifier-symbols)
-	   (%proclaim `(type . ,form))
-	   (error "Unrecognized proclamation: ~S." form)))))
-  (undefined-value))
-;;;
-(setf (symbol-function 'proclaim) #'%proclaim)
-
-
-;;; %%Compiler-Defstruct  --  Interface
-;;;
-;;;    This function updates the global compiler information to represent the
-;;; definition of the the structure described by Info.
-;;;
-(defun %%compiler-defstruct (info)
-  (declare (type defstruct-description info))
-
-  (let ((name (dd-name info)))
-    (dolist (inc (dd-includes info))
-      (pushnew name (dd-included-by (info type structure-info inc))))
-
-    (let ((old (info type structure-info name)))
-      (when old
-	(setf (dd-included-by info) (dd-included-by old))))
-
-    (setf (info type kind name) :structure)
-    (setf (info type structure-info name) info)
-    (when (info type expander name)
-      (setf (info type expander name) nil)))
-
-  (dolist (inc (dd-includes info))
-    (pushnew (dd-name info)
-	     (dd-included-by (info type structure-info inc))))
-
-  (dolist (slot (dd-slots info))
-    (let ((fun (dsd-accessor slot)))
-      (define-function-name fun)
-      (setf (info function accessor-for fun) info)
-      ;;
-      ;; ### Bootstrap hack...
-      ;; This blows away any inverse that has been loaded into the bootstrap
-      ;; environment.  Probably this should be more general (expanders, etc.),
-      ;; and also perhaps done on other functions.
-      (when (info setf inverse fun)
-	(setf (info setf inverse fun) nil))
-      
-      (unless (dsd-read-only slot)
-	(setf (info function accessor-for `(setf ,fun)) info))))
-  (undefined-value))
-
-(setf (symbol-function '%compiler-defstruct) #'%%compiler-defstruct)
-
-
-;;;; Dummy definitions of COMPILER-ERROR, etc.
-;;;
-;;;    Until the compiler is properly loaded, we make the compiler error
-;;; functions synonyms for the obvious standard error function.
-;;;
-
-(defun compiler-error (string &rest args)
-  (apply #'error string args))
-
-(defun compiler-warning (string &rest args)
-  (apply #'warn string args))
-
-(defun compiler-note (string &rest args)
-  (apply #'warn string args))
-
-(defun compiler-error-message (string &rest args)
-  (apply #'warn string args))
-
-
-;;; Alien=>Lisp-Transform  --  Internal
-;;;
-;;;    This is the transform for alien-operators and other alien-valued
-;;; things which may be evaluated normally to yield an alien-value structure.
-;;;
-(defun alien=>lisp-transform (form)
-  (multiple-value-bind (binds stuff res)
-		       (analyze-alien-expression nil form)
-    `(let* ,(reverse binds)
-       ,(ignore-unreferenced-vars binds)
-       ,@(nreverse stuff)
-       ,(if (ct-a-val-alien res)
-	    (ct-a-val-alien res)
-	    `(lisp::make-alien-value
-	      ,(ct-a-val-sap res)
-	      ,(ct-a-val-offset res)
-	      ,(ct-a-val-size res)
-	      ',(ct-a-val-type res))))))
diff --git a/compiler/profile.lisp b/compiler/profile.lisp
deleted file mode 100644
index 9fdaead12e6d0754d9316bc6feea11dbbf23047e..0000000000000000000000000000000000000000
--- a/compiler/profile.lisp
+++ /dev/null
@@ -1,41 +0,0 @@
-;;; -*- Package: C -*-
-(in-package 'c)
-
-(use-package "PROFILE")
-
-(profile ir1-top-level
-	 find-initial-dfo
-	 find-dfo
-	 local-call-analyze
-	 delete-block
-	 join-successor-if-possible
-	 ir1-optimize-block
-	 flush-dead-code
-	 generate-type-checks
-	 constraint-propagate
-	 environment-analyze
-	 gtn-analyze
-	 control-analyze
-	 ltn-analyze
-	 stack-analyze
-	 ir2-convert
-	 lifetime-pre-pass
-	 lifetime-flow-analysis
-	 reset-current-conflict
-	 lifetime-post-pass
-	 delete-unreferenced-tns
-
-;	 pack
-	 compute-costs-and-target
-	 pack-wired-tn
-	 pack-tn
-	 pack-targeting-tns
-	 pack-load-tns
-	 emit-saves
-
-	 generate-code
-	 fasl-dump-component
-;	 check-life-consistency
-;	 check-ir1-consistency
-;	 check-ir2-consistency
-	 )
diff --git a/compiler/seqtran.lisp b/compiler/seqtran.lisp
deleted file mode 100644
index 163d5499cbf14d4a01e199d2c6afb4ac4765ac01..0000000000000000000000000000000000000000
--- a/compiler/seqtran.lisp
+++ /dev/null
@@ -1,532 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    This file contains optimizers for list and sequence functions.
-;;;
-;;; Written by Rob MacLachlan.  Some code adapted from the old seqtran file,
-;;; written by Wholey and Fahlman.
-;;;
-(in-package 'c)
-
-
-(defun mapper-transform (fn arglists accumulate take-car)
-  (collect ((do-clauses)
-	    (args-to-fn)
-	    (tests))
-    (let ((n-first (gensym)))
-      (dolist (a (if accumulate
-		     arglists
-		     `(,n-first ,@(rest arglists))))
-	(let ((v (gensym)))
-	  (do-clauses `(,v ,a (cdr ,v)))
-	  (tests `(endp ,v))
-	  (args-to-fn (if take-car `(car ,v) v))))
-      
-      (let ((call `(funcall ,fn . ,(args-to-fn)))
-	    (endtest `(or ,@(tests))))
-	(ecase accumulate
-	  (:nconc
-	   (let ((temp (gensym))
-		 (map-result (gensym)))
-	     `(let ((,map-result (list nil)))
-		(do-anonymous ((,temp ,map-result) . ,(do-clauses))
-			      (,endtest (cdr ,map-result))
-		  (setq ,temp (last (nconc ,temp ,call)))))))
-	  (:list
-	   (let ((temp (gensym))
-		 (map-result (gensym)))
-	     `(let ((,map-result (list nil)))
-		(do-anonymous ((,temp ,map-result) . ,(do-clauses))
-			      (,endtest (cdr ,map-result))
-		  (rplacd ,temp (setq ,temp (list ,call)))))))
-	  ((nil)
-	   `(let ((,n-first ,(first arglists)))
-	      (do-anonymous ,(do-clauses)
-			    (,endtest ,n-first) ,call))))))))
-
-(def-source-transform mapc (function list &rest more-lists)
-  (mapper-transform function (cons list more-lists) nil t))
-
-(def-source-transform mapcar (function list &rest more-lists)
-  (mapper-transform function (cons list more-lists) :list t))
-
-(def-source-transform mapcan (function list &rest more-lists)
-  (mapper-transform function (cons list more-lists) :nconc t))
-
-(def-source-transform mapl (function list &rest more-lists)
-  (mapper-transform function (cons list more-lists) nil nil))
-
-(def-source-transform maplist (function list &rest more-lists)
-  (mapper-transform function (cons list more-lists) :list nil))
-
-(def-source-transform mapcon (function list &rest more-lists)
-  (mapper-transform function (cons list more-lists) :nconc nil))
-
-(deftransform elt ((s i) (vector *))
-  '(aref s i))
-
-(deftransform elt ((s i) (list *))
-  '(nth i s))
-
-(deftransform %setelt ((s i v) (vector * *))
-  '(%aset s i v))
-
-(deftransform %setelt ((s i v) (list * *))
-  '(setf (car (nthcdr i s)) v))
-
-(deftransform member ((e l &key (test #'eql)) * * :node node)
-  (unless (constant-continuation-p l) (give-up))
-  (let ((val (continuation-value l)))
-    (unless (policy node
-		    (or (= speed 3)
-			(and (>= speed space)
-			     (<= (length val) 5))))
-      (give-up))
-    `(or ,@(mapcar #'(lambda (x) `(funcall test e ',x))
-		   val))))
-
-
-
-#|Inline expansion is available...
-
-;;; For Adjoin, just turn into a member and let the member transform
-;;; worry about it.
-;;;
-(deftransform adjoin ((item list &key (key #'identity) test test-not))
-  `(if (member (funcall key item) list
-	       ,@(when test '(:test test))
-	       ,@(when test-not '(:test-not test-not))
-	       :key key)
-       list
-       (cons item list)))
-|#
-
-
-#|
-member map concatenate position find
-|#
-
-
-;;;; Simple string transforms:
-
-
-(deftransform subseq ((string start &optional (end nil))
-		      (simple-string t &optional t))
-  '(let* ((length (- (or end (length string))
-		     start))
-	  (result (make-string length)))
-     (%primitive byte-blt string start result 0 length)
-     result))
-
-
-(deftransform copy-seq ((seq) (simple-string))
-  '(let* ((length (length seq))
-	  (res (make-string length)))
-     (%primitive byte-blt seq 0 res 0 length)
-     res))
-
-
-(deftransform replace ((string1 string2 &key (start1 0) (start2 0)
-				end1 end2)
-		       (simple-string simple-string &rest t))
-  '(progn
-     (%primitive byte-blt string2 start2 string1 start1
-		 (+ start1
-		    (min (- (or end1 (length string1))
-			    start1)
-			 (- (or end2 (length string2))
-			    start2))))
-     string1))
-
-
-(deftransform concatenate ((rtype &rest sequences)
-			   (t &rest simple-string)
-			   simple-string)
-  (collect ((lets)
-	    (forms)
-	    (all-lengths)
-	    (args))
-    (dolist (seq sequences)
-      (declare (ignore seq))
-      (let ((n-seq (gensym))
-	    (n-length (gensym)))
-	(args n-seq)
-	(lets `(,n-length (length ,n-seq)))
-	(all-lengths n-length)
-	(forms `(setq start end  end (+ start ,n-length)))
-	(forms `(%primitive byte-blt ,n-seq 0 res start end))))
-    `(lambda (rtype ,@(args))
-       (declare (ignore rtype))
-       (let* (,@(lets)
-	      (res (make-string (+ ,@(all-lengths))))
-	      (start 0)
-	      (end 0))
-	 (declare (type index start end))
-	 ,@(forms)
-	 res))))
-
-
-;;; Names of predicates that compute the same value as CHAR= when applied to
-;;; characters.
-;;; 
-(defconstant char=-functions '(eql equal char=))
-
-
-(deftransform position ((item sequence &key from-end test (start 0) end)
-			(t simple-string &rest t))
-  (unless (or (not test)
-	      (continuation-function-is test char=-functions))
-    (give-up))
-  `(and (typep item 'string-char)
-	(,@(if (constant-value-or-lose from-end)
-	       '(lisp::%sp-reverse-find-character)
-	       '(%primitive find-character))
-	 sequence start (or end (length sequence))
-	 item)))
-
-
-(deftransform find ((item sequence &key from-end (test #'eql) (start 0) end)
-		    (t simple-string &rest t))
-  `(if (position item sequence
-		 ,@(when from-end `(:from-end from-end))
-		 :test test :start start :end end)
-       item
-       nil))
-
-
-;;;; Utilities:
-
-
-;;; CONTINUATION-FUNCTION-IS  --  Interface
-;;;
-;;;    Return true if Cont's only use is a non-notinline reference to a global
-;;; function with one of the specified Names.
-;;;
-(defun continuation-function-is (cont names)
-  (declare (type continuation cont) (list names))
-  (let ((use (continuation-use cont)))
-    (and (ref-p use)
-	 (let ((leaf (ref-leaf use)))
-	   (and (global-var-p leaf)
-		(eq (global-var-kind leaf) :global-function)
-		(not (null (member (leaf-name leaf) names :test #'equal))))))))
-
-
-;;; CONSTANT-VALUE-OR-LOSE  --  Interface
-;;;
-;;;    If Cont is a constant continuation, the return the constant value.  If
-;;; it is null, then return default, otherwise quietly GIVE-UP.
-;;; ### Probably should take an ARG and flame using the NAME.
-;;;
-(defun constant-value-or-lose (cont &optional default)
-  (declare (type (or continuation null) cont))
-  (cond ((not cont) default)
-	((constant-continuation-p cont)
-	 (continuation-value cont))
-	(t
-	 (give-up))))
-
-#|
-;;; MAKE-ARG, ARG-CONT, ARG-NAME  --  Interface
-;;;
-;;;    This is a frob whose job it is to make it easier to pass around the
-;;; arguments to IR1 transforms.  It bundles together the name of the argument
-;;; (which should be referenced in any expansion), and the continuation for
-;;; that argument (or NIL if unsupplied.)
-;;;
-(defstruct (arg (:constructor %make-arg (name cont)))
-  (name nil :type symbol)
-  (cont nil :type (or continuation null)))
-;;;
-(defmacro make-arg (name)
-  `(%make-arg ',name ,name))
-
-;;; DEFAULT-ARG  --  Interface
-;;;
-;;;    If Arg is null or its CONT is null, then return Default, otherwise
-;;; return Arg's NAME.
-;;;
-(defun default-arg (arg default)
-  (declare (type (or arg null) arg))
-  (if (and arg (arg-cont arg))
-      (arg-name arg)
-      default))
-
-
-;;; ARG-CONSTANT-VALUE  --  Interface
-;;;
-;;;    If Arg is null or has no CONT, return the default.  Otherwise, Arg's
-;;; CONT must be a constant continuation whose value we return.  If not, we
-;;; give up.
-;;;
-(defun arg-constant-value (arg default)
-  (declare (type (or arg null) arg))
-  (if (and arg (arg-cont arg))
-      (let ((cont (arg-cont arg)))
-	(unless (constant-continuation-p cont)
-	  (give-up "Argument is not constant: ~S." (arg-name arg)))
-	(continuation-value from-end))
-      default))
-
-
-;;; ARG-EQL  --  Internal
-;;;
-;;;    If Arg is a constant and is EQL to X, then return T, otherwise NIL.  If
-;;; Arg is NIL or its CONT is NIL, then compare to the default.
-;;;
-(defun arg-eql (arg default x)
-  (declare (type (or arg null) x))
-  (if (and arg (arg-cont arg))
-      (let ((cont (arg-cont arg)))
-	(and (constant-continuation-p cont)
-	     (eql (continuation-value cont) x)))
-      (eql default x)))
-
-
-(defstruct iterator
-  ;;
-  ;; The kind of iterator.
-  (kind nil (member :normal :result))
-  ;;
-  ;; A list of LET* bindings to create the initial state.
-  (binds nil :type list)
-  ;;
-  ;; A list of declarations for Binds.
-  (decls nil :type list)
-  ;;
-  ;; A form that returns the current value.  This may be set with SETF to set
-  ;; the current value.
-  (current (error "Must specify CURRENT."))
-  ;;
-  ;; In a :Normal iterator, a form that tests whether there is a current value.
-  (done nil)
-  ;;
-  ;; In a :Result iterator, a form that truncates the result at the current
-  ;; position and returns it.
-  (result nil)
-  ;;
-  ;; A form that returns the initial total number of values.  The result is
-  ;; undefined after NEXT has been evaluated.
-  (length (error "Must specify LENGTH."))
-  ;;
-  ;; A form that advances the state to the next value.  It is an error to call
-  ;; this when the iterator is Done.
-  (next (error "Must specify NEXT.")))
-
-
-;;; Type of an index var that can go negative (in the from-end case.)
-(deftype neg-index ()
-  `(integer -1 ,most-positive-fixnum))
-
-
-;;; MAKE-SEQUENCE-ITERATOR  --  Interface
-;;;
-;;;    Return an ITERATOR structure describing how to iterate over an arbitrary
-;;; sequence.  Sequence is a variable bound to the sequence, and Type is the
-;;; type of the sequence.  If true, INDEX is a variable that should be bound to
-;;; the index of the current element in the sequence.
-;;;
-;;;    If we can't tell whether the sequence is a list or a vector, or whether
-;;; the iteration is forward or backward, then GIVE-UP.
-;;;
-(defun make-sequence-iterator (sequence type &key start end from-end index)
-  (declare (symbol sequence) (type ctype type)
-	   (type (or arg null) start end from-end)
-	   (type (or symbol null) index))
-  (let ((from-end (arg-constant-value from-end nil)))
-    (cond ((csubtypep type (specifier-type 'vector))
-	   (let* ((n-stop (gensym))
-		  (n-idx (or index (gensym)))
-		  (start (default-arg 0 start))
-		  (end (default-arg `(length ,sequence) end)))
-	     (make-iterator
-	      :kind :normal
-	      :binds `((,n-idx ,(if from-end `(1- ,end) ,start))
-		       (,n-stop ,(if from-end `(1- ,start) ,end)))
-	      :decls `((type neg-index ,n-idx ,n-stop))
-	      :current `(aref ,sequence ,n-idx)
- 	      :done `(,(if from-end '<= '>=) ,n-idx ,n-stop)
-	      :next `(setq ,n-idx
-			   ,(if from-end `(1- ,n-idx) `(1+ ,n-idx)))
-	      :length (if from-end
-			  `(- ,n-idx ,n-stop)
-			  `(- ,n-stop ,n-idx)))))
-	  ((csubtypep type (specifier-type 'list))
-	   (let* ((n-stop (if (and end (not from-end)) (gensym) nil))
-		  (n-current (gensym))
-		  (start-p (not (arg-eql start 0 0)))
-		  (end-p (not (arg-eql end nil nil)))
-		  (start (default-arg start 0))
-		  (end (default-arg end nil)))
-	     (make-iterator
-	      :binds `((,n-current
-			,(if from-end
-			     (if (or start-p end-p)
-				 `(nreverse (subseq ,sequence ,start
-						    ,@(when end `(,end))))
-				 `(reverse ,sequence))
-			     (if start-p
-				 `(nthcdr ,start ,sequence)
-				 sequence)))
-		       ,@(when n-stop
-			   `((,n-stop (nthcdr (the index
-						   (- ,end ,start))
-					      ,n-current))))
-		       ,@(when index
-			   `((,index ,(if from-end `(1- ,end) start)))))
-	      :kind :normal
-	      :decls `((list ,n-current ,n-end)
-		       ,@(when index `((type neg-index ,index))))
-	      :current `(car ,n-current)
-	      :done `(eq ,n-current ,n-stop)
-	      :length `(- ,(or end `(length ,sequence)) ,start)
-	      :next `(progn
-		       (setq ,n-current (cdr ,n-current))
-		       ,@(when index
-			   `((setq ,n-idx
-				   ,(if from-end
-					`(1- ,index)
-					`(1+ ,index)))))))))
-	  (t
-	   (give-up "Can't tell whether sequence is a list or a vector.")))))
-
-
-;;; MAKE-RESULT-SEQUENCE-ITERATOR  --  Interface
-;;;
-;;;    Make an iterator used for constructing result sequences.  Name is a
-;;; variable to be bound to the result sequence.  Type is the type of result
-;;; sequence to make.  Length is an expression to be evaluated to get the
-;;; maximum length of the result (not evaluated in list case.)
-;;;
-(defun make-result-sequence-iterator (name type length)
-  (declare (symbol name) (type ctype type))
-
-;;; COERCE-FUNCTIONS  --  Interface
-;;;
-;;;    Defines each Name as a local macro that will call the value of the
-;;; Fun-Arg with the given arguments.  If the argument isn't known to be a
-;;; function, give them an efficiency note and reference a coerced version.
-;;;
-(defmacro coerce-functions (specs &body body)
-  "COERCE-FUNCTIONS ({(Name Fun-Arg Default)}*) Form*"
-  (collect ((binds)
-	    (defs))
-    (dolist (spec specs)
-      `(let ((body (progn ,@body))
-	     (n-fun (arg-name ,(second spec)))
-	     (fun-cont (arg-cont ,(second spec))))
-	 (cond ((not fun-cont)
-		`(macrolet ((,',(first spec) (&rest args)
-			     `(,',',(third spec) ,@args)))
-		   ,body))
-	       ((not (csubtypep (continuation-type fun-cont)
-				(specifier-type 'function)))
-		(when (policy *compiler-error-context* (> speed brevity))
-		  (compiler-note
-		   "~S may not be a function, so must coerce at run-time."
-		   n-fun))
-		(once-only ((n-fun `(if (functionp ,n-fun)
-					,n-fun
-					(symbol-function ,n-fun))))
-		  `(macrolet ((,',(first spec) (&rest args)
-			       `(funcall ,',n-fun ,@args)))
-		     ,body)))
-	       (t
-		`(macrolet ((,',(first spec) (&rest args)
-			      `(funcall ,',n-fun ,@args)))
-		   ,body)))))))
-
-
-;;; WITH-SEQUENCE-TEST  --  Interface
-;;;
-;;;    Wrap code around the result of the body to define Name as a local macro
-;;; that returns true when its arguments satisfy the test according to the Args
-;;; Test and Test-Not.  If both Test and Test-Not are supplied, abort the
-;;; transform.
-;;;
-(defmacro with-sequence-test ((name test test-not) &body body)
-  `(let ((not-p (arg-cont ,test-not)))
-     (when (and (arg-cont ,test) not-p)
-       (abort-transform "Both ~S and ~S supplied." (arg-name ,test)
-			(arg-name ,test-not)))
-     (coerce-functions ((,name (if not-p ,test-not ,test) eql))
-       ,@body)))
-
-|#
-
-;;;; Hairy sequence transforms:
-
-
-
-;;;; String operations:
-
-;;; STRINGxxx transform  --  Internal
-;;;
-;;;    We transform the case-sensitive string predicates into a non-keyword
-;;; version.  This is an IR1 transform so that we don't have to worry about
-;;; changing the order of evaluation.
-;;;
-(macrolet ((frob (pred pred*)
-	     `(deftransform ,pred ((string1 string2 &key (start1 0) end1
-					    (start2 0) end2))
-		'(,pred* string1 string2 start1 end1 start2 end2))))
-
-  (frob string< string<*)
-  (frob string> string>*)
-  (frob string<= string<=*)
-  (frob string>= string>=*)
-  (frob string= string=*)
-  (frob string/= string/=*))
-
-
-;;; STRING<>=-BODY  --  Internal
-;;;
-;;;    Return a form that tests the free variables STRING1 and STRING2 for the
-;;; ordering relationship specified by Lessp and Equalp.  The start and end are
-;;; also gotten from the environment.  Both strings must be simple strings.
-;;;
-(defun string<>=-body (lessp equalp)
-  `(let* ((end1 (if (not end1) (length string1) end1))
-	  (end2 (if (not end2) (length string2) end2))
-	  (index (lisp::%sp-string-compare
-		  string1 start1 end1 string2 start2 end2)))
-     (if index
-	 (cond ((= index ,(if lessp 'end1 'end2)) index)
-	       ((= index ,(if lessp 'end2 'end1)) nil)
-	       ((,(if lessp 'char< 'char>)
-		 (schar string1 index)
-		 (schar string2
-			(truly-the index
-				   (+ index (truly-the fixnum
-						       (- start2 start1))))))
-		index)
-	       (t nil))
-	 ,(if equalp 'end1 'nil))))
-
-
-(macrolet ((frob (name lessp equalp)
-	     `(deftransform ,name ((string1 string2 start1 end1 start2 end2)
-				   (simple-string simple-string t t t t))
-		(string<>=-body ,lessp ,equalp))))
-  (frob string<* t nil)
-  (frob string<=* t t)
-  (frob string>* nil nil)
-  (frob string>=* nil t))
-
-
-(macrolet ((frob (name result-fun)
-	     `(deftransform ,name
-			    ((string1 string2 start1 end1 start2 end2)
-			     (simple-string simple-string t t t t))
-		'(,result-fun
-		  (lisp::%sp-string-compare
-		   string1 start1 (or end1 (length string1))
-		   string2 start2 (or end2 (length string2)))))))
-  (frob string=* not)
-  (frob string/=* identity))
diff --git a/compiler/srctran.lisp b/compiler/srctran.lisp
deleted file mode 100644
index 019788dd0aff593e203799dcae53270f05e7bc25..0000000000000000000000000000000000000000
--- a/compiler/srctran.lisp
+++ /dev/null
@@ -1,1016 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    This file contains macro-like source transformations which convert
-;;; uses of certain functions into the canonical form desired within the
-;;; compiler.  ### and other IR1 transforms and stuff.  Some code adapted from
-;;; CLC, written by Wholey and Fahlman.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-;;; Source transform for Not, Null  --  Internal
-;;;
-;;;    Convert into an IF so that IF optimizations will eliminate redundant
-;;; negations.
-;;;
-(def-source-transform not (x) `(if ,x nil t))
-(def-source-transform null (x) `(if ,x nil t))
-
-;;; Source transform for Endp  --  Internal
-;;;
-;;;    Endp is just NULL with a List assertion.
-;;;
-(def-source-transform endp (x) `(null (the list ,x)))
-
-;;; We turn Identity into Prog1 so that it is obvious that it just returns the
-;;; first value of its argument.  Ditto for Values with one arg.
-(def-source-transform identity (x) `(prog1 ,x))
-(def-source-transform values (x) `(prog1 ,x))
-
-
-;;;; List hackery:
-
-;;;
-;;; Translate CxxR into car/cdr combos.
-(def-source-transform caar (x) `(car (car ,x)))
-(def-source-transform cadr (x) `(car (cdr ,x)))
-(def-source-transform cdar (x) `(cdr (car ,x)))
-(def-source-transform cddr (x) `(cdr (cdr ,x)))
-(def-source-transform caaar (x) `(car (car (car ,x))))
-(def-source-transform caadr (x) `(car (car (cdr ,x))))
-(def-source-transform cadar (x) `(car (cdr (car ,x))))
-(def-source-transform caddr (x) `(car (cdr (cdr ,x))))
-(def-source-transform cdaar (x) `(cdr (car (car ,x))))
-(def-source-transform cdadr (x) `(cdr (car (cdr ,x))))
-(def-source-transform cddar (x) `(cdr (cdr (car ,x))))
-(def-source-transform cdddr (x) `(cdr (cdr (cdr ,x))))
-(def-source-transform caaaar (x) `(car (car (car (car ,x)))))
-(def-source-transform caaadr (x) `(car (car (car (cdr ,x)))))
-(def-source-transform caadar (x) `(car (car (cdr (car ,x)))))
-(def-source-transform caaddr (x) `(car (car (cdr (cdr ,x)))))
-(def-source-transform cadaar (x) `(car (cdr (car (car ,x)))))
-(def-source-transform cadadr (x) `(car (cdr (car (cdr ,x)))))
-(def-source-transform caddar (x) `(car (cdr (cdr (car ,x)))))
-(def-source-transform cadddr (x) `(car (cdr (cdr (cdr ,x)))))
-(def-source-transform cdaaar (x) `(cdr (car (car (car ,x)))))
-(def-source-transform cdaadr (x) `(cdr (car (car (cdr ,x)))))
-(def-source-transform cdadar (x) `(cdr (car (cdr (car ,x)))))
-(def-source-transform cdaddr (x) `(cdr (car (cdr (cdr ,x)))))
-(def-source-transform cddaar (x) `(cdr (cdr (car (car ,x)))))
-(def-source-transform cddadr (x) `(cdr (cdr (car (cdr ,x)))))
-(def-source-transform cdddar (x) `(cdr (cdr (cdr (car ,x)))))
-(def-source-transform cddddr (x) `(cdr (cdr (cdr (cdr ,x)))))
-
-;;;
-;;; Turn First..Fourth and Rest into the obvious synonym, assuming whatever is
-;;; right for them is right for us.  Fifth..Tenth turn into Nth, which can be
-;;; expanded into a car/cdr later on if policy favors it.
-(def-source-transform first (x) `(car ,x))
-(def-source-transform rest (x) `(cdr ,x))
-(def-source-transform second (x) `(cadr ,x))
-(def-source-transform third (x) `(caddr ,x))
-(def-source-transform fourth (x) `(cadddr ,x))
-(def-source-transform fifth (x) `(nth 4 ,x))
-(def-source-transform sixth (x) `(nth 5 ,x))
-(def-source-transform seventh (x) `(nth 6 ,x))
-(def-source-transform eighth (x) `(nth 7 ,x))
-(def-source-transform ninth (x) `(nth 8 ,x))
-(def-source-transform tenth (x) `(nth 9 ,x))
-
-
-;;;
-;;; Translate RPLACx to LET and SETF.
-(def-source-transform rplaca (x y)
-  (once-only ((n-x x))
-    `(progn
-       (setf (car ,n-x) ,y)
-       ,n-x)))
-;;;
-(def-source-transform rplacd (x y)
-  (once-only ((n-x x))
-    `(progn
-       (setf (cdr ,n-x) ,y)
-       ,n-x)))
-
-
-(def-source-transform nth (n l) `(car (nthcdr ,n ,l)))
-  
-(defvar *default-nthcdr-open-code-limit* 6)
-(defvar *extreme-nthcdr-open-code-limit* 20)
-
-(deftransform nthcdr ((n l) (unsigned-byte t) * :node node)
-  (unless (constant-continuation-p n) (give-up))
-  (let ((n (continuation-value n)))
-    (when (> n
-	     (if (policy node (= speed 3) (= space 0))
-		 *extreme-nthcdr-open-code-limit*
-		 *default-nthcdr-open-code-limit*))
-      (give-up))
-
-    (labels ((frob (n)
-	       (if (zerop n)
-		   'l
-		   `(cdr ,(frob (1- n))))))
-      (frob n))))
-
-
-;;;; ARITHMETIC and NUMEROLOGY.
-
-(def-source-transform plusp (x) `(> ,x 0))
-(def-source-transform minusp (x) `(< ,x 0))
-(def-source-transform zerop (x) `(= ,x 0))
-
-(def-source-transform 1+ (x) `(+ ,x 1))
-(def-source-transform 1- (x) `(- ,x 1))
-
-(def-source-transform oddp (x) `(not (zerop (logand ,x 1))))
-(def-source-transform evenp (x) `(zerop (logand ,x 1)))
-
-;;; Note that all the integer division functions are available for inline
-;;; expansion.
-
-(def-source-transform truncate (x &optional y)
-  (if y
-      (values nil t)
-      `(truncate ,x 1)))
-
-(def-source-transform logeqv-two-arg (x y) `(lognot (logxor ,x ,y)))
-(def-source-transform lognand (x y) `(lognot (logand ,x ,y)))
-(def-source-transform lognor (x y) `(lognot (logior ,x ,y)))
-(def-source-transform logandc1 (x y) `(logand (lognot ,x) ,y))
-(def-source-transform logandc2 (x y) `(logand ,x (lognot ,y)))
-(def-source-transform logorc1 (x y) `(logior (lognot ,x) ,y))
-(def-source-transform logorc2 (x y) `(logior ,x (lognot ,y)))
-(def-source-transform logtest (x y) `(not (zerop (logand ,x ,y))))
-(def-source-transform logbitp (index integer)
-  `(not (zerop (logand (ash 1 ,index) ,integer))))
-(def-source-transform byte (size position) `(cons ,size ,position))
-(def-source-transform byte-size (spec) `(car ,spec))
-(def-source-transform byte-position (spec) `(cdr ,spec))
-(def-source-transform ldb-test (bytespec integer)
-  `(not (zerop (ldb ,bytespec ,integer))))
-
-
-;;; With the ratio and complex accessors, we pick off the "identity" case, and
-;;; use a primitive to handle the cell access case.
-;;;
-(macrolet ((frob (fun)
-	     `(def-source-transform ,fun (num)
-		(once-only ((n-num `(the rational ,num)))
-		  `(if (ratiop ,n-num)
-		       (%primitive ,',fun ,n-num)
-		       ,n-num)))))
-  (frob numerator)
-  (frob denominator))
-
-(macrolet ((frob (fun)
-	     `(def-source-transform ,fun (num)
-		(once-only ((n-num num))
-		  `(if (complexp ,n-num)
-		       (%primitive ,',fun ,n-num)
-		       ,n-num)))))
-  (frob realpart)
-  (frob imagpart))
-
-
-;;;; Numeric Derive-Type methods:
-
-;;; Derive-Integer-Type  --  Internal
-;;;
-;;;    Utility for defining derive-type methods of integer operations.  If the
-;;; types of both X and Y are integer types, then we compute a new integer type
-;;; with bounds determined Fun when applied to X and Y.  Otherwise, we use
-;;; Numeric-Contagion.
-;;;
-(defun derive-integer-type (x y fun)
-  (declare (type continuation x y) (type function fun))
-  (let ((x (continuation-type x))
-	(y (continuation-type y)))
-    (if (and (numeric-type-p x) (numeric-type-p y)
-	     (eq (numeric-type-class x) 'integer)
-	     (eq (numeric-type-class y) 'integer)
-	     (eq (numeric-type-complexp x) :real)
-	     (eq (numeric-type-complexp y) :real))
-	(multiple-value-bind (low high)
-			     (funcall fun x y)
-	  (make-numeric-type :class 'integer  :complexp :real
-			     :low low  :high high))
-	(numeric-contagion x y))))
-
-
-(defoptimizer (+ derive-type) ((x y))
-  (derive-integer-type
-   x y
-   #'(lambda (x y)
-       (flet ((frob (x y)
-		(if (and x y)
-		    (+ x y)
-		    nil)))
-	 (values (frob (numeric-type-low x) (numeric-type-low y))
-		 (frob (numeric-type-high x) (numeric-type-high y)))))))
-
-(defoptimizer (- derive-type) ((x y))
-  (derive-integer-type
-   x y
-   #'(lambda (x y)
-       (flet ((frob (x y)
-		(if (and x y)
-		    (- x y)
-		    nil)))
-	 (values (frob (numeric-type-low x) (numeric-type-high y))
-		 (frob (numeric-type-high x) (numeric-type-low y)))))))
-
-(defoptimizer (* derive-type) ((x y))
-  (derive-integer-type
-   x y
-   #'(lambda (x y)
-       (let ((x-low (numeric-type-low x))
-	     (x-high (numeric-type-high x))
-	     (y-low (numeric-type-low y))
-	     (y-high (numeric-type-high y)))
-	 (cond ((not (and x-low y-low))
-		(values nil nil))
-	       ((or (minusp x-low) (minusp y-low))
-		(if (and x-high y-high)
-		    (let ((max (* (max (abs x-low) (abs x-high))
-				  (max (abs y-low) (abs y-high)))))
-		      (values (- max) max))
-		    (values nil nil)))
-	       (t
-		(values (* x-low y-low)
-			(if (and x-high y-high)
-			    (* x-high y-high)
-			    nil))))))))
-
-(defoptimizer (ash derive-type) ((n shift))
-  (let ((type (continuation-type n)))
-    (if (and (numeric-type-p type)
-	     (constant-continuation-p shift))
-	(let ((low (numeric-type-low type))
-	      (high (numeric-type-high type))
-	      (shift (continuation-value shift)))
-	  (make-numeric-type :class 'integer  :complexp :real
-			     :low (when low (ash low shift))
-			     :high (when high (ash high shift))))
-	*universal-type*)))
-
-
-;;; Negative-Integer-P  --  Internal
-;;;
-;;;    Return true if Type is a integer type that includes negative numbers.
-;;;
-(defun negative-integer-p (type)
-  (declare (type numeric-type type))
-  (let ((low (numeric-type-low type)))
-    (or (not low) (minusp low))))
-
-(defoptimizer (logand derive-type) ((x y))
-  (derive-integer-type
-   x y
-   #'(lambda (x y)
-       (let* ((x-high (numeric-type-high x))
-	      (y-high (numeric-type-high y))
-	      (both-neg (and (negative-integer-p x)
-			     (negative-integer-p y)))
-	      (min (cond ((not x-high) y-high)
-			 ((not y-high) x-high)
-			 (t
-			  (min x-high y-high)))))
-	 (if min
-	     (let ((mag (ldb (byte (integer-length min) 0) -1)))
-	       (values (if both-neg (lognot mag) 0) mag))
-	     (values (if both-neg nil 0) nil))))))
-
-
-(defoptimizer (logior derive-type) ((x y))
-  (derive-integer-type
-   x y
-   #'(lambda (x y)
-       (let* ((x-high (numeric-type-high x))
-	      (y-high (numeric-type-high y))
-	      (one-neg (or (negative-integer-p x)
-			   (negative-integer-p y)))
-	      (max (cond ((not x-high) nil)
-			 ((not y-high) nil)
-			 (t
-			  (max x-high y-high)))))
-	 (if max
-	     (let ((mag (ldb (byte (integer-length max) 0) -1)))
-	       (values (if one-neg (lognot mag) 0) mag))
-	     (values (if one-neg nil 0) nil))))))
-
-(macrolet ((frob (fun)
-	     `#'(lambda (type type2)
-		  (declare (ignore type2))
-		  (let ((lo (numeric-type-low type))
-			(hi (numeric-type-high type)))
-		    (values (if hi (,fun hi) nil) (if lo (,fun lo) nil))))))
-
-  (defoptimizer (%negate derive-type) ((num))
-    (derive-integer-type num num (frob -)))
-
-  (defoptimizer (lognot derive-type) ((int))
-    (derive-integer-type int int (frob lognot))))
-
-
-;;;; Miscellaneous derive-type optimizers:
-
-(defoptimizer (aref derive-type) ((array &rest indices))
-  (let ((type (continuation-type array)))
-    (when (array-type-p type)
-      (array-type-element-type type))))
-
-(defoptimizer (%aset derive-type) ((array &rest stuff))
-  (let ((type (continuation-type array)))
-    (when (array-type-p type)
-      (let ((val (car (last stuff)))
-	    (eltype (array-type-element-type type)))
-	(assert-continuation-type val eltype)
-	(continuation-type val)))))
-
-;;; Unsupplied-Or-NIL  --  Internal
-;;;
-;;;    Return true if Arg is NIL, or is a constant-continuation whose value is
-;;; NIL, false otherwise.
-;;;
-(defun unsupplied-or-nil (arg)
-  (declare (type (or continuation null arg)))
-  (or (not arg)
-      (and (constant-continuation-p arg)
-	   (not (continuation-value arg)))))
-
-(defoptimizer (make-array derive-type) ((dims &key initial-element
-					      element-type initial-contents
-					      adjustable fill-pointer
-					      displaced-index-offset
-					      displaced-to))
-  (specifier-type
-   `(,(if (and (unsupplied-or-nil adjustable)
-	       (unsupplied-or-nil displaced-to)
-	       (unsupplied-or-nil fill-pointer))
-	  'simple-array
-	  'array)
-     ,(cond ((not element-type) 't)
-	    ((constant-continuation-p element-type)
-	     (continuation-value element-type))
-	    (t
-	     '*))
-     ,(cond ((constant-continuation-p dims)
-	     (let ((val (continuation-value dims)))
-	       (if (listp val) val (list val))))
-	    ((csubtypep (continuation-type dims)
-			(specifier-type 'integer))
-	     '(*))
-	    (t
-	     '*)))))
-
-(defoptimizer (code-char derive-type) ((code))
-  (specifier-type 'string-char))
-
-
-;;;; Byte operations:
-;;;
-;;;    We try to turn byte operations into simple logical operations.  First,
-;;; we convert byte specifiers into separate size and position arguments passed
-;;; to internal %FOO functions.  We then attempt to transform the %FOO
-;;; functions into boolean operations when the size and position are constant
-;;; and the operands are fixnums.
-
-
-;;; With-Byte-Specifier  --  Internal
-;;;
-;;;    Evaluate body with Size-Var and Pos-Var bound to expressions that
-;;; evaluate to the Size and Position of the byte-specifier form Spec.  We may
-;;; wrap a let around the result of the body to bind some variables.
-;;;
-;;;    If the spec is a Byte form, then bind the vars to the subforms.
-;;; otherwise, evaluate Spec and use the Byte-Size and Byte-Position.  The goal
-;;; of this transformation is to avoid consing up byte specifiers and then
-;;; immediately throwing them away.
-;;;
-(defmacro with-byte-specifier ((size-var pos-var spec) &body body)
-  (once-only ((spec `(macroexpand ,spec))
-	      (temp '(gensym)))
-    `(if (and (consp ,spec)
-	      (eq (car ,spec) 'byte)
-	      (= (length ,spec) 3))
-	 (let ((,size-var (second ,spec))
-	       (,pos-var (third ,spec)))
-	   ,@body)
-	 (let ((,size-var `(byte-size ,,temp))
-	       (,pos-var `(byte-position ,,temp)))
-	   `(let ((,,temp ,,spec))
-	      ,,@body)))))
-
-(def-source-transform ldb (spec int)
-  (with-byte-specifier (size pos spec)
-    `(%ldb ,size ,pos ,int)))
-
-(def-source-transform dpb (newbyte spec int)
-  (with-byte-specifier (size pos spec)
-    `(%dpb ,newbyte ,size ,pos ,int)))
-
-(def-source-transform mask-field (spec int)
-  (with-byte-specifier (size pos spec)
-    `(%mask-field ,size ,pos ,int)))
-
-(def-source-transform deposit-field (newbyte spec int)
-  (with-byte-specifier (size pos spec)
-    `(%deposit-field ,newbyte ,size ,pos ,int)))
-
-
-;;; Check-Fixnum-Byte  --  Internal
-;;;
-;;;    If the continuations Size and Pos are constant, and represent a field
-;;; that fits into a fixnum, then return the size and position as values,
-;;; otherwise Give-Up.
-;;;
-(defun check-fixnum-byte (size pos)
-  (unless (and (constant-continuation-p size)
-	       (constant-continuation-p pos))
-    (give-up))
-  (let ((size (continuation-value size))
-	(pos (continuation-value pos)))
-    (when (> (+ size pos) (integer-length most-positive-fixnum))
-      (give-up))
-    (values size pos)))
-
-(deftransform %ldb ((size pos int) (t t fixnum))
-  (multiple-value-bind (size pos)
-		       (check-fixnum-byte size pos)
-    `(logand (ash int ,(- pos)) ,(ldb (byte size 0) -1))))
-
-(deftransform %dpb ((new size pos int) (t t t fixnum))
-  (multiple-value-bind (size pos)
-		       (check-fixnum-byte size pos)
-    `(logior (ash (logand new ,(ldb (byte size 0) -1))
-		  pos)
-	     (logand int ,(lognot (ash (ldb (byte size 0) -1) pos))))))
-
-(deftransform %mask-field ((size pos int) (t t fixnum))
-  (multiple-value-bind (size pos)
-		       (check-fixnum-byte size pos)
-    `(logand int ,(ash (ldb (byte size 0) -1) pos))))
-
-(deftransform %deposit-field ((new size pos int) (t t t fixnum))
-  (multiple-value-bind (size pos)
-		       (check-fixnum-byte size pos)
-    (let ((mask (ash (ldb (byte size 0) -1) pos)))
-      `(logior (logand new ,mask)
-	       (logand int ,(lognot mask))))))
-
-
-;;;; Funny function stubs:
-;;;
-;;;    These functions are the result of compiler transformations.  We never
-;;; actually compile a call to these functions, but we need to have a
-;;; definition to allow constant folding.
-;;;
-
-(defun %negate (x) (%primitive negate x))
-(defun %ldb (s p i) (%primitive ldb s p i))
-(defun %dpb (n s p i) (%primitive dpb n s p i))
-(defun %mask-field (s p i) (%primitive mask-field s p i))
-(defun %deposit-field (n s p i) (%primitive deposit-field n s p i))
-
-
-;;; Miscellanous numeric transforms:
-
-;;; Handle the case of a constant boole-code.
-;;;
-(deftransform boole ((op x y))
-  (unless (constant-continuation-p op)
-    (give-up "BOOLE code is not a constant."))
-  (let ((control (continuation-value op)))
-    (case control
-      (#.boole-clr 0)
-      (#.boole-set -1)
-      (#.boole-1 'x)
-      (#.boole-2 'y)
-      (#.boole-c1 '(lognot x))
-      (#.boole-c2 '(lognot y))
-      (#.boole-and '(logand x y))
-      (#.boole-ior '(logior x y))
-      (#.boole-xor '(logxor x y))
-      (#.boole-eqv '(logeqv x y))
-      (#.boole-nand '(lognand x y))
-      (#.boole-nor '(lognor x y))
-      (#.boole-andc1 '(logandc1 x y))
-      (#.boole-andc2 '(logandc2 x y))
-      (#.boole-orc1 '(logorc1 x y))
-      (#.boole-orc2 '(logorc2 x y))
-      (t
-       (abort-transform "~S illegal control arg to BOOLE." control)))))
-
-
-;;; If arg is a constant power of two, turn * into a shift.
-;;;
-(deftransform * ((x y) (integer integer))
-  (unless (constant-continuation-p y) (give-up))
-  (let* ((y (continuation-value y))
-	 (y-abs (abs y))
-	 (len (1- (integer-length y-abs))))
-    (unless (= y-abs (ash 1 len)) (give-up))
-    (if (minusp y)
-	`(- (ash x ,len))
-	`(ash x ,len))))
-
-
-;;;; Character operations:
-
-(deftransform char-equal ((a b) (string-char string-char))
-  '(let* ((ac (char-code a))
-	  (bc (char-code b))
-	  (sum (logxor ac bc)))
-     (or (zerop sum)
-	 (when (eql sum #x20)
-	   (let ((sum (+ ac bc)))
-	     (and (> sum 161) (< sum 213)))))))
-
-(deftransform char-upcase ((x) (string-char))
-  '(let ((n-code (char-code x)))
-     (if (and (> n-code #o140)	; Octal 141 is #\a.
-	      (< n-code #o173))	; Octal 172 is #\z.
-	 (code-char (logxor #x20 n-code))
-	 x)))
-
-(deftransform char-downcase ((x) (string-char))
-  '(let ((n-code (char-code x)))
-     (if (and (> n-code 64)	; 65 is #\A.
-	      (< n-code 91))	; 90 is #\Z.
-	 (code-char (logxor #x20 n-code))
-	 x)))
-
-
-;;;; Equality predicate transforms:
-
-
-;;; SAME-LEAF-REF-P  --  Internal
-;;;
-;;;    Return true if X and Y are continuations whose only use is a reference
-;;; to the same leaf.
-;;;
-(defun same-leaf-ref-p (x y)
-  (declare (type continuation x y))
-  (let ((x-use (continuation-use x))
-	(y-use (continuation-use y)))
-    (and (ref-p x-use)
-	 (ref-p y-use)
-	 (eq (ref-leaf x-use) (ref-leaf y-use)))))
-
-
-;;; SIMPLE-EQUALITY-TRANSFORM  --  Internal
-;;;
-;;;    If X and Y are the same leaf, then the result is true.  Otherwise, if
-;;; there is no intersection between the types of the arguments, then the
-;;; result is definitely false.
-;;;
-(deftransform simple-equality-transform ((x y) * * :defun-only t)
-  (cond ((same-leaf-ref-p x y)
-	 't)
-	((types-intersect (continuation-type x) (continuation-type y))
-	 (give-up))
-	(t
-	 'nil)))
-
-(dolist (x '(eq char= equal))
-  (%deftransform x 'function #'simple-equality-transform))
-
-
-;;; EQL IR1 Transform  --  Internal
-;;;
-;;;    Similar to SIMPLE-EQUALITY-PREDICATE, except that we also try to convert
-;;; to a type-specific predicate or EQ:
-;;;
-;;; -- If both args are characters, convert to CHAR=.  This is better than just
-;;;    converting to EQ, since CHAR= may have special compilation strategies
-;;;    for non-standard representations, etc.
-;;; -- If both args are the "same" numeric type, then convert to =.  This
-;;;    allows all of ='s expertise to come into play.  "Same" means either both
-;;;    rational or both floats of the same format.  Complexp must also be
-;;;    specified and identical.
-;;; -- If either arg is definitely not a number, then we can compare with EQ.
-;;; -- If either arg is definitely a fixnum, then we can compare with EQ.
-;;;
-(deftransform eql ((x y))
-  (let ((x-type (continuation-type x))
-	(y-type (continuation-type y))
-	(char-type (specifier-type 'character))
-	(fixnum-type (specifier-type 'fixnum))
-	(number-type (specifier-type 'number)))
-    (cond ((same-leaf-ref-p x y)
-	   't)
-	  ((not (types-intersect x-type y-type))
-	   'nil)
-	  ((and (csubtypep x-type char-type)
-		(csubtypep y-type char-type))
-	   '(char= x y))
-	  ((and (numeric-type-p x-type) (numeric-type-p y-type)
-		(let ((x-class (numeric-type-class x-type))
-		      (y-class (numeric-type-class y-type))
-		      (x-format (numeric-type-format x-type)))
-		  (or (and (eq x-class 'float) (eq y-class 'float)
-			   x-format
-			   (eq x-format (numeric-type-format y-type)))
-		      (and (member x-class '(rational integer))
-			   (member y-class '(rational integer)))))
-		(let ((x-complexp (numeric-type-complexp x-type)))
-		  (and x-complexp
-		       (eq x-complexp (numeric-type-complexp y-type)))))
-	   '(= x y))
-	  ((or (not (types-intersect x-type number-type))
-	       (not (types-intersect y-type number-type)))
-	   '(eq x y))
-	  ((or (csubtypep x-type fixnum-type)
-	       (csubtypep y-type fixnum-type))
-	   '(eq x y))
-	  (t
-	   (give-up "Not enough type information to open-code.")))))
-
-
-;;; Numeric-Type-Or-Lose  --  Interface
-;;;
-;;;    If Cont's type is a numeric type, then return the type, otherwise
-;;; GIVE-UP.
-;;;
-(defun numeric-type-or-lose (cont)
-  (declare (type continuation cont))
-  (let ((res (continuation-type cont)))
-    (unless (numeric-type-p res) (give-up))
-    res))
-
-
-;;; IR1-TRANSFORM-<  --  Internal
-;;;
-;;;    See if we can statically determine (< X Y) using type information.  If
-;;; the types don't intersect, then we can always determine the relationship.
-;;; < can only be true if X has a high bound and Y has a low bound, and X's
-;;; high bound is < Y's low bound.
-;;;
-(defun ir1-transform-< (x y)
-  (if (same-leaf-ref-p x y)
-      'nil
-      (let* ((x (numeric-type-or-lose x))
-	     (x-hi (numeric-type-high x))
-	     (y (numeric-type-or-lose y))
-	     (y-lo (numeric-type-low y)))
-	(when (types-intersect x y) (give-up))
-	(if (and x-hi y-lo (< x-hi y-lo))
-	    't
-	    'nil))))
-
-(deftransform < ((x y) (integer integer))
-  (ir1-transform-< x y))
-
-(deftransform > ((x y) (integer integer))
-  (ir1-transform-< y x))
-
-
-;;;; Converting N-arg comparisons:
-;;;
-;;;    We convert calls to N-arg comparison functions such as < into two-arg
-;;; calls.  This transformation is enabled for all such comparisons in this
-;;; file.  If any of these predicates are not open-coded, then the
-;;; transformation should be removed at some point to avoid pessimization.
-
-;;; Multi-Compare  --  Internal
-;;;
-;;;    This function is used for source transformation of N-arg comparison
-;;; functions other than inequality.  We deal both with converting to two-arg
-;;; calls and inverting the sense of the test, if necessary.  If the call has
-;;; two args, then we pass or return a negated test as appropriate.  If it is a
-;;; degenerate one-arg call, then we transform to code that returns true.
-;;; Otherwise, we bind all the arguments and expand into a bunch of IFs.
-;;;
-(proclaim '(function multi-compare (symbol list boolean)))
-(defun multi-compare (predicate args not-p)
-  (let ((nargs (length args)))
-    (cond ((< nargs 1) (values nil t))
-	  ((= nargs 1) `(progn ,@args t))
-	  ((= nargs 2)
-	   (if not-p
-	       `(if (,predicate ,(first args) ,(second args)) nil t)
-	       (values nil t)))
-	  (t
-	   (do* ((i (1- nargs) (1- i))
-		 (last nil current)
-		 (current (gensym) (gensym))
-		 (vars (list current) (cons current vars))
-		 (result 't (if not-p
-				`(if (,predicate ,current ,last)
-				     nil ,result)
-				`(if (,predicate ,current ,last)
-				     ,result nil))))
-	       ((zerop i)
-		`((lambda ,vars ,result) . ,args)))))))
-
-
-(def-source-transform = (&rest args) (multi-compare '= args nil))
-(def-source-transform < (&rest args) (multi-compare '< args nil))
-(def-source-transform > (&rest args) (multi-compare '> args nil))
-(def-source-transform <= (&rest args) (multi-compare '> args t))
-(def-source-transform >= (&rest args) (multi-compare '< args t))
-
-(def-source-transform char= (&rest args) (multi-compare 'char= args nil))
-(def-source-transform char< (&rest args) (multi-compare 'char< args nil))
-(def-source-transform char> (&rest args) (multi-compare 'char> args nil))
-(def-source-transform char<= (&rest args) (multi-compare 'char> args t))
-(def-source-transform char>= (&rest args) (multi-compare 'char< args t))
-
-(def-source-transform char-equal (&rest args) (multi-compare 'char-equal args nil))
-(def-source-transform char-lessp (&rest args) (multi-compare 'char-lessp args nil))
-(def-source-transform char-greaterp (&rest args) (multi-compare 'char-greaterp args nil))
-(def-source-transform char-not-greaterp (&rest args) (multi-compare 'char-greaterp args t))
-(def-source-transform char-not-lessp (&rest args) (multi-compare 'char-lessp args t))
-
-
-;;; Multi-Not-Equal  --  Internal
-;;;
-;;;    This function does source transformation of N-arg inequality functions
-;;; such as /=.  This is similar to Multi-Compare in the <3 arg cases.  If
-;;; there are more than two args, then we expand into the appropriate n^2
-;;; comparisons only when speed is important.
-;;;
-(proclaim '(function multi-not-equal (symbol list)))
-(defun multi-not-equal (predicate args)
-  (let ((nargs (length args)))
-    (cond ((< nargs 1) (values nil t))
-	  ((= nargs 1) `(progn ,@args t))
-	  ((= nargs 2)
-	   `(if (,predicate ,(first args) ,(second args)) nil t))
-	  ((not (policy nil (>= speed space) (>= speed cspeed)))
-	   (values nil t))
-	  (t
-	   (collect ((vars))
-	     (dotimes (i nargs) (vars (gensym)))
-	     (do ((var (vars) next)
-		  (next (cdr (vars)) (cdr next))
-		  (result 't))
-		 ((null next)
-		  `((lambda ,(vars) ,result) . ,args))
-	       (let ((v1 (first var)))
-		 (dolist (v2 next)
-		   (setq result `(if (,predicate ,v1 ,v2) nil ,result))))))))))
-
-(def-source-transform /= (&rest args) (multi-not-equal '= args))
-(def-source-transform char/= (&rest args) (multi-not-equal 'char= args))
-(def-source-transform char-not-equal (&rest args) (multi-not-equal 'char-equal args))
-
-
-;;; Expand Max and Min into the obvious comparisons.
-(def-source-transform max (arg &rest more-args)
-  (if (null more-args)
-      `(values ,arg)
-      (once-only ((arg1 arg)
-		  (arg2 `(max ,@more-args)))
-	`(if (> ,arg1 ,arg2)
-	     ,arg1 ,arg2))))
-;;;
-(def-source-transform min (arg &rest more-args)
-  (if (null more-args)
-      `(values ,arg)
-      (once-only ((arg1 arg)
-		  (arg2 `(min ,@more-args)))
-	`(if (< ,arg1 ,arg2)
-	     ,arg1 ,arg2))))
-
-
-;;;; Converting N-arg arithmetic functions:
-;;;
-;;;    N-arg arithmetic and logic functions are associated into two-arg
-;;; versions, and degenerate cases are flushed.
-
-;;; Associate-Arguments  --  Internal
-;;;
-;;;    Left-associate First-Arg and More-Args using Function.
-;;;
-(proclaim '(function associate-arguments (symbol t list) list))
-(defun associate-arguments (function first-arg more-args)
-  (let ((next (rest more-args))
-	(arg (first more-args)))
-    (if (null next)
-	`(,function ,first-arg ,arg)
-	(associate-arguments function `(,function ,first-arg ,arg) next))))
-
-;;; Source-Transform-Transitive  --  Internal
-;;;
-;;;    Do source transformations for transitive functions such as +.  One-arg
-;;; cases are replaced with the arg and zero arg cases with the identity.  If
-;;; Leaf-Fun is true, then replace two-arg calls with a call to that function. 
-;;;
-(proclaim '(function source-transform-transitive
-		     (symbol list (or symbol null))
-		     void))
-(defun source-transform-transitive (fun args identity &optional leaf-fun)
-  (case (length args)
-    (0 identity)
-    (1 `(values ,(first args)))
-    (2 (if leaf-fun
-	   `(,leaf-fun ,(first args) ,(second args))
-	   (values nil t)))
-    (t
-     (associate-arguments fun (first args) (rest args)))))
-
-(def-source-transform + (&rest args) (source-transform-transitive '+ args 0))
-(def-source-transform * (&rest args) (source-transform-transitive '* args 1))
-(def-source-transform logior (&rest args) (source-transform-transitive 'logior args 0))
-(def-source-transform logxor (&rest args) (source-transform-transitive 'logxor args 0))
-(def-source-transform logand (&rest args) (source-transform-transitive 'logand args -1))
-(def-source-transform logeqv (&rest args)
-  (source-transform-transitive 'logeqv args -1 'logeqv-two-arg))
-
-
-;;; Source-Transform-Intransitive  --  Internal
-;;;
-;;;    Do source transformations for intransitive n-arg functions such as /.
-;;; With one arg, we form the inverse using the indentity, with two args we
-;;; pass, otherwise we associate into two-arg calls.
-;;;
-(proclaim '(function source-transform-intransitive (symbol list t) list))
-(defun source-transform-intransitive (function args identity)
-  (case (length args)
-    ((0 2) (values nil t))
-    (1 `(,function ,identity ,(first args)))
-    (t
-     (associate-arguments function (first args) (rest args)))))
-
-(def-source-transform - (&rest args) (source-transform-intransitive '- args 0))
-(def-source-transform / (&rest args) (source-transform-intransitive '/ args 1))
-
-(deftransform - ((x y))
-  (unless (and (constant-continuation-p x) (zerop (continuation-value x)))
-    (give-up))
-  '(%negate y))
-
-
-;;;; Array accessors:
-;;;
-;;;    We convert all array accessors into aref and %aset.
-;;;
-
-(def-source-transform svref (a i) `(aref (the simple-vector ,a) ,i))
-(def-source-transform %svset (a i v) `(%aset (the simple-vector ,a) ,i ,v))
-
-(def-source-transform schar (a i) `(aref (the simple-string ,a) ,i))
-(def-source-transform %scharset (a i v) `(%aset (the simple-string ,a) ,i ,v))
-(def-source-transform char (a i) `(aref (the string ,a) ,i))
-(def-source-transform %charset (a i v) `(%aset (the string ,a) ,i ,v))
-
-(def-source-transform sbit (a &rest i) `(aref (the (simple-array bit) ,a) ,@i))
-(def-source-transform %sbitset (a &rest i) `(%aset (the (simple-array bit) ,a) ,@i))
-(def-source-transform bit (a &rest i) `(aref (the (array bit) ,a) ,@i))
-(def-source-transform %bitset (a &rest i) `(%aset (the (array bit) ,a) ,@i))
-
-
-(def-source-transform vector (&rest elements)
-  (let ((len (length elements))
-	(n -1))
-    (once-only ((n-vec `(make-array ,len)))
-      `(progn 
-	 ,@(mapcar #'(lambda (el)
-		       (once-only ((n-val el))
-			 `(locally (declare (optimize (safety 0)))
-			    (setf (svref ,n-vec ,(incf n)) ,n-val))))
-		   elements)
-	 ,n-vec))))
-
-
-(deftransform make-array ((length &key initial-element element-type)
-			  (integer &rest *))
-  (let* ((eltype (cond ((not element-type) t)
-		       ((not (constant-continuation-p element-type))
-			(give-up "Element-Type is not constant."))
-		       (t
-			(continuation-value element-type))))
-	 (len (if (constant-continuation-p length)
-		  (continuation-value length)
-		  '*))
-	 (spec `(simple-array ,eltype (,len)))
-	 (type (specifier-type spec)))
-    (cond ((csubtypep type (specifier-type 'simple-string))
-	   (when initial-element
-	     (give-up "Can't hack initial elements in strings."))
-	   `(truly-the ,spec (%primitive alloc-string length)))
-	  ((csubtypep type (specifier-type 'simple-bit-vector))
-	   (unless (or (not initial-element)
-		       (and (constant-continuation-p initial-element)
-			    (eql (continuation-value initial-element) 0)))
-	     (give-up "Can't hack non-zero initial-elements in bit-vectors."))
-	   `(truly-the ,spec (%primitive alloc-bit-vector length)))
-	  ((csubtypep type (specifier-type 'simple-vector))
-	   `(truly-the ,spec
-		       (%primitive alloc-g-vector length initial-element)))
-	  (t
-	   (give-up "Can't open-code creation of ~S."
-		    (type-specifier type))))))
-
-
-;;; ### Should pass though any :INITIAL-ELEMENT to MAKE-ARRAY, but this would
-;;; be a pessimization until the compiler can transform MAKE-ARRAY of strings
-;;; with initial elements.  Until then, it is faster to call MAKE-STRING than
-;;; MAKE-ARRAY.
-;;;
-(def-source-transform make-string (length)
-  `(make-array ,length :element-type 'string-char))
-
-
-(deftransform array-dimension ((array dim)
-			       ((simple-array * (*)) (integer 0 0)))
-  '(length array))
-			       
-
-;;;; Apply:
-;;;
-;;;    We convert Apply into Multiple-Value-Call so that the compiler only
-;;; needs to understand one kind of variable-argument call.  It is more
-;;; efficient to convert Apply to MV-Call than MV-Call to Apply.
-
-(def-source-transform apply (fun arg &rest more-args)
-  (let ((args (cons arg more-args)))
-    `(multiple-value-call ,fun
-       ,@(mapcar #'(lambda (x)
-		     `(values ,x))
-		 (butlast args))
-       (values-list ,(car (last args))))))
-
-
-;;;; FORMAT transform:
-
-;;; A transform for FORMAT, based on the original (courtesy of Skef.)
-;;;
-(deftransform format ((stream control &rest args)
-		      ((or (member t) stream) simple-string &rest t))
-  (unless (constant-continuation-p control)
-    (give-up "Control string is not a constant."))
-  (let* ((control (continuation-value control))
-	 (end (length control))
-	 (penultimus (1- end))
-	 (stream-form (if (csubtypep (continuation-type stream)
-				     (specifier-type 'stream))
-			  `(stream)
-			  ()))
-	 (arg-vars (mapcar #'(lambda (x)
-			       (declare (ignore x))
-			       (gensym))
-			   args))
-	 (args arg-vars)
-	 (index 0))
-    (declare (simple-string control))
-    (collect ((forms))
-      (loop
-	(let ((command-index (position #\~ control :start index)))
-	  (unless command-index
-	    ;; Write out the final part of the string.
-	    (forms `(write-string ,(subseq control index end)
-				  ,@stream-form))
-	    (return `(lambda (stream control ,@arg-vars)
-		       (declare (ignorable stream control))
-		       ,@(forms)
-		       nil)))
-
-	  (when (= command-index penultimus)
-	    (abort-transform "FORMAT control string ends in a ~~: ~S"
-			     (continuation-value control)))
-
-	  ;; Non-command stuff gets write-string'ed out.
-	  (when (/= index command-index)
-	    (forms `(write-string
-		     ,(subseq control index command-index)
-		     ,@stream-form)))
-	  
-	  ;; Get the format directive.
-	  (forms
-	   (case (schar control (1+ command-index))
-	     ((#\b #\B) `(let ((*print-base* 2))
-			   (princ ,(pop args) ,@stream-form)))
-	     ((#\o #\O) `(let ((*print-base* 8))
-			   (princ ,(pop args) ,@stream-form)))
-	     ((#\d #\D) `(let ((*print-base* 10))
-			   (princ ,(pop args) ,@stream-form)))
-	     ((#\x #\X) `(let ((*print-base* 16))
-			   (princ ,(pop args) ,@stream-form)))
-	     ((#\a #\A) `(princ ,(pop args) ,@stream-form))
-	     ((#\s #\S) `(prin1 ,(pop args) ,@stream-form))
-	     (#\% `(terpri ,@stream-form))
-	     (#\& `(fresh-line ,@stream-form))
-	     (#\| `(write-char #\form ,@stream-form))
-	     (#\~ `(write-char #\~ ,@stream-form))
-	     (#\newline
-	      (let ((new-pos (position-if-not
-			      #'lisp::whitespace-char-p
-			      control
-			      :start (+ command-index 2))))
-		(if new-pos
-		    (setq command-index (- new-pos 2)))))
-	     (t
-	      (give-up))))
-
-	  (setq index (+ command-index 2)))))))
diff --git a/compiler/sset.lisp b/compiler/sset.lisp
deleted file mode 100644
index d59eb71fda0d5c07cd23dd324e80954ab025140d..0000000000000000000000000000000000000000
--- a/compiler/sset.lisp
+++ /dev/null
@@ -1,295 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    A sparse set abstraction, implemented as a sorted linked list.  We don't
-;;; use bit-vectors to represent sets in flow analysis, since the universe may
-;;; be quite large but the average number of elements is small.  We keep the
-;;; list sorted so that we can do union and intersection in linear time.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-;;;
-;;; Each structure that may be placed in a SSet must include the SSet-Element
-;;; structure.  We allow an initial value of NIL to mean that no ordering has
-;;; been assigned yet (although an ordering must be assigned before doing set
-;;; operations.)
-;;;
-(defstruct sset-element
-  (number nil :type (or unsigned-byte null)))
-
-
-(defstruct (sset (:constructor make-sset ())
-		 (:copier nil)
-		 (:print-function %print-sset))
-  (elements (list nil) :type list))
-
-
-(defprinter sset
-  (elements :prin1 (cdr elements)))
-
-
-;;; Do-Elements  --  Interface
-;;;
-;;;    Iterate over the elements in Set, binding Var to each element in turn.
-;;;
-(defmacro do-elements ((var set &optional result) &body body)
-  `(dolist (,var (cdr (sset-elements ,set)) ,result) ,@body))
-
-
-;;; SSet-Adjoin  --  Interface
-;;;
-;;;    Destructively add Element to Set.  If Element was not in the set, then
-;;; we return true, otherwise we return false.
-;;;
-(proclaim '(function sset-adjoin (sset-element sset) boolean))
-(defun sset-adjoin (element set)
-  (let ((number (sset-element-number element))
-	(elements (sset-elements set)))
-    (do ((prev elements current)
-	 (current (cdr elements) (cdr current)))
-	((null current)
-	 (setf (cdr prev) (list element))
-	 t)
-      (let ((el (car current)))
-	(when (>= (sset-element-number el) number)
-	  (when (eq el element)
-	    (return nil))
-	  (setf (cdr prev) (cons element current))
-	  (return t))))))
-
-
-;;; SSet-Delete  --  Interface
-;;;
-;;;    Destructively remove Element from Set.  If element was in the set,
-;;; then return true, otherwise return false.
-;;;
-(proclaim '(function sset-delete (sset-element sset) boolean))
-(defun sset-delete (element set)
-  (let ((elements (sset-elements set)))
-    (do ((prev elements current)
-	 (current (cdr elements) (cdr current)))
-	((null current) nil)
-      (when (eq (car current) element)
-	(setf (cdr prev) (cdr current))
-	(return t)))))
-
-
-;;; SSet-Member  --  Interface
-;;;
-;;;    Return true if Element is in Set, false otherwise.
-;;;
-(proclaim '(function sset-member (sset-element sset) boolean))
-(defun sset-member (element set)
-  (declare (inline member))
-  (not (null (member element (cdr (sset-elements set)) :test #'eq))))
-
-
-;;; SSet-Empty  --  Interface
-;;;
-;;;    Return true if Set contains no elements, false otherwise.
-;;;
-(proclaim '(function sset-empty (sset) boolean))
-(defun sset-empty (set)
-  (null (cdr (sset-elements set))))
-
-
-;;; SSet-Singleton  --  Interface
-;;;
-;;;    If Set contains exactly one element, then return it, otherwise return
-;;; NIL.
-;;;
-(proclaim '(function sset-singleton (sset) (or sset-element null)))
-(defun sset-singleton (set)
-  (let ((elements (cdr (sset-elements set))))
-    (if (and elements (not (cdr elements)))
-	(car elements)
-	nil)))
-
-
-;;; SSet-Subsetp  --  Interface
-;;;
-;;;    If Set1 is a (not necessarily proper) subset of Set2, then return true,
-;;; otherwise return false.
-;;;
-(proclaim '(function sset-subsetp (sset sset) boolean))
-(defun sset-subsetp (set1 set2)
-  (let ((el2 (cdr (sset-elements set2))))
-    (do ((el1 (cdr (sset-elements set1)) (cdr el1)))
-	((null el1) t)
-      (let ((num1 (sset-element-number (car el1))))
-	(loop
-	 (when (null el2) (return-from sset-subsetp nil))
-	 (let ((num2 (sset-element-number (pop el2))))
-	   (when (>= num2 num1)
-	     (when (> num2 num1) (return-from sset-subsetp nil))
-	     (return))))))))
-
-
-;;; SSet-Equal  --  Interface
-;;;
-;;;    Return true if Set1 and Set2 contain the same elements, false otherwise.
-;;;
-(proclaim '(function sset-equal (sset sset) boolean))
-(defun sset-equal (set1 set2)
-  (do ((el1 (cdr (sset-elements set1)) (cdr el1))
-       (el2 (cdr (sset-elements set2)) (cdr el2)))
-      (())
-    (when (null el1) (return (null el2)))
-    (when (null el2) (return nil))
-    (unless (eq (car el1) (car el2)) (return nil))))
-
-
-;;; Copy-SSet  --  Interface
-;;;
-;;;    Return a new copy of Set.
-;;;
-(proclaim '(function copy-sset (sset) sset))
-(defun copy-sset (set)
-  (let ((res (make-sset)))
-    (setf (sset-elements res) (copy-list (sset-elements set)))
-    res))
-
-
-;;; SSet-Union, SSet-Intersection, SSet-Difference  --  Interface
-;;;
-;;; Perform the appropriate set operation on Set1 and Set2 by destructively
-;;; modifying Set1.  We return true if Set1 was modified, false otherwise.
-;;;
-(proclaim '(ftype (function (sset sset) boolean) sset-union sset-intersection
-		  sset-difference))
-(defun sset-union (set1 set2)
-  (let* ((prev-el1 (sset-elements set1))
-	 (el1 (cdr prev-el1))
-	 (changed nil))
-    (do ((el2 (cdr (sset-elements set2)) (cdr el2)))
-	((null el2) changed)
-      (let* ((e (car el2))
-	     (num2 (sset-element-number e)))
-	(loop
-	  (when (null el1)
-	    (setf (cdr prev-el1) (copy-list el2))
-	    (return-from sset-union t))
-	  (let ((num1 (sset-element-number (car el1))))
-	    (when (>= num1 num2)
-	      (if (> num1 num2)
-		  (let ((new (cons e el1)))
-		    (setf (cdr prev-el1) new)
-		    (setq prev-el1 new  changed t))
-		  (shiftf prev-el1 el1 (cdr el1)))
-	      (return))
-	    (shiftf prev-el1 el1 (cdr el1))))))))
-;;;
-(defun sset-intersection (set1 set2)
-  (let* ((prev-el1 (sset-elements set1))
-	 (el1 (cdr prev-el1))
-	 (changed nil))
-    (do ((el2 (cdr (sset-elements set2)) (cdr el2)))
-	((null el2)
-	 (cond (el1
-		(setf (cdr prev-el1) nil)
-		t)
-	       (t changed)))
-      (let ((num2 (sset-element-number (car el2))))
-	(loop
-	  (when (null el1)
-	    (return-from sset-intersection changed))
-	  (let ((num1 (sset-element-number (car el1))))
-	    (when (>= num1 num2)
-	      (when (= num1 num2)
-		(shiftf prev-el1 el1 (cdr el1)))
-	      (return))
-	    (pop el1)
-	    (setf (cdr prev-el1) el1)
-	    (setq changed t)))))))
-;;;
-(defun sset-difference (set1 set2)
-  (let* ((prev-el1 (sset-elements set1))
-	 (el1 (cdr prev-el1))
-	 (changed nil))
-    (do ((el2 (cdr (sset-elements set2)) (cdr el2)))
-	((null el2) changed)
-      (let ((num2 (sset-element-number (car el2))))
-	(loop
-	  (when (null el1)
-	    (return-from sset-difference changed))
-	  (let ((num1 (sset-element-number (car el1))))
-	    (when (>= num1 num2)
-	      (when (= num1 num2)
-		(pop el1)
-		(setf (cdr prev-el1) el1)
-		(setq changed t))
-	      (return))
-	    (shiftf prev-el1 el1 (cdr el1))))))))
-
-
-;;; SSet-Union-Of-Difference  --  Interface
-;;;
-;;;    Destructively modify Set1 to include its union with the difference of
-;;; Set2 and Set3.  We return true if Set1 was modified, false otherwise.
-;;;
-(proclaim '(function sset-union-of-difference (sset sset sset) boolean))
-(defun sset-union-of-difference (set1 set2 set3)
-  (let* ((prev-el1 (sset-elements set1))
-	 (el1 (cdr prev-el1))
-	 (el3 (cdr (sset-elements set3)))
-	 (changed nil))
-    (do ((el2 (cdr (sset-elements set2)) (cdr el2)))
-	((null el2) changed)
-      (let* ((e (car el2))
-	     (num2 (sset-element-number e)))
-	(loop
-	  (when (null el3)
-	    (loop
-	      (when (null el1)
-		(setf (cdr prev-el1) (copy-list el2))
-		(return-from sset-union-of-difference t))
-	      (let ((num1 (sset-element-number (car el1))))
-		(when (>= num1 num2)
-		  (if (> num1 num2)
-		      (let ((new (cons e el1)))
-			(setf (cdr prev-el1) new)
-			(setq prev-el1 new  changed t))
-		      (shiftf prev-el1 el1 (cdr el1)))
-		  (return))
-		(shiftf prev-el1 el1 (cdr el1))))
-	    (return))
-	  (let ((num3 (sset-element-number (car el3))))
-	    (when (<= num2 num3)
-	      (unless (= num2 num3)
-		(loop
-		  (when (null el1)
-		    (do ((el2 el2 (cdr el2)))
-			((null el2)
-			 (return-from sset-union-of-difference changed))
-		      (let* ((e (car el2))
-			     (num2 (sset-element-number e)))
-			(loop
-			  (when (null el3)
-			    (setf (cdr prev-el1) (copy-list el2))
-			    (return-from sset-union-of-difference t))
-			  (when (<= num2 num3)
-			    (unless (= num2 num3)
-			      (let ((new (cons e el1)))
-				(setf (cdr prev-el1) new)
-				(setq prev-el1 new  changed t)))
-			    (return))
-			  (pop el3)))))
-		  (let ((num1 (sset-element-number (car el1))))
-		    (when (>= num1 num2)
-		      (if (> num1 num2)
-			  (let ((new (cons e el1)))
-			    (setf (cdr prev-el1) new)
-			    (setq prev-el1 new  changed t))
-			  (shiftf prev-el1 el1 (cdr el1)))
-		      (return))
-		    (shiftf prev-el1 el1 (cdr el1)))))
-	      (return)))
-	  (pop el3))))))
diff --git a/compiler/stack.lisp b/compiler/stack.lisp
deleted file mode 100644
index d0eb64b70aab32acfd656fee3a6e023e0dd08467..0000000000000000000000000000000000000000
--- a/compiler/stack.lisp
+++ /dev/null
@@ -1,214 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    The stack analysis phase in the compiler.  We do a graph walk to
-;;; determine which unknown-values continuations are on the stack at each point
-;;; in the program, and then we insert cleanup code to pop off unused values.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-
-;;; Find-Pushed-Continuations  --  Internal
-;;;
-;;;    Scan through Block looking for uses of :Unknown continuations that have
-;;; their Dest outside of the block.  We do some checking to verify the
-;;; invariant that all pushes come after the last pop.
-;;;
-(defun find-pushed-continuations (block)
-  (let* ((2block (block-info block))
-	 (popped (ir2-block-popped 2block))
-	 (last-pop (if popped
-		       (continuation-dest (car (last popped)))
-		       nil)))
-    (collect ((pushed))
-      (let ((saw-last nil))
-	(do-nodes (node cont block)
-	  (when (eq node last-pop)
-	    (setq saw-last t))
-
-	  (let ((dest (continuation-dest cont))
-		(2cont (continuation-info cont)))
-	    (when (and dest
-		       (not (eq (node-block dest) block))
-		       2cont
-		       (eq (ir2-continuation-kind 2cont) :unknown))
-	      (assert (or saw-last (not last-pop)))
-	      (pushed cont)))))
-
-      (setf (ir2-block-pushed 2block) (pushed))))
-  (undefined-value))
-
-
-;;;; Annotation graph walk:
-
-;;; Stack-Simulation-Walk  --  Internal
-;;;
-;;;    Do a backward walk in the flow graph simulating the run-time stack of
-;;; unknown-values continuations and annotating the blocks with the result.
-;;;
-;;;    Block is the block that is currently being walked and Stack is the stack
-;;; of unknown-values continuations in effect immediately after block.  We
-;;; simulate the stack by popping off the unknown-values generated by this
-;;; block (if any) and pushing the continuations for values received by this
-;;; block.  (The role of push and pop are interchanged because we are doing a
-;;; backward walk.)
-;;;
-;;;    If we run into a values generator whose continuation isn't on stack top,
-;;; then the receiver hasn't yet been reached on any walk to this use.  In this
-;;; case, we ignore the push for now, counting on Annotate-Dead-Values to clean
-;;; it up if we discover that it isn't reachable at all.
-;;;
-;;;    If our final stack isn't empty, then we walk all the predecessor blocks
-;;; that have less stuff on their End-Stack than we have on our Start-Stack.
-;;; This is our termination condition for the graph walk.  We put the test
-;;; around the recursive call so that the initial call to this function will do
-;;; something even though there isn't initially anything on the stack.
-;;;
-;;;    If a predecessor block is the component head, then it must be the case
-;;; that this is a NLX entry stub.  If so, we just stop our walk, since the
-;;; stack at the exit point doesn't have anything to do with our stack.
-;;;
-(defun stack-simulation-walk (block stack)
-  (declare (type cblock block) (list stack))
-  (let ((2block (block-info block)))
-    (setf (ir2-block-end-stack 2block) stack)
-    (let ((new-stack stack))
-      (dolist (push (reverse (ir2-block-pushed 2block)))
-	(if (eq (car new-stack) push)
-	    (pop new-stack)
-	    (assert (not (member push new-stack)))))
-      
-      (dolist (pop (reverse (ir2-block-popped 2block)))
-	(push pop new-stack))
-      
-      (setf (ir2-block-start-stack 2block) new-stack)
-      
-      (when new-stack
-	(dolist (pred (block-pred block))
-	  (if (eq pred (component-head (block-component block)))
-	      (assert (find block
-			    (environment-nlx-info
-			     (lambda-environment
-			      (block-lambda block)))
-			    :key #'nlx-info-target))
-	      (let ((pred-stack (ir2-block-end-stack (block-info pred))))
-		(unless (tailp new-stack pred-stack)
-		  (assert (or (null pred-stack) (tailp pred-stack new-stack)))
-		  (stack-simulation-walk pred new-stack))))))))
-
-  (undefined-value))
-
-
-;;; Annotate-Dead-Values  --  Internal
-;;;
-;;;    Do stack annotation for any values generators in Block that were
-;;; unreached by all walks (i.e. the continuation isn't live at the point that
-;;; it is generated.)  This will only happen when the values receiver cannot be
-;;; reached from this particular generator (due to an unconditional control
-;;; transfer.)
-;;;
-;;;    What we do is push on the End-Stack all continuations in Pushed that
-;;; aren't already present in the End-Stack.  When we find any pushed
-;;; continuation that isn't live, it must be the case that all continuations
-;;; pushed after (on top of) it aren't live.
-;;;
-(defun annotate-dead-values (block)
-  (declare (type cblock block))
-  (let* ((2block (block-info block))
-	 (stack (ir2-block-end-stack 2block)))
-    (do ((pushes (ir2-block-pushed 2block) (rest pushes)))
-	((null pushes))
-      (unless (member (first pushes) stack)
-	(dolist (push pushes)
-	  (assert (not (member push stack)))
-	  (push push (ir2-block-end-stack 2block))))))
-  
-  (undefined-value))
-
-
-;;; Discard-Unused-Values  --  Internal
-;;;
-;;;    Called when we discover that the stack-top unknown-values continuation
-;;; at the end of Block1 is different from that at the start of Block2 (its
-;;; successor.)
-;;;
-;;;    We insert a call to a funny function in a new cleanup block introduced
-;;; between Block1 and Block2.  Since control analysis and LTN have already
-;;; run, we must do make an IR2 block, then do ADD-TO-EMIT-ORDER and
-;;; LTN-ANALYZE-BLOCK on the new block.  The new block is inserted after Block1
-;;; in the emit order.
-;;;
-;;;    If the control transfer between Block1 and Block2 represents a
-;;; tail-recursive return (:Deleted IR2-continuation) or a non-local exit, then
-;;; the cleanup code will never actually be executed.  It doesn't seem to be
-;;; worth the risk of trying to optimize this, since this rarely happens and
-;;; wastes only space.
-;;;
-(defun discard-unused-values (block1 block2)
-  (declare (type cblock block1 block2))
-  (let* ((block1-stack (ir2-block-end-stack (block-info block1)))
-	 (block2-stack (ir2-block-start-stack (block-info block2)))
-	 (last-popped (elt block1-stack
-			   (- (length block1-stack)
-			      (length block2-stack)
-			      1))))
-    (assert (or (tailp block2-stack block1-stack)
-		(null block2-stack))) ; !@#%* tailp bug.
-
-    (let* ((block (insert-cleanup-code block1 block2
-				       (continuation-next (block-start block2))
-				       `(%pop-values ',last-popped)))
-	   (2block (make-ir2-block block)))
-      (setf (block-info block) 2block)
-      (add-to-emit-order 2block (block-info block1))
-      (ltn-analyze-block block)))
-
-  (undefined-value))
-
-
-;;; Stack-Analyze  --  Interface
-;;;
-;;;    Analyze the use of unknown-values continuations in Component, inserting
-;;; cleanup code to discard values that are generated but never received.  This
-;;; phase doesn't need to be run when Values-Receivers is null, i.e. there are
-;;; no unknown-values continuations used across block boundaries.
-;;; Values-Generators is always null when Values-Receivers is null.
-;;;
-;;;    Do the backward graph walk, starting at each values receiver.  We ignore
-;;; receivers that already have a non-null Start-Stack.  These are nested
-;;; values receivers that have already been reached on another walk.  We don't
-;;; want to clobber that result with our null initial stack. 
-;;;
-(defun stack-analyze (component)
-  (declare (type component component))
-  (let* ((2comp (component-info component))
-	 (receivers (ir2-component-values-receivers 2comp))
-	 (generators (ir2-component-values-generators 2comp)))
-
-    (dolist (block generators)
-      (find-pushed-continuations block))
-    
-    (dolist (block receivers)
-      (unless (ir2-block-start-stack (block-info block))
-	(stack-simulation-walk block ())))
-    
-    (dolist (block generators)
-      (annotate-dead-values block))
-    
-    (do-blocks (block component)
-      (let ((top (car (ir2-block-end-stack (block-info block)))))
-	(dolist (succ (block-succ block))
-	  (when (and (block-lambda succ)
-		     (not (eq (car (ir2-block-start-stack (block-info succ)))
-			      top)))
-	    (discard-unused-values block succ))))))
-  
-  (undefined-value))
diff --git a/compiler/tn.lisp b/compiler/tn.lisp
deleted file mode 100644
index 2c3b1b76b86d8b830088262e3cb277d6436eed46..0000000000000000000000000000000000000000
--- a/compiler/tn.lisp
+++ /dev/null
@@ -1,328 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    This file contains utilities used for creating and manipulating TNs, and
-;;; some other more assorted IR2 utilities.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-;;; The component that is currently being compiled.  TNs are allocated in this
-;;; component.
-;;;
-(defvar *compile-component*)
-
-
-;;; Do-Packed-TNs  --  Interface
-;;;
-(defmacro do-packed-tns ((tn component &optional result) &body body)
-  "Do-Packed-TNs (TN-Var Component [Result]) Declaration* Form*
-  Iterate over all packed TNs allocated in Component."
-  (let ((n-component (gensym)))
-    `(let ((,n-component (component-info ,component)))
-       (do ((,tn (ir2-component-normal-tns ,n-component) (tn-next ,tn)))
-	   ((null ,tn))
-	 ,@body)
-       (do ((,tn (ir2-component-restricted-tns ,n-component) (tn-next ,tn)))
-	   ((null ,tn))
-	 ,@body)
-       (do ((,tn (ir2-component-wired-tns ,n-component) (tn-next ,tn)))
-	   ((null ,tn)
-	    ,result)
-	 ,@body))))
-
-
-;;; Delete-Unreferenced-TNs  --  Interface
-;;;
-;;;    Remove all TNs with no references from the lists of unpacked TNs.  We
-;;; null out the Offset so that nobody will mistake deleted wired TNs for
-;;; properly packed TNs.
-;;;
-(defun delete-unreferenced-tns (component)
-  (macrolet ((frob (name)
-	       `(let ((prev nil))
-		  (do ((tn ,name (tn-next tn)))
-		      ((null tn))
-		    (cond ((or (tn-reads tn) (tn-writes tn))
-			   (setq prev tn))
-			  (t
-			   (if prev
-			       (setf (tn-next prev) (tn-next tn))
-			       (setf ,name (tn-next tn)))
-			   (setf (tn-offset tn) nil)))))))
-    (let ((2comp (component-info component)))
-      (frob (ir2-component-normal-tns 2comp))
-      (frob (ir2-component-restricted-tns 2comp))
-      (frob (ir2-component-wired-tns 2comp))))
-  (undefined-value))
-
-
-
-;;;; TN Creation:
-
-;;; Make-Normal-TN  --  Interface
-;;;
-;;;    Create a packed TN of the specified primitive-type in the
-;;; *Compile-Component*.  We use the SCs from the primitive type to determine
-;;; which SCs it can be packed in.
-;;;
-(defun make-normal-tn (type)
-  (declare (type primitive-type type))
-  (let* ((component (component-info *compile-component*))
-	 (res (make-tn (incf (ir2-component-global-tn-counter component))
-		       :normal type nil))
-	 (costs (tn-costs res)))
-    (dolist (scn (primitive-type-scs type))
-      (setf (svref costs scn) 0))
-    (push-in tn-next res (ir2-component-normal-tns component))
-    res))
-
-
-;;; Make-Environment-TN  --  Interface
-;;;
-;;;    Like Make-Normal-TN, but give it a :Environment kind and note it in the
-;;; specified Environment.
-;;;
-(defun make-environment-tn (type env)
-  (declare (type primitive-type type) (type environment env))
-  (let ((res (make-normal-tn type)))
-    (setf (tn-kind res) :environment)
-    (push res (ir2-environment-live-tns (environment-info env)))
-    res))
-
-
-;;; Make-Restricted-TN  --  Interface
-;;;
-;;;    Create a packed TN restricted to some subset of the SCs normally allowed
-;;; by Type.  SCs is a list of the legal SC numbers.
-;;;
-(defun make-restricted-tn (type scs)
-  (declare (type primitive-type type) (type list scs))
-  (let* ((component (component-info *compile-component*))
-	 (res (make-tn (incf (ir2-component-global-tn-counter component))
-		       :normal type nil))
-	 (costs (tn-costs res)))
-    (dolist (scn scs)
-      (setf (svref costs scn) 0))
-    (push-in tn-next res (ir2-component-restricted-tns component))
-    res))
-
-
-;;; Make-Wired-TN  --  Interface
-;;;
-;;;    Create a TN wired to a particular location in an SC.  We set the Offset
-;;; and FSC to record where it goes, and then put it on the current component's
-;;; Wired-TNs list.  Type is used to determine the move/coerce operations.
-;;;
-(defun make-wired-tn (type scn offset)
-  (declare (type primitive-type type) (type sc-number scn)
-	   (type unsigned-byte offset))
-  (let* ((component (component-info *compile-component*))
-	 (res (make-tn (incf (ir2-component-global-tn-counter component))
-		       :normal type (svref *sc-numbers* scn))))
-    (setf (tn-offset res) offset)
-    (push-in tn-next res (ir2-component-wired-tns component))
-    res))
-
-
-;;; Make-Wired-Environment-TN  --  Interface
-;;;
-;;;    Like Make-Wired-TN, but give it a :Environment kind and note it in the
-;;; specified Environment.
-;;;
-(defun make-wired-environment-tn (type scn offset env)
-  (declare (type primitive-type type) (type sc-number scn)
-	   (type unsigned-byte offset) (type environment env))
-  (let ((res (make-wired-tn type scn offset)))
-    (setf (tn-kind res) :environment)
-    (push res (ir2-environment-live-tns (environment-info env)))
-    res))
-
-
-;;; Make-Constant-TN  --  Interface
-;;;
-;;;    Create a constant TN.  The implementation dependent
-;;; Immediate-Constant-SC function is used to determine whether the constant
-;;; has an immediate representation.
-;;;
-(defun make-constant-tn (constant)
-  (declare (type constant constant))
-  (let* ((component (component-info *compile-component*))
-	 (immed (immediate-constant-sc (constant-value constant)))
-	 (sc (svref *sc-numbers* (or immed (sc-number-or-lose 'constant))))
-	 (res (make-tn 0 :constant (primitive-type (leaf-type constant)) sc)))
-    (unless immed
-      (let ((constants (ir2-component-constants component)))
-	(setf (tn-offset res) (fill-pointer constants))
-	(vector-push-extend constant constants)))
-    (push-in tn-next res (ir2-component-constant-tns component))
-    (setf (tn-leaf res) constant)
-    res))
-
-
-;;; Make-Load-Time-Constant-TN  --  Internal
-;;;
-;;;    Return a load-time constant TN with the specified Kind and Info.  If the
-;;; desired Constants entry already exists, then reuse it, otherwise allocate a
-;;; new load-time constant slot.
-;;;
-(defun make-load-time-constant-tn (kind info)
-  (declare (type keyword kind))
-  (let* ((component (component-info *compile-component*))
-	 (res (make-tn 0 :constant *any-primitive-type*
-		       (svref *sc-numbers* (sc-number-or-lose 'constant))))
-	 (constants (ir2-component-constants component)))
-
-    (do ((i 0 (1+ i)))
-	((= i (length constants))
-	 (setf (tn-offset res) i)
-	 (vector-push-extend (cons kind info) constants))
-      (let ((entry (aref constants i)))
-	(when (and (consp entry)
-		   (eq (car entry) kind)
-		   (eq (cdr entry) info))
-	  (setf (tn-offset res) i))))
-
-    (push-in tn-next res (ir2-component-constant-tns component))
-    res))  
-
-
-;;;; TN referencing:
-
-;;; Reference-TN  --  Interface
-;;;
-;;;    Make a TN-Ref that references TN and return it.  Write-P should be true
-;;; if this is a write reference, otherwise false.  All we do other than
-;;; calling the constructor is add the reference to the TN's references.
-;;;
-(proclaim '(inline reference-tn))
-(defun reference-tn (tn write-p)
-  (declare (type tn tn) (type boolean write-p))
-  (let ((res (make-tn-ref tn write-p)))
-    (if write-p
-	(push-in tn-ref-next res (tn-writes tn))
-	(push-in tn-ref-next res (tn-reads tn)))
-    res))
-
-
-;;; Reference-TN-List  --  Interface
-;;;
-;;;    Make TN-Refs to reference each TN in TNs, linked together by
-;;; TN-Ref-Across.  Write-P is the Write-P value for the refs.  More is 
-;;; stuck in the TN-Ref-Across of the ref for the last TN, or returned as the
-;;; result if there are no TNs.
-;;;
-(defun reference-tn-list (tns write-p &optional more)
-  (declare (list tns) (type boolean write-p) (type (or tn-ref null) more))
-  (if tns
-      (let* ((first (reference-tn (first tns) write-p))
-	     (prev first))
-	(dolist (tn (rest tns))
-	  (let ((res (reference-tn tn write-p)))
-	    (setf (tn-ref-across prev) res)
-	    (setq prev res)))
-	(setf (tn-ref-across prev) more)
-	first)
-      more))
-
-
-;;; Delete-TN-Ref  --  Interface
-;;;
-;;;    Remove Ref from the references for its associated TN.
-;;;
-(defun delete-tn-ref (ref)
-  (declare (type tn-ref ref))
-  (if (tn-ref-write-p ref)
-      (deletef-in tn-ref-next (tn-writes (tn-ref-tn ref)) ref)
-      (deletef-in tn-ref-next (tn-reads (tn-ref-tn ref)) ref))
-  (undefined-value))
-
-
-;;; Change-TN-Ref-TN  --  Interface
-;;;
-;;;    Do stuff to change the TN referenced by Ref.  We remove Ref from it's
-;;; old TN's refs, add ref to TN's refs, and set the TN-Ref-TN.
-;;;
-(defun change-tn-ref-tn (ref tn)
-  (declare (type tn-ref ref) (type tn tn))
-  (delete-tn-ref ref)
-  (setf (tn-ref-tn ref) tn)
-  (if (tn-ref-write-p ref)
-      (push-in tn-ref-next ref (tn-writes tn))
-      (push-in tn-ref-next ref (tn-reads tn)))
-  (undefined-value))
-
-
-;;;; Random utilities:
-
-;;; Make-N-TNs  --  Interface
-;;;
-;;;    Return a list of N normal TNs of the specified primitive type.
-;;;
-(defun make-n-tns (n ptype)
-  (declare (type unsigned-byte n) (type primitive-type ptype))
-  (collect ((res))
-    (dotimes (i n)
-      (res (make-normal-tn ptype)))
-    (res)))
-
-
-;;; Location=  --  Interface
-;;;
-;;;    Return true if X and Y are packed in the same location, false otherwise.
-;;; This is false if either operand is constant.
-;;;
-(defun location= (x y)
-  (declare (type tn x y))
-  (and (eq (sc-sb (tn-sc x)) (sc-sb (tn-sc y)))
-       (eql (tn-offset x) (tn-offset y))
-       (not (or (eq (tn-kind x) :constant)
-		(eq (tn-kind y) :constant)))))
-
-
-;;; TN-Value  --  Interface
-;;;
-;;;    Return the value of an immediate constant TN.
-;;;
-(defun tn-value (tn)
-  (declare (type tn tn))
-  (assert (member (tn-kind tn) '(:constant :cached-constant)))
-  (assert (/= (sc-number (tn-sc tn)) (sc-number-or-lose 'constant)))
-  (constant-value (tn-leaf tn)))
-
-
-;;; Force-TN-To-Stack  --  Interface
-;;;
-;;;    Force TN not to be allocated in a register by clearing the cost for each
-;;; SC that has a Save-SC.
-;;;
-(defun force-tn-to-stack (tn)
-  (declare (type tn tn))
-  (let ((costs (tn-costs tn)))
-    (dotimes (i sc-number-limit)
-      (when (svref *save-scs* i)
-	(setf (svref costs i) nil))))
-  (undefined-value))
-
-
-;;; TN-Environment  --  Interface
-;;;
-;;;    Return some IR2-Environment that TN is referenced in.  TN must have at
-;;; least one reference (either read or write.)  Note that some TNs are
-;;; referenced in multiple environments.
-;;;
-(defun tn-environment (tn)
-  (declare (type tn tn))
-  (let ((ref (or (tn-reads tn) (tn-writes tn))))
-    (assert ref)
-    (environment-info
-     (lambda-environment
-      (block-lambda
-       (ir2-block-block (vop-block (tn-ref-vop ref))))))))
diff --git a/compiler/typetran.lisp b/compiler/typetran.lisp
deleted file mode 100644
index 6080d2997e9ff24ab2b9502502c7af92e42505b0..0000000000000000000000000000000000000000
--- a/compiler/typetran.lisp
+++ /dev/null
@@ -1,402 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    This file contains stuff that implements the portable IR1 semantics of
-;;; type tests.  The main thing we do is convert complex type tests into
-;;; simpler code that can be compiled inline.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-
-;;;; Type predicate translation:
-;;;
-;;;    We maintain a bidirectional association between type predicates and the
-;;; tested type.  The presence of a predicate in this association implies that
-;;; it is desirable to implement tests of this type using the predicate.  This
-;;; is true both of very simple types.  These are either predicates that the
-;;; back end is likely to have special knowledge about, or predicates so
-;;; complex that the only reasonable implentation is via function call.
-;;;
-;;;    Some standard types (such as SEQUENCE) are best tested by letting the
-;;; TYPEP source transform do its thing with the expansion.  These types (and
-;;; corresponding predicates) are not maintained in this association.  In this
-;;; case, there need not be any predicate function unless it is required by
-;;; Common Lisp.
-
-;;; These two variables maintain the translation between types and predicates.
-;;; *Predicate-Types* is a hashtable that translates from type predicate names
-;;; to CType objects.  *Type-Predicates* is an alist (<type> . <predicate>)
-;;; that translates from types to predicates.  We can't use a hashtable, since
-;;; there is no such thing as a Type= hashtable.  Establishing this translation
-;;;
-(defvar *predicate-types* (make-hash-table :test #'eq))
-(proclaim '(hash-table *predicate-types*))
-(defvar *type-predicates* ())
-(proclaim '(list *type-predicates*))
-
-
-;;; Define-Type-Predicate  --  Interface
-;;;
-(defmacro define-type-predicate (name type)
-  "Define-Type-Predicate Name Type
-  Establish an association between the type predicate Name and the
-  corresponding Type.  This causes the type predicate to be recognized for
-  purposes of optimization."
-  `(progn
-     (setf (gethash ',name *predicate-types*) (specifier-type ',type))
-     (setq *type-predicates*
-	   (cons (cons (specifier-type ',type) ',name)
-		 (remove ',name *type-predicates* :key #'cdr)))
-     (%deftransform ',name '(function (t) *) #'fold-type-predicate)
-     ',name))
-
-
-
-;;;; IR1 transforms:
-
-;;; Typep IR1 transform  --  Internal
-;;;
-;;;    If we discover the type argument is constant during IR1 optimization,
-;;; then give the source transform another chance.  The source transform can't
-;;; pass, since we give it an explicit constant.  At worst, it will convert to
-;;; %Typep, which will prevent spurious attempts at transformation (and
-;;; possible repeated warnings.) 
-;;;
-(deftransform typep ((object type))
-  (unless (constant-continuation-p type)
-    (give-up "Can't open-code test of non-constant type."))
-  `(typep object ',(continuation-value type)))
-
-
-;;; IR1-Transform-Type-Predicate  --  Internal
-;;;
-;;;    If the continuation Object definitely is or isn't of the specified type,
-;;; then return T or NIL as appropriate.  Otherwise quietly Give-Up.
-;;;
-(defun ir1-transform-type-predicate (object type)
-  (declare (type continuation object) (type ctype type))
-  (let ((otype (continuation-type object)))
-    (values 
-     (cond ((not (types-intersect otype type)) 'nil)
-	   ((csubtypep otype type) 't)
-	   (t (give-up)))
-     '((declare (ignore object type))))))
-
-
-;;; %Typep IR1 transform  --  Internal
-;;;
-;;;    Flush %Typep tests whose result is known at compile time.
-;;;
-(deftransform %typep ((object type))
-  (ir1-transform-type-predicate
-   object
-   (specifier-type (continuation-value type))))
-
-
-;;; Fold-Type-Predicate IR1 transform  --  Internal
-;;;
-;;;    This is the IR1 transform for simple type predicates.  It checks whether
-;;; the single argument is known to (not) be of the appropriate type, expanding
-;;; to T or NIL as apprporiate.
-;;;
-(deftransform fold-type-predicate ((object type) * * :node node :defun-only t)
-  (let ((ctype (gethash (leaf-name
-			 (ref-leaf
-			  (continuation-use
-			   (basic-combination-fun node))))
-			*predicate-types*)))
-    (assert ctype)
-    (ir1-transform-type-predicate object ctype)))
-
-
-;;;; Standard type predicates:
-
-(define-type-predicate arrayp array)
-; No atom.  Use (not cons) deftype.
-(define-type-predicate bit-vector-p bit-vector)
-(define-type-predicate characterp character)
-(define-type-predicate commonp common)
-(define-type-predicate compiled-function-p compiled-function)
-(define-type-predicate complexp complex)
-(define-type-predicate consp cons)
-(define-type-predicate floatp float)
-(define-type-predicate functionp function)
-(define-type-predicate integerp integer)
-(define-type-predicate keywordp keyword)
-(define-type-predicate listp list)
-(define-type-predicate null null)
-(define-type-predicate numberp number)
-(define-type-predicate rationalp rational)
-(define-type-predicate simple-bit-vector-p simple-bit-vector)
-(define-type-predicate simple-string-p simple-string)
-(define-type-predicate simple-vector-p simple-vector)
-(define-type-predicate stringp string)
-(define-type-predicate structurep structure)
-(define-type-predicate symbolp symbol)
-(define-type-predicate vectorp vector)
-
-
-;;;; Transforms for type predicates not implemented primitively:
-;;;
-;;; See also VM dependent transforms.
-
-(def-source-transform atom (x)
-  `(not (consp ,x)))
-
-
-;;;; Internal predicates:
-;;;
-;;;    These type predicates are used to implement simple cases of typep.  They
-;;; shouldn't be used explicitly.
-
-;;; Numeric type predicates:
-;;;
-(define-type-predicate bignump bignum)
-(define-type-predicate double-float-p double-float)
-(define-type-predicate fixnump fixnum)
-(define-type-predicate long-float-p long-float)
-(define-type-predicate ratiop ratio)
-(define-type-predicate short-float-p short-float)
-(define-type-predicate single-float-p single-float)
-
-;;; Character type predicates.  Unlike the un-%'ed versions, these are true
-;;; type predicates, accepting any type object.
-;;;
-(define-type-predicate %string-char-p string-char)
-(define-type-predicate %standard-char-p standard-char)
-
-
-;;;; Typep source transform:
-
-;;; Transform-Numeric-Bound-Test  --  Internal
-;;;
-;;;    Return a form that tests the variable N-Object for being in the binds
-;;; specified by Type.  Base is the name of the base type, for declaration.  We
-;;; make safety locally 0 to inhibit any checking of this assertion.
-;;;
-(defun transform-numeric-bound-test (n-object type base)
-  (declare (type numeric-type type))
-  (let ((low (numeric-type-low type))
-	(high (numeric-type-high type)))
-    `(locally
-       (declare (optimize (safety 0)))
-       (and ,@(when low
-		(if (consp low)
-		    `((> (the ,base ,n-object) ,(car low)))
-		    `((>= (the ,base ,n-object) ,low))))
-	    ,@(when high
-		(if (consp high)
-		    `((< (the ,base ,n-object) ,(car high)))
-		    `((<= (the ,base ,n-object) ,high))))))))
-
-
-;;; Source-Transform-Numeric-Typep  --  Internal
-;;;
-;;;    Do source transformation of a test of a known numeric type.  We can
-;;; assume that the type doesn't have a corresponding predicate, since those
-;;; types have already been picked off.  In particular, Class must be
-;;; specified, since it is unspecified only in NUMBER and COMPLEX.  Similarly,
-;;; we assume that Complexp is always specified.
-;;;
-;;;    For non-complex types, we just test that the number belongs to the base
-;;; type, and then test that it is in bounds.  When Class is Integer, we check
-;;; to see if the range is no bigger than FIXNUM.  If so, we check for FIXNUM
-;;; instead of INTEGER.  This allows us to use fixnum comparison to test the
-;;; bounds.
-;;;
-;;;    For complex types, we must test for complex, then do the above on both
-;;; the real and imaginary parts.  When Class is float, we need only check the
-;;; type of the realpart, since the format of the realpart and the imagpart
-;;; must be the same.
-;;;
-(defun source-transform-numeric-typep (object type)
-  (let* ((class (numeric-type-class type))
-	 (low (numeric-type-low type))
-	 (high (numeric-type-high type))
-	 (base (ecase class
-		 (integer
-		  (if (and low (>= low most-negative-fixnum)
-			   high (<= high most-positive-fixnum))
-		      'fixnum
-		      'integer))
-		 (rational 'rational)
-		 (float (or (numeric-type-format type) 'float)))))
-    (once-only ((n-object object))
-      (ecase (numeric-type-complexp type)
-	(:real
-	 `(and (typep ,n-object ',base)
-	       ,(transform-numeric-bound-test n-object type base)))
-	(:complex
-	 `(and (complexp ,n-object)
-	       ,(once-only ((n-real `(realpart (the complex ,n-object)))
-			    (n-imag `(imagpart (the complex ,n-object))))
-		  `(and (typep ,n-real ',base)
-			,@(unless (eq class 'float) `((typep ,n-imag ',base)))
-			,(transform-numeric-bound-test n-real type base)
-			,(transform-numeric-bound-test n-imag type
-						       base)))))))))
-
-
-;;; Source-Transform-Hairy-Typep  --  Internal
-;;;
-;;;    Do the source transformation for a test of a known hairy type.  AND,
-;;; SATISFIES and NOT are converted into the obvious code.  We convert
-;;; anything else to %TYPEP.
-;;;
-(defun source-transform-hairy-typep (object type)
-  (declare (type hairy-type type))
-  (let ((spec (hairy-type-specifier type)))
-    (cond ((or (atom spec)
-	       (not (member (first spec) '(and not satisfies))))
-	   (compiler-warning "Unknown type specifier: ~S." spec)
-	   `(%typep ,object ',spec))
-	  ((and (eq (first spec) 'satisfies) (consp (rest spec)))
-	   `(funcall ',(second spec) ,object))
-	  (t
-	   (once-only ((n-obj object))
-	     `(,(first spec) ,@(mapcar #'(lambda (x) 
-					   `(typep ,n-obj ',x))
-				       (rest spec))))))))
-
-
-;;; Source-Transform-Union-Typep  --  Internal
-;;;
-;;;    Do source transformation for Typep of a known union type.  If a union
-;;; type contains LIST, then we pull that out and make it into a single LISTP
-;;; call.  Note that if SYMBOL is in the union, then LIST will be a subtype
-;;; even without there being any (member NIL).  We just drop through to the
-;;; general code in this case, rather than trying to optimize it.
-;;;
-(defun source-transform-union-typep (object type)
-  (let* ((types (union-type-types type))
-	 (ltype (specifier-type 'list))
-	 (mtype (find-if #'member-type-p types)))
-    (cond ((and mtype (csubtypep ltype type))
-	   (let ((members (member-type-members mtype)))
-	     (once-only ((n-obj object))
-	       `(if (listp ,n-obj)
-		    t
-		    (typep ,n-obj 
-			   '(or ,@(mapcar #'type-specifier
-					  (remove (specifier-type 'cons)
-						  (remove mtype types)))
-				(member ,@(remove nil members))))))))
-	  (t
-	   (once-only ((n-obj object))
-	     `(or ,@(mapcar #'(lambda (x)
-				`(typep ,n-obj ',(type-specifier x)))
-			    types)))))))
-
-
-;;; FIND-SUPERTYPE-PREDICATE  --  Internal
-;;;
-;;;    Return the predicate and type from the most specific entry in
-;;; *TYPE-PREDICATES* that is a supertype of Type.
-;;;
-(defun find-supertype-predicate (type)
-  (declare (type ctype ctype))
-  (let ((res nil)
-	(res-type nil))
-    (dolist (x *type-predicates*)
-      (let ((stype (car x)))
-	(when (and (csubtypep type stype)
-		   (or (not res-type)
-		       (csubtypep stype res-type)))
-	  (setq res-type stype)
-	  (setq res (cdr x)))))
-    (values res res-type)))
-
-
-;;; TEST-ARRAY-DIMENSIONS  --  Internal
-;;;
-;;;    Return forms to test that Obj has the rank and dimensions specified by
-;;; Type, where Stype is the type we have checked against (which is the same
-;;; but for dimensions.)
-;;;
-(defun test-array-dimensions (obj type stype)
-  (declare (type array-type type stype))
-  (let ((obj `(truly-the ,(type-specifier stype) ,obj))
-	(dims (array-type-dimensions type)))
-    (unless (eq dims '*)
-      (collect ((res))
-	(when (eq (array-type-dimensions stype) '*)
-	  (res `(= (array-rank ,obj) ,(length dims))))
-
-	(do ((i 0 (1+ i))
-	     (dim dims (cdr dim)))
-	    ((null dim))
-	  (let ((dim (car dim)))
-	    (unless (eq dim '*)
-	      (res `(= (array-dimension ,obj ,i) ,dim)))))
-	(res)))))
-
-
-;;; SOURCE-TRANSFORM-ARRAY-TYPEP  --  Internal
-;;;
-;;;    If we can find a type predicate that tests for the type w/o dimensions,
-;;; then use that predicate and test for dimensions.  Otherwise, just do
-;;; %TYPEP.
-;;;
-(defun source-transform-array-typep (obj type)
-  (multiple-value-bind (pred stype)
-		       (find-supertype-predicate type)
-    (if (and (array-type-p stype)
-	     (type= (array-type-specialized-element-type stype)
-		    (array-type-specialized-element-type type))
-	     (eq (array-type-complexp stype) (array-type-complexp type)))
-	(once-only ((n-obj obj))
-	  `(and (,pred ,n-obj)
-		,@(test-array-dimensions n-obj type stype)))
-	`(%typep ,obj ',(type-specifier type)))))
-
-
-;;; Source-Transform-Typep  --  Internal
-;;;
-;;;    If the specifier argument is a quoted constant, then we consider
-;;; converting into a simple predicate or other stuff.  If the type is
-;;; constant, but we can't transform the call, then we convert to %Typep.  We
-;;; only pass when the type is non-constant.  This allows us to recognize
-;;; between calls that might later be transformed sucessfully when a constant
-;;; type is discovered.  We don't given an efficiency note when we pass, since
-;;; the IR1 transform will give one if necessary and appropriate.
-;;;
-;;; If the type is Type= to a type that has a predicate, then expand to that
-;;; predicate.  Otherwise, we dispatch off of the type's type.  These
-;;; transformations can increase space, but it is hard to tell when, so we
-;;; ignore policy and always do them.
-;;;
-(def-source-transform typep (object spec)
-  (if (and (consp spec) (eq (car spec) 'quote))
-      (let* ((type (specifier-type (cadr spec)))
-	     (pred (cdr (assoc type *type-predicates* :test #'type=))))
-	(if pred
-	    `(,pred ,object)
-	    (typecase type
-	      (numeric-type
-	       (source-transform-numeric-typep object type))
-	      (hairy-type
-	       (source-transform-hairy-typep object type))
-	      (union-type
-	       (source-transform-union-typep object type))
-	      (member-type
-	       `(member ,object ',(member-type-members type)))
-	      (structure-type
-	       (once-only ((n-obj object))
-		 (structure-predicate n-obj (structure-type-name type))))
-	      (args-type
-	       (compiler-warning "Illegal type specifier for Typep: ~S."
-				 (cadr spec))
-	       `(%typep ,object ,spec))
-	      (array-type
-	       (source-transform-array-typep object type))
-	      (t
-	       `(%typep ,object ,spec)))))
-      (values nil t)))
diff --git a/compiler/vmdef.lisp b/compiler/vmdef.lisp
deleted file mode 100644
index 3dbe5f380850a265dc7d6adfb7d905aff455f753..0000000000000000000000000000000000000000
--- a/compiler/vmdef.lisp
+++ /dev/null
@@ -1,2036 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    This file contains implementation-independent facilities used for
-;;; defining the compiler's interface to the VM in a given implementation.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-;;;
-;;; Translates from SC numbers to SC info structures.  SC numbers are always
-;;; used instead of names at run time, so changing this vector changes all the
-;;; references.
-(defvar *sc-numbers* (make-array sc-number-limit))
-(proclaim '(type sc-vector *sc-numbers*))
-
-;;;
-;;; A list of all the SBs defined, so that we can easily iterate over them.
-(defvar *sb-list* ())
-(proclaim '(type list *sb-list*))
-
-;;;
-;;; Translates from template names to template structures.
-(defvar *template-names* (make-hash-table :test #'eq))
-(proclaim '(type hash-table *template-names*))
-
-;;; Template-Or-Lose  --  Internal
-;;;
-;;;    Return the template having the specified name, or die trying.
-;;;
-(defun template-or-lose (x)
-  (the template
-       (or (gethash x *template-names*)
-	   (error "~S is not a defined template." x))))
-
-
-(eval-when (compile load eval)
-
-;;;
-;;; Hashtable from SC and SB names the corresponding structures.  These tables
-;;; are only used at meta-compile and load times, so the defining macros can
-;;; change these at meta-compile time without breaking the compiler.
-(defvar *sc-names* (make-hash-table :test #'eq))
-(defvar *sb-names* (make-hash-table :test #'eq))
-(proclaim '(hash-table *sc-names* *sb-names*))
-
-;;;
-;;; Like *SC-Numbers*, but is updated at meta-compile time.
-(defvar *meta-sc-numbers* (make-array sc-number-limit))
-(proclaim '(type sc-vector *meta-sc-numbers*))
-
-
-;;; SC-Or-Lose, SB-Or-Lose, SC-Number-Or-Lose  --  Internal
-;;;
-;;;    Return the SC structure, SB structure or SC number corresponding to a
-;;; name, or die trying.  These should not be used after load time, since
-;;; compiling the compiler changes the definitions.
-;;;
-(defun sc-or-lose (x)
-  (the sc
-       (or (gethash x *sc-names*)
-	   (error "~S is not a defined storage class." x))))
-;;;
-(defun sb-or-lose (x)
-  (the sb
-       (or (gethash x *sb-names*)
-	   (error "~S is not a defined storage base." x))))
-;;;
-(defun sc-number-or-lose (x)
-  (the sc-number (sc-number (sc-or-lose x))))
-
-); Eval-When (Compile Load Eval)
-
-
-;;;; Storage class and storage base definition:
-
-;;; Define-Storage-Base  --  Public
-;;;
-;;;    Enter the basic structure at meta-compile time, and then fill in the
-;;; missing slots at load time.
-;;;
-(defmacro define-storage-base (name kind &key size)
-  "Define-Storage-Base Name Kind {Key Value}*
-  Define a storage base having the specified Name.  Kind may be :Finite,
-  :Unbounded or :Non-Packed.  The following keywords are legal:
-
-  :Size <Size>
-      Specify the number of locations in a :Finite SB or the initial size of a
-      :Unbounded SB."
-  (check-type name symbol)
-  (check-type kind (member :finite :unbounded :non-packed))
-  (ecase kind
-    (:non-packed
-     (when size
-       (error "Size specification meaningless in a ~S SB." kind)))
-    ((:finite :unbounded)
-     (unless size (error "Size not specified in a ~S SB." kind))
-     (check-type size unsigned-byte)))
-    
-  (let ((res (if (eq kind :non-packed)
-		 (make-sb :name name :kind kind)
-		 (make-finite-sb :name name :kind kind :size size))))
-    `(progn
-       (eval-when (compile load eval)
-	 (setf (gethash ',name *sb-names*) ',res))
-       ,(if (eq kind :non-packed)
-	    `(setf (gethash ',name *sb-names*) (copy-sb ',res))
-	    `(let ((res (copy-finite-sb ',res)))
-	       (setf (finite-sb-always-live res)
-		     (make-array ',size :initial-element #*))
-	       (setf (finite-sb-conflicts res)
-		     (make-array ',size :initial-element '#()))
-	       (setf (finite-sb-live-tns res)
-		     (make-array ',size :initial-element nil))
-	       (setf (gethash ',name *sb-names*) res)))
-       (setq *sb-list*
-	     (cons (gethash ',name *sb-names*)
-		   (remove ',name *sb-list* :key #'sb-name)))
-       ',name)))
-
-
-;;; Define-Storage-Class  --  Public
-;;;
-;;;
-(defmacro define-storage-class (name number sb-name &key (element-size '1) 
-				     locations)
-  "Define-Storage-Class Name Number Storage-Base {Key Value}*
-  Define a storage class Name that uses the named Storage-Base.  Number is a
-  small, non-negative integer that is used as an alias.  The following
-  keywords are defined:
-
-  :Element-Size <Size>
-      The size of objects in this SC in whatever units the SB uses.  This
-      defaults to 1.
-
-  :Locations
-      If the SB is :Finite, then this is a list of the offsets within the SB
-      that are in this SC."
-  
-  (check-type name symbol)
-  (check-type number sc-number)
-  (check-type sb-name symbol)
-  (check-type locations list)
-
-  (let ((sb (sb-or-lose sb-name)))
-    (if (eq (sb-kind sb) :finite)
-	(let ((size (sb-size sb))
-	      (element-size (eval element-size)))
-	  (check-type element-size unsigned-byte)
-	  (dolist (el locations)
-	    (check-type el unsigned-byte)
-	    (unless (<= 1 (+ el element-size) size)
-	      (error "SC element ~D out of bounds for ~S." el sb))))
-	(when locations
-	  (error ":Locations is meaningless in a ~S SB." (sb-kind sb)))))
-
-  `(progn
-     (eval-when (compile load eval)
-       (setf (gethash ',name *sc-names*) 
-	     (make-sc :name ',name :number ',number
-		      :sb (sb-or-lose ',sb-name)
-		      :element-size ,element-size
-		      :locations ',locations)))
-
-     (eval-when (compile eval)
-       (setf (svref *meta-sc-numbers* ',number)
-	     (gethash ',name *sc-names*)))
-
-     (let ((old (svref *sc-numbers* ',number)))
-       (when (and old (not (eq (sc-name old) ',name)))
-	 (warn "Redefining SC number ~D from ~S to ~S." ',number
-	       (sc-name old) ',name)))
-
-     (setf (svref *sc-numbers* ',number) (sc-or-lose ',name))
-     ',name))
-
-
-;;;; Primitive type definition:
-
-;;; Translates from primitive type names to the corresponding primitive-type
-;;; structure.
-;;;
-(defvar *primitive-type-names* (make-hash-table :test #'eq))
-
-;;; The primitive type T is somewhat magical, in that it is the only primitive
-;;; type that overlaps with other primitive types.  An object of primitive-type
-;;; T is in the canonical descriptor (boxed or pointer) representation.
-;;;
-;;; We stick the T primitive-type in a variable so that people who have to
-;;; special-case it can get at it conveniently.  This is done by the machine
-;;; specific VM definition, since the Def-Primitive-Type for T must specify the
-;;; SCs that boxed objects can be allocated in.
-;;;
-(proclaim '(special *any-primitive-type*))
-(proclaim '(type primitive-type *any-primitive-type*))
-
-
-;;; Def-Primitive-Type  --  Public
-;;;
-;;;    If the primitive-type structure already exists, we destructively modify
-;;; it so that existing references in templates won't be invalidated.
-;;; Primitive-type definition isn't done at meta-compile time, so this doesn't
-;;; break the running compiler.
-;;;
-(defmacro def-primitive-type (name scs &key (type name))
-  "Def-Primitive-Type Name (SC*) {Key Value}*
-  Define a primitive type Name.  Each SC specifies a Storage Class that values
-  of this type may be allocated in.  The following keyword options are defined:
-
-  :Type
-      The type descriptor for the Lisp type that is equivalent to this type
-      (defaults to Name.)"
-  (check-type name symbol)
-  (check-type scs list)
-  (once-only ((n-old `(gethash ',name *primitive-type-names*))
-	      (n-scs `(mapcar #'sc-number-or-lose ',scs))
-	      (n-type `(specifier-type ',type)))
-    `(progn
-       (cond (,n-old
-	      (setf (primitive-type-scs ,n-old) ,n-scs)
-	      (setf (primitive-type-type ,n-old) ,n-type))
-	     (t
-	      (setf (gethash ',name *primitive-type-names*)
-		    (make-primitive-type :name ',name
-					 :scs ,n-scs
-					 :type ,n-type))))
-       ',name)))
-
-
-;;; Primitive-Type-Or-Lose  --  Interface
-;;;
-;;;    Return the primitive type corresponding to the spesicifed name, or die
-;;; trying.
-;;;
-(defun primitive-type-or-lose (name)
-  (the primitive-type
-       (or (gethash name *primitive-type-names*)
-	   (error "~S is not a defined primitive type." name))))
-
-
-;;; Primitive-Subtypep  --  Interface
-;;;
-;;;    Return true if the primitive type Type1 is a subtype of the primitive
-;;; type Type2.  This is only true if the types are identical or if Type2 is T.
-;;;
-(proclaim '(inline primitive-subtypep))
-(defun primitive-subtypep (type1 type2)
-  (declare (type primitive-type type1 type2))
-  (or (eq type1 type2) (eq type2 *any-primitive-type*)))
-
-
-;;; Primitive-Type-Union  --  Interface
-;;;
-;;;    Return the union of two primitive types.
-;;;
-(proclaim '(inline primitive-type-union))
-(defun primitive-type-union (type1 type2)
-  (declare (type primitive-type type1 type2))
-  (if (eq type1 type2)
-      type1
-      *any-primitive-type*))
-
-
-(eval-when (compile load eval)
-  (defparameter primitive-type-slot-alist
-    '((:coerce-to-t . primitive-type-coerce-to-t)
-      (:coerce-from-t . primitive-type-coerce-from-t)
-      (:move . primitive-type-move)
-      (:check . primitive-type-check))))
-
-
-;;; Primitive-Type-Vop  --  Public
-;;;
-(defmacro primitive-type-vop (vop kinds &rest types)
-  "Primitive-Type-VOP Vop (Kind*) Type*
-  Annotate all the specified primitive Types with the named VOP under each of
-  the specified kinds:
-
-  :Coerce-To-T
-  :Coerce-From-T
-  :Move
-      One argument one result VOPs used for coercion between representations
-      and explicit moves.
-
-  :Check
-      A one argument one result VOP that moves the argument to the result,
-      checking that the value is of this type in the process."
-  (let ((n-vop (gensym))
-	(n-type (gensym)))
-    `(let ((,n-vop (template-or-lose ',vop)))
-       ,@(mapcar
-	  #'(lambda (type)
-	      `(let ((,n-type (primitive-type-or-lose ',type)))
-		 ,@(mapcar
-		    #'(lambda (kind)
-			(let ((slot (or (cdr (assoc kind
-						    primitive-type-slot-alist))
-					(error "Unknown kind: ~S." kind))))
-			  `(setf (,slot ,n-type) ,n-vop)))
-		    kinds)))
-	  types)
-       nil)))
-
-
-;;;; Move cost definition:
-
-;;;
-;;; A 2-d array indexed by the source and destination SC number resulting in
-;;; the cost of doing that move.  If a cost for an entry wasn't specified, then
-;;; the entry is null.  This is initalized by a use of Define-Move-Costs in the
-;;; VM definition, and is used by Define-VOP at meta-compile time to fill in
-;;; the costs for SCs not explicitly handled.
-(defvar *move-costs*)
-
-;;; Define-Move-Costs  --  Public
-;;;
-;;;    Build the *move-costs* array, doing some basic consistency checking.
-;;;
-(defmacro define-move-costs (&rest specs)
-  "Define-Move-Costs {((Source-SC*) {(Cost Dest-SC*)}*)}*
-  This macro declares the cost of the implicit move operations needed to load
-  arguments and store results.  The format is somewhat similar to the costs
-  specifications in Define-VOP.  Each argument form gives the cost for moving
-  to all possible destination SCs from some collection of equivalent source
-  SCs.
-
-  This information is used only to compute the cost of moves from arguments to
-  Load TNs or from Load TNs to results.  It is not necessary to specify the
-  costs for moves between combinations of SCs impossible in this context."
-  (let ((res (make-array (list sc-number-limit sc-number-limit)
-			 :initial-element nil)))
-    (dolist (spec specs)
-      (unless (and (every #'listp spec)
-		   (>= (length spec) 2))
-	(error "Malformed move cost specification: ~S." spec))
-
-      (dolist (dest-spec (rest spec))
-	(unless (and (>= (length dest-spec) 2)
-		     (typep (first dest-spec) 'unsigned-byte))
-	  (error "Malformed move destination cost specification: ~S."
-		 dest-spec))
-	(let ((cost (first dest-spec)))
-	  (dolist (dest-sc (rest dest-spec))
-	    (let ((dest-scn (sc-number-or-lose dest-sc)))
-	      (dolist (source-sc (first spec))
-		(setf (aref res (sc-number-or-lose source-sc) dest-scn)
-		      cost)))))))
-
-    `(progn
-       (eval-when (compile load eval)
-	 (setq *move-costs* ',res))
-
-       (dotimes (i sc-number-limit)
-	 (dotimes (j sc-number-limit)
-	   (when (and (aref *move-costs* i j) (not (aref *move-costs* j i))
-		      (not (eq (sb-kind (sc-sb (svref *sc-numbers* i)))
-			       :non-packed)))
-	     (warn "Move possible from SC ~D to ~D, but not vice-versa."
-		   i j)))))))
-
-
-;;; A SC-Vector containing the SCs used for saving each SC, or NIL if the SC
-;;; isn't saved.
-;;;
-(defvar *save-scs* (make-array sc-number-limit :initial-element nil))
-
-;;; Cost vectors describing the costs of saving and restoring TNs in each SC.
-;;; Zero for SCs that aren't saved.
-;;;
-(defvar *save-costs*)
-(defvar *restore-costs*)
-
-;;; Define-Save-SCs  --  Interface
-;;;
-(defmacro define-save-scs (&rest specs)
-  "Define-Save-SCs {(save-sc saved-sc*)}*
-  This form is used to define which SCs must be saved on a function call.  The
-  Saved-SCs are SCs that must be saved.  The Save-SC a SC that is used in
-  combination with the defined move costs to determine the cost of saving."
-  (let ((save-costs (make-array sc-number-limit :initial-element 0))
-	(restore-costs (make-array sc-number-limit :initial-element 0)))
-    (collect ((scs)
-	      (saves))
-      (dolist (spec specs)
-	(let ((save-scn (sc-number-or-lose (first spec))))
-	  (dolist (sc (rest spec))
-	    (let ((saved-scn (sc-number-or-lose sc)))
-	      (when (member saved-scn (scs))
-		(error "SC ~S appears more than once." sc))
-	      (scs saved-scn)
-	      (saves save-scn)
-	      (setf (svref save-costs saved-scn)
-		    (aref *move-costs* saved-scn save-scn))
-	      (setf (svref restore-costs saved-scn)
-		    (aref *move-costs* save-scn saved-scn))))))
-
-      `(progn
-	 ,@(mapcar #'(lambda (scn save)
-		       `(setf (svref *save-scs* ,scn)
-			      (svref *sc-numbers* ,save)))
-		   (scs) (saves))
-	 (setq *save-costs* ',save-costs)
-	 (setq *restore-costs* ',restore-costs)
-	 nil))))
-
-
-;;;; VOP definition structures:
-;;;
-;;;    Define-VOP uses some fairly complex data structures at meta-compile
-;;; time, both to hold the results of parsing the elaborate syntax and to
-;;; retain the information so that it can be inherited by other VOPs.
-
-(eval-when (compile load eval)
-
-;;;
-;;; Hashtable translating from VOP names to the corresponding VOP-Parse
-;;; structures.  This information is only used at meta-compile time.
-(defvar *parsed-vops* (make-hash-table :test #'eq))
-(proclaim '(type hash-table *parsed-vops*))
-
-;;; The VOP-Parse structure holds everything we need to know about a VOP at
-;;; meta-compile time.
-;;;
-(defstruct (vop-parse
-	    (:print-function %print-vop-parse))
-  ;;
-  ;; The name of this VOP.
-  (name nil :type symbol)
-  ;;
-  ;; If true, then the name of the VOP we inherit from.
-  (inherits nil :type (or symbol null))
-  ;;
-  ;; Lists of Operand-Parse structures describing the arguments, results and
-  ;; temporaries of the VOP.
-  (args nil :type list)
-  (results nil :type list)
-  (temps nil :type list)
-  ;;
-  ;; Operand-Parse structures containing information about more args and
-  ;; results.  If null, then there there are no more operands of that kind.
-  (more-args nil :type (or operand-parse null))
-  (more-results nil :type (or operand-parse null))
-  ;;
-  ;; A list of all the above together.
-  (operands nil :type list)
-  ;;
-  ;; Names of variables that should be declared ignore.
-  (ignores () :type list)
-  ;;
-  ;; True if this is a :Conditional VOP.
-  (conditional-p nil)
-  ;;
-  ;; Argument and result primitive types.  These are pulled out of the
-  ;; operands, since we often want to change them without respecifying the
-  ;; operands.
-  (arg-types :unspecified :type (or (member :unspecified) list))
-  (result-types :unspecified :type (or (member :unspecified) list))
-  ;;
-  ;; The guard expression specified, or NIL if none.
-  (guard nil)
-  ;;
-  ;; The cost of and body code for the generator.
-  (cost 0 :type unsigned-byte)
-  (body :unspecified :type (or (member :unspecified) list))
-  ;;
-  ;; Info for VOP variants.  The list of forms to be evaluated to get the
-  ;; variant args for this VOP, and the list of variables to be bound to the
-  ;; variant args.
-  (variant () :type list)
-  (variant-vars () :type list)
-  ;;
-  ;; Variables bound to the VOP and Vop-Node when in the generator body.
-  (vop-var (gensym) :type symbol)
-  (node-var nil :type (or symbol null))
-  ;;
-  ;; A list of the names of the codegen-info arguments to this VOP.
-  (info-args () :type list)
-  ;;
-  ;; An efficiency note associated with this VOP.
-  (note nil :type (or string null))
-  ;;
-  ;; A list of the names of the Effects and Affected attributes for this VOP.
-  (effects '(any) :type list)
-  (affected '(any) :type list)
-  ;;
-  ;; A list of the names of functions this VOP is a translation of and the
-  ;; policy that allows this translation to be done.  :Fast is a safe default,
-  ;; since it isn't a safe policy.
-  (translate () :type list)
-  (policy :fast :type policies)
-  ;;
-  ;; Stuff used by life analysis.
-  (save-p nil :type (member t nil :compute-only :force-to-stack)))
-
-(defprinter vop-parse
-  name
-  (inherits :test inherits)
-  args
-  results
-  temps
-  (more-args :test more-args)
-  (more-results :test more-results)
-  (conditional-p :test conditional-p)
-  ignores
-  arg-types
-  result-types
-  cost
-  body
-  (variant :test variant)
-  (variant-vars :test variant-vars)
-  (info-args :test info-args)
-  (note :test note)
-  effects
-  affected
-  translate
-  policy)
-
-
-;;; The Operand-Parse structure contains stuff we need to know about and
-;;; operand or temporary at meta-compile time.  Besides the obvious stuff, we
-;;; also store the names of per-operand temporaries here.
-;;;
-(defstruct (operand-parse
-	    (:print-function %print-operand-parse))
-  ;;
-  ;; Name of the operand (which we bind to the TN).
-  (name nil :type symbol)
-  ;;
-  ;; The way this operand is used:
-  (kind nil :type (member :argument :result :temporary
-			  :more-argument :more-result))
-  ;;
-  ;; If true, the name of an operand that this operand is targeted to.  This is
-  ;; only meaningful in :Argument and :Temporary operands.
-  (target nil :type (or symbol null))
-  ;;
-  ;; Temporary that holds the TN-Ref for this operand.  Temp-Temp holds the
-  ;; write reference that begins a temporary's lifetime.
-  (temp (gensym) :type symbol)
-  (temp-temp nil :type (or symbol null))
-  ;;
-  ;; The time that this operand is first live and the time at which it becomes
-  ;; dead again.  These are time-specs, as returned by parse-time-spec. 
-  born
-  dies
-  ;;
-  ;; A list of the names of the SCs that this operand is allowed into.  If
-  ;; false, there is no restriction.
-  (scs nil :type list)
-  ;;
-  ;; True if automatic operand loading should be done when the SC restriction
-  ;; isn't met.  Meaningful only in arguments and results.
-  (load t :type boolean)
-  ;;
-  ;; The primitive-type of a temporary.
-  (type t :type symbol)
-  ;;
-  ;; In a wired temporary this is the SC and offset it is wired to.
-  (sc nil :type (or symbol null))
-  (offset nil :type (or unsigned-byte null)))
-
-
-(defprinter operand-parse
-  name
-  kind
-  (type :test (not (eq type t)))
-  (target :test target)
-  born
-  dies
-  (scs :test scs)
-  load
-  (sc :test sc)
-  (offset :test offset))
-
-); Eval-When (Compile Load Eval)
-
-
-;;;; Random utilities:
-
-(eval-when (compile load eval)
-
-;;; Find-Operand  --  Internal
-;;;
-;;;    Find the operand or temporary with the specifed Name in the VOP Parse.
-;;; If there is no such operand, signal an error.  Also error if the operand
-;;; kind isn't one of the specified Kinds.
-;;;
-(defun find-operand (name parse &optional
-			  (kinds '(:argument :result :temporary)))
-  (declare (symbol name) (type vop-parse parse) (list kinds))
-  (let ((found (find name (vop-parse-operands parse)
-		     :key #'operand-parse-name)))
-    (unless found
-      (error "~S is not an operand to ~S." name (vop-parse-name parse)))
-    (unless (member (operand-parse-kind found) kinds)
-      (error "Operand ~S isn't one of these kinds: ~S." name kinds))
-    found))
-
-
-;;; VOP-Parse-Or-Lose  --  Internal
-;;;
-;;;    Get the VOP-Parse structure for Name or die trying.  For all
-;;; meta-compile time uses, the VOP-Parse should be used instead of the
-;;; VOP-Info
-;;;
-(defun vop-parse-or-lose (name)
-  (the vop-parse
-       (or (gethash name *parsed-vops*)
-	   (error "~S is not the name of a defined VOP." name))))
-
-
-;;; Access-Operands  --  Internal
-;;;
-;;;    Return a list of let-forms to parse a tn-ref list into a the temps
-;;; specified by the operand-parse structures.  More-Operand is the
-;;; Operand-Parse describing any more operand, or NIL if none.  Refs is an
-;;; expression that evaluates into the first tn-ref.
-;;;
-(defun access-operands (operands more-operand refs)
-  (declare (list operands))
-  (collect ((res))
-    (let ((prev refs))
-      (dolist (op operands)
-	(let ((n-ref (operand-parse-temp op)))
-	  (res `(,n-ref ,prev))
-	  (setq prev `(tn-ref-across ,n-ref))))
-
-      (when more-operand
-	(res `(,(operand-parse-name more-operand) ,prev))))
-    (res)))
-
-
-;;; Ignore-Unreferenced-Temps --  Internal
-;;;
-;;;    Used with Access-Operands to prevent warnings for TN-Ref temps not used
-;;; by some particular function.  It returns the name of the last operand, or
-;;; NIL if Operands is NIL.
-;;;
-(defun ignore-unreferenced-temps (operands)
-  (when operands
-    (operand-parse-temp (car (last operands)))))
-
-
-;;; VOP-Spec-Arg  --  Internal
-;;;
-;;;    Grab an arg out of a VOP spec, checking the type and syntax and stuff.
-;;;
-(defun vop-spec-arg (spec type &optional (n 1) (last t))
-  (let ((len (length spec)))
-    (when (<= len n)
-      (error "~:R argument missing: ~S." n spec))
-    (when (and last (> len (1+ n)))
-      (error "Extra junk at end of ~S." spec))
-    (let ((thing (elt spec n)))
-      (unless (typep thing type)
-	(error "~:R argument is not a ~S: ~S." n type spec))
-      thing)))
-
-
-;;;; Time specs:
-
-;;; Parse-Time-Spec  --  Internal
-;;;
-;;;    Return a time spec describing a time during the evaluation of a VOP,
-;;; used to delimit operand and temporary lifetimes.  The representation is a
-;;; cons whose CAR is the number of the evaluation phase and the CDR is the
-;;; sub-phase.  The sub-phase is 0 in the :Load and :Save phases. 
-;;;
-(defun parse-time-spec (spec)
-  (let ((dspec (if (atom spec) (list spec 0) spec)))
-    (unless (and (= (length dspec) 2)
-		 (typep (second dspec) 'unsigned-byte))
-      (error "Malformed time specifier: ~S." spec))
-
-    (cons (case (first dspec)
-	    (:load 0)
-	    (:argument 1)
-	    (:eval 2)
-	    (:result 3)
-	    (:save 4)
-	    (t
-	     (error "Unknown phase in time specifier: ~S." spec)))
-	  (second dspec))))
-
-
-;;; Time-Spec-Order  --  Internal
-;;;
-;;;    Return true if the time spec X is the same or later time than Y.
-;;;
-(defun time-spec-order (x y)
-  (or (> (car x) (car y))
-      (and (= (car x) (car y))
-	   (>= (cdr x) (cdr y)))))
- 
-
-;;;; Emit function generation:
-
-;;; Compute-Reference-Order  --  Internal
-;;;
-;;;    Return a list of 2-lists (<Temporary> <More-P>) in reverse reference
-;;; order describing how to build the next-ref linkage for Parse.  If More-P is
-;;; false, then the Temporary points to a single TN-Ref that should be linked
-;;; in.  If More-P is true, then Temporary points to a chain of Tn-Refs linked
-;;; together by Tn-Ref-Across that should be linked in reverse order.
-;;;
-;;;    In implementation, we build a temporary list containing the result
-;;; tuples augmented with reference time and whether the reference is a write.
-;;; We sort this list using Time-Spec-Order augmented by the subsidiary rule
-;;; that when the specs are equal, we do read references first.  This
-;;; implements the desired semantics of open intervals for temporary lifetimes.
-;;;
-(defun compute-reference-order (parse)
-  (declare (type vop-parse parse))
-  (collect ((refs))
-    (dolist (op (vop-parse-operands parse))
-      (let ((born (operand-parse-born op))
-	    (dies (operand-parse-dies op))
-	    (name (operand-parse-name op))
-	    (temp (operand-parse-temp op))
-	    (temp-temp (operand-parse-temp-temp op)))
-	(ecase (operand-parse-kind op)
-	  (:argument
-	   (refs (list (cons dies nil) temp nil)))
-	  (:more-argument
-	   (refs (list (cons dies nil) name t)))
-	  (:result
-	   (refs (list (cons born t) temp nil)))
-	  (:more-result
-	   (refs (list (cons born t) name t)))
-	  (:temporary
-	   (refs (list (cons born t) temp nil))
-	   (refs (list (cons dies nil) temp-temp nil))))))
-
-    (mapcar #'cdr
-	    (sort (refs)
-		  #'(lambda (x y)
-		      (let ((x-time (car x))
-			    (y-time (car y)))
-		      (if (time-spec-order x-time y-time)
-			  (if (time-spec-order y-time x-time)
-			      (or (cdr x) (not (cdr y)))
-			      t)
-			  nil)))
-		  :key #'first))))
-
-
-;;; Make-Next-Ref-Linkage  --  Internal
-;;;
-;;;    Use the operand lifetime annotations to set up the next-ref slots in all
-;;; the TN-Refs used in the VOP.  We set the Refs in the VOP to point to the
-;;; head of this list.  More operands make life a bit interesting, since they
-;;; introduce uncertainty as to whether we have seen any operands yet, and also
-;;; must be linked together contiguously with the other TN-Refs.
-;;;
-(defun make-next-ref-linkage (parse n-vop)
-  (declare (type vop-parse parse))
-  (collect ((forms)
-	    (binds))
-    (let ((first-seen :no)
-	  (prev nil))
-      (dolist (x (compute-reference-order parse))
-	(let* ((var (first x))
-	       (more-p (second x))
-	       (n-tail (if more-p (gensym) var)))
-	  (ecase first-seen
-	    (:no
-	     (forms `(setf (vop-refs ,n-vop) ,n-tail)))
-	    (:yes
-	     (forms `(setf (tn-ref-next-ref ,prev) ,n-tail)))
-	    (:maybe
-	     (forms `(if ,prev
-			 (setf (tn-ref-next-ref ,prev) ,n-tail)
-			 (setf (vop-refs ,n-vop) ,n-tail)))))
-	  
-	  (unless (eq first-seen :yes)
-	    (setq first-seen (if more-p :maybe :yes)))
-	  
-	  (if more-p
-	      (let ((n-current (gensym))
-		    (n-prev (gensym))
-		    (n-head (gensym)))
-		(binds `(,n-head (or ,var ,prev)))
-		(binds
-		 `(,n-tail
-		   (do ((,n-current ,var (tn-ref-across ,n-current))
-			(,n-prev nil ,n-current))
-		       ((null ,n-current) ,n-prev)
-		     (setf (tn-ref-next-ref ,n-current) ,n-prev))))
-		(setq prev n-head))
-	      (setq prev var)))))
-    
-    `((let* ,(binds)
-	,@(forms)))))
-
-
-;;; Make-Temporary  --  Internal
-;;;
-;;;    Return a form that creates a TN as specified by Temp.  This requires
-;;; deciding whether the temp is wired, restricted or normal.
-;;;
-(defun make-temporary (temp)
-  (declare (type operand-parse temp))
-  (let ((type (operand-parse-type temp)))
-    (cond ((operand-parse-sc temp)
-	   `(make-wired-tn (primitive-type-or-lose ',type)
-			   ,(sc-number-or-lose (operand-parse-sc temp))
-			   ,(operand-parse-offset temp)))
-	  ((operand-parse-scs temp)
-	   `(make-restricted-tn (primitive-type-or-lose ',type)
-				',(mapcar #'sc-number-or-lose
-					  (operand-parse-scs temp))))
-	  (t
-	   `(make-normal-tn (primitive-type-or-lose ',type))))))
-
-  
-;;; Allocate-Temporaries  --  Internal
-;;;
-;;;    Allocate VOP temporary TNs, making TN-Refs for their start and end, and
-;;; setting up various per-ref information.  N-Vop is the temporary holding the
-;;; VOP we are emitting.  We return a list of let* binding forms that create
-;;; the TN-Refs, a list of forms that initialize the TN-Refs.
-;;;
-(defun allocate-temporaries (parse n-vop)
-  (declare (type vop-parse parse))
-  (collect ((binds)
-	    (forms))
-    (let ((prev-write nil))
-      (dolist (temp (vop-parse-temps parse))
-	(let ((n-write (operand-parse-temp temp))
-	      (n-read (operand-parse-temp-temp temp))
-	      (n-tn (gensym)))
-	  (binds `(,n-tn ,(make-temporary temp)))
-	  (binds `(,n-write (reference-tn ,n-tn t)))
-	  (binds `(,n-read (reference-tn ,n-tn nil)))
-	  (if prev-write
-	      (forms `(setf (tn-ref-across ,prev-write) ,n-write))
-	      (forms `(setf (vop-temps ,n-vop) ,n-write)))
-	  (setq prev-write n-write)
-	  (forms `(setf (tn-ref-vop ,n-read) ,n-vop))
-	  (forms `(setf (tn-ref-vop ,n-write) ,n-vop)))))
-
-    (values (binds) (forms))))
-
-
-;;; Set-VOP-Pointers  --  Internal
-;;;
-;;;    Return code to set the TN-Ref-Vop slots in some operands to the value of
-;;; N-Vop.  If there is no more operand, set the set the slots individually,
-;;; otherwise loop over the whole list N-Refs.
-;;;
-(defun set-vop-pointers (operands more-operand n-vop n-refs)
-  (if more-operand
-      `((do ((,n-refs ,n-refs (tn-ref-across ,n-refs)))
-	    ((null ,n-refs))
-	  (setf (tn-ref-vop ,n-refs) ,n-vop)))
-      (mapcar #'(lambda (op)
-		  `(setf (tn-ref-vop ,(operand-parse-temp op)) ,n-vop))
-	      operands)))
-
-
-;;; Make-Emit-Function  --  Internal
-;;;
-;;;    Make the Template Emit-Function for a VOP.
-;;;
-(defun make-emit-function (parse)
-  (declare (type vop-parse parse))
-  (let ((n-node (gensym)) (n-block (gensym))
-	(n-template (gensym)) (n-args (gensym))
-	(n-results (gensym)) (n-info (gensym))
-	(n-vop (gensym))
-	(info-args (vop-parse-info-args parse)))
-    (multiple-value-bind (temp-binds temp-forms)
-			 (allocate-temporaries parse n-vop)
-      `#'(lambda (,n-node ,n-block ,n-template ,n-args ,n-results
-			  ,@(when info-args `(,n-info)))
-	   (let ((,n-vop (make-vop ,n-block ,n-node ,n-template
-				   ,n-args ,n-results)))
-
-	     ,@(when info-args
-		 `((setf (vop-codegen-info ,n-vop) ,n-info)))
-	     
-	     (let* (,@(access-operands (vop-parse-args parse)
-				       (vop-parse-more-args parse)
-				       n-args)
-		    ,@(access-operands (vop-parse-results parse)
-				       (vop-parse-more-results parse)
-				       n-results)
-		    ,@temp-binds)
-	       ,@temp-forms
-	       ,@(set-vop-pointers (vop-parse-args parse)
-				   (vop-parse-more-args parse)
-				   n-vop n-args)
-	       ,@(set-vop-pointers (vop-parse-results parse)
-				   (vop-parse-more-results parse)
-				   n-vop n-results)
-	       ,@(make-next-ref-linkage parse n-vop))
-	     (values ,n-vop ,n-vop))))))
-
-
-;;; Make-Target-Function  --  Internal
-;;;
-;;;    Make lambda that does operand targeting as indicated by the
-;;; Operand-Parse-Target slots.  We do some meta-compile-time consistency
-;;; checking, and the emit a call to Target-If-Desirable for each operand
-;;; with a target specified.
-;;;
-;;;    If we are targeting from a temporary, then we indirect through the TN to
-;;; find the read ref.  This exploits the fact that a temp has exactly one
-;;; read.
-;;;
-(defun make-target-function (parse)
-  (collect ((forms))
-    (dolist (op (vop-parse-operands parse))
-      (when (operand-parse-target op)
-	(unless (member (operand-parse-kind op) '(:argument :temporary))
-	  (error "Cannot target a ~S operand: ~S." (operand-parse-kind op)
-		 (operand-parse-name op)))
-	(let ((target (find-operand (operand-parse-target op) parse
-				    '(:temporary :result))))
-	  (forms `(target-if-desirable
-		   ,(ecase (operand-parse-kind op)
-		      (:temporary
-		       `(tn-reads (tn-ref-tn ,(operand-parse-temp op))))
-		      (:argument
-		       (operand-parse-temp op)))
-		   ,(operand-parse-temp target))))))
-
-    (let ((n-vop (gensym)))
-      `#'(lambda (,n-vop)
-	   (let* (,@(access-operands (vop-parse-args parse) nil
-				     `(vop-args ,n-vop))
-		  ,@(access-operands (vop-parse-results parse) nil
-				     `(vop-results ,n-vop))
-		  ,@(access-operands (vop-parse-temps parse) nil
-				     `(vop-temps ,n-vop)))
-	     ,(ignore-unreferenced-temps (vop-parse-args parse))
-	     ,(ignore-unreferenced-temps (vop-parse-results parse))
-	     ,(ignore-unreferenced-temps (vop-parse-temps parse))
-	     ,@(forms))))))
-
-
-;;; Make-Generator-Function  --  Internal
-;;;
-;;;    Make a lambda that parses the VOP TN-Refs, does automatic operand
-;;; loading, and runs the appropriate code generator.
-;;;
-(defun make-generator-function (parse)
-  (declare (type vop-parse parse))
-  (let ((n-vop (vop-parse-vop-var parse))
-	(operands (vop-parse-operands parse))
-	(n-info (gensym)) (n-variant (gensym)))
-    (collect ((binds))
-      (dolist (op operands)
-	(ecase (operand-parse-kind op)
-	  ((:argument :result :temporary)
-	   (binds `(,(operand-parse-name op)
-		    (tn-ref-tn ,(operand-parse-temp op)))))
-	  ((:more-argument :more-result))))
-
-      `#'(lambda (,n-vop)
-	   (let* (,@(access-operands (vop-parse-args parse)
-				     (vop-parse-more-args parse)
-				     `(vop-args ,n-vop))
-		  ,@(access-operands (vop-parse-results parse)
-				     (vop-parse-more-results parse)
-				     `(vop-results ,n-vop))
-		  ,@(access-operands (vop-parse-temps parse) nil
-				     `(vop-temps ,n-vop))
-		  ,@(when (vop-parse-info-args parse)
-		      `((,n-info (vop-codegen-info ,n-vop))
-			,@(mapcar #'(lambda (x) `(,x (pop ,n-info)))
-				  (vop-parse-info-args parse))))
-		  ,@(when (vop-parse-variant-vars parse)
-		      `((,n-variant (vop-info-variant (vop-info ,n-vop)))
-			,@(mapcar #'(lambda (x) `(,x (pop ,n-variant)))
-				  (vop-parse-variant-vars parse))))
-		  ,@(when (vop-parse-node-var parse)
-		      `((,(vop-parse-node-var parse) (vop-node ,n-vop))))
-		  ,@(binds))
-	     (declare (ignore ,@(vop-parse-ignores parse)))
-	     (assemble (vop-node ,n-vop)
-	       ,@(vop-parse-body parse)))))))
-
-
-;;; Parse-Operands  --  Internal
-;;;
-;;;    Given a list of operand specifications as given to Define-VOP, return a
-;;; list of Operand-Parse structures describing the fixed operands, and a
-;;; single Operand-Parse describing any more operand.
-;;;
-(defun parse-operands (specs kind)
-  (declare (list specs)
-	   (type (member :argument :result) kind))
-  (let ((num -1)
-	(more nil))
-    (collect ((operands))
-      (dolist (spec specs)
-	(unless (and (consp spec) (symbolp (first spec)) (oddp (length spec)))
-	  (error "Malformed operand specifier: ~S." spec))
-	(when more
-	  (error "More operand isn't last: ~S." specs)) 
-	(let ((res (ecase kind
-		     (:argument
-		      (make-operand-parse
-		       :name (first spec)  :kind :argument
-		       :born (parse-time-spec :load)
-		       :dies (parse-time-spec `(:argument ,(incf num)))))
-		     (:result
-		      (make-operand-parse
-		       :name (first spec)  :kind :result
-		       :born (parse-time-spec `(:result ,(incf num)))
-		       :dies (parse-time-spec :save))))))
-	  (do ((key (rest spec) (cddr key)))
-	      ((null key))
-	    (let ((value (second key)))
-	      (case (first key)
-		(:scs
-		 (check-type value list)
-		 (setf (operand-parse-scs res) value))
-		(:load
-		 (check-type value boolean)
-		 (setf (operand-parse-load res) value))
-		(:more
-		 (check-type value boolean)
-		 (setf (operand-parse-kind res)
-		       (if (eq kind :argument) :more-argument :more-result))
-		 (setq more res))
-		(:target
-		 (check-type value symbol)
-		 (setf (operand-parse-target res) value))
-		(t
-		 (error "Unknown keyword in operand specifier: ~S." spec)))))
-	  (unless more
-	    (operands res))))
-      (values (the list (operands)) more))))
-
-
-;;; Parse-Temporary  --  Internal
-;;;
-;;;    Parse a temporary specification, entering the Operand-Parse structures in
-;;; the Parse structure.
-;;;
-(defun parse-temporary (spec parse)
-  (declare (list spec)
-	   (type vop-parse parse))
-  (let ((len (length spec)))
-    (unless (>= len 2)
-      (error "Malformed temporary spec: ~S." spec))
-    (dolist (name (cddr spec))
-      (unless (symbolp name)
-	(error "Bad temporary name: ~S." name))
-      (let ((res (make-operand-parse :name name  :kind :temporary
-				     :temp-temp (gensym)
-				     :born (parse-time-spec :load)
-				     :dies (parse-time-spec :save))))
-	(unless (evenp (length (second spec)))
-	  (error "Odd number of argument in keyword options: ~S." spec))
-	(do ((opt (second spec) (cddr opt)))
-	    ((null opt))
-	  (case (first opt)
-	    (:target
-	     (setf (operand-parse-target res)
-		   (vop-spec-arg opt 'symbol 1 nil)))
-	    (:type
-	     (setf (operand-parse-type res)
-		   (vop-spec-arg opt 'symbol 1 nil)))
-	    (:scs
-	     (setf (operand-parse-scs res)
-		   (vop-spec-arg opt 'list 1 nil)))
-	    (:sc
-	     (setf (operand-parse-sc res)
-		   (vop-spec-arg opt 'symbol 1 nil)))
-	    (:offset
-	     (let ((offset (eval (second opt))))
-	       (check-type offset unsigned-byte)
-	       (setf (operand-parse-offset res) offset)))
-	    (:from
-	     (setf (operand-parse-born res) (parse-time-spec (second opt))))
-	    (:to
-	     (setf (operand-parse-dies res) (parse-time-spec (second opt))))
-	    (t
-	     (error "Unknown temporary option: ~S." opt))))
-
-	(unless (and (time-spec-order (operand-parse-dies res)
-				      (operand-parse-born res))
-		     (not (time-spec-order (operand-parse-born res)
-					   (operand-parse-dies res))))
-	  (error "Temporary lifetime doesn't begin before it ends: ~S." spec))
-
-	(when (if (operand-parse-sc res)
-		  (not (operand-parse-offset res))
-		  (operand-parse-offset res))
-	  (error "Must specify both :SC and :Offset or neither: ~S." spec))
-
-	(when (and (operand-parse-sc res)
-		   (operand-parse-scs res))
-	  (error "Cannot specify both :SC and :SCs: ~S." spec))
-
-	(setf (vop-parse-temps parse)
-	      (cons res
-		    (remove name (vop-parse-temps parse)
-			    :key #'operand-parse-name))))))
-  (undefined-value))
-
-
-;;; Parse-Define-VOP  --  Internal
-;;;
-;;;    Top-level parse function.  Clobber Parse to represent the specified
-;;; options.
-;;;
-(defun parse-define-vop (parse specs)
-  (declare (type vop-parse parse) (list specs))
-  (dolist (spec specs)
-    (unless (consp spec)
-      (error "Malformed option specification: ~S." spec))
-    (case (first spec)
-      (:args
-       (multiple-value-bind
-	   (fixed more)
-	   (parse-operands (rest spec) :argument)
-	 (setf (vop-parse-args parse) fixed)
-	 (setf (vop-parse-more-args parse) more)))
-      (:results
-       (multiple-value-bind
-	   (fixed more)
-	   (parse-operands (rest spec) :result)
-	 (setf (vop-parse-results parse) fixed)
-	 (setf (vop-parse-more-results parse) more))
-       (setf (vop-parse-conditional-p parse) nil))
-      (:conditional
-       (setf (vop-parse-result-types parse) ())
-       (setf (vop-parse-results parse) ())
-       (setf (vop-parse-more-results parse) nil)
-       (setf (vop-parse-conditional-p parse) t))
-      (:temporary
-       (parse-temporary spec parse))
-      (:generator
-       (setf (vop-parse-cost parse)
-	     (vop-spec-arg spec 'unsigned-byte 1 nil))
-       (setf (vop-parse-body parse) (cddr spec)))
-      (:effects
-       (setf (vop-parse-effects parse) (rest spec)))
-      (:affected
-       (setf (vop-parse-affected parse) (rest spec)))
-      (:info
-       (setf (vop-parse-info-args parse) (rest spec)))
-      (:ignore
-       (setf (vop-parse-ignores parse) (rest spec)))
-      (:variant
-       (setf (vop-parse-variant parse) (rest spec)))
-      (:variant-vars
-       (let ((vars (rest spec)))
-	 (setf (vop-parse-variant-vars parse) vars)
-	 (setf (vop-parse-variant parse)
-	       (make-list (length vars) :initial-element nil))))
-      (:variant-cost
-       (setf (vop-parse-cost parse) (vop-spec-arg spec 'unsigned-byte)))
-      (:vop-var
-       (setf (vop-parse-vop-var parse) (vop-spec-arg spec 'symbol)))
-      (:node-var
-       (setf (vop-parse-node-var parse) (vop-spec-arg spec 'symbol)))
-      (:note
-       (setf (vop-parse-note parse) (vop-spec-arg spec 'string)))
-      (:arg-types
-       (setf (vop-parse-arg-types parse) (rest spec)))
-      (:result-types
-       (setf (vop-parse-result-types parse) (rest spec)))
-      (:translate
-       (setf (vop-parse-translate parse) (rest spec)))
-      (:guard
-       (setf (vop-parse-guard parse) (vop-spec-arg spec t)))
-      (:policy
-       (setf (vop-parse-policy parse) (vop-spec-arg spec 'policies)))
-      (:save-p
-       (setf (vop-parse-save-p parse)
-	     (vop-spec-arg spec
-			   '(member t nil :compute-only :force-to-stack))))
-      (t
-       (error "Unknown option specifier: ~S." (first spec)))))
-  (undefined-value))
-
-
-;;;; Make costs and restrictions:
-
-(defconstant no-restriction
-  (make-array sc-number-limit  :element-type 'bit  :initial-element 1))
-
-(defconstant no-costs
-  (make-array sc-number-limit  :initial-element 0))
-
-
-;;; Compute-Loading-Costs  --  Internal
-;;;
-;;;    Given a operand, return a costs vector with costs filled in for all SCs
-;;; that we could load from.  When there are multiple SCs we can load into, we
-;;; use the one with the lowest aggregate cost.  Load-P specifies the
-;;; direction: if true, we are loading, if false we are saving.
-;;;
-(defun compute-loading-costs (op load-p)
-  (declare (type operand-parse op))
-  (let ((scs (operand-parse-scs op)))
-    (if scs
-	(let ((res (make-array sc-number-limit :initial-element nil)))
-	  (dolist (sc-name scs)
-	    (let ((load-sc (sc-number-or-lose sc-name)))
-	      (setf (svref res load-sc) 0)
-	      (dotimes (op-sc sc-number-limit)
-		(let ((load (if load-p
-				(aref *move-costs* op-sc load-sc)
-				(aref *move-costs* load-sc op-sc))))
-		  (when load
-		    (let ((op-cost (svref res op-sc)))
-		      (when (or (not op-cost) (< load op-cost))
-			(setf (svref res op-sc) load))))))))
-	    res)
-	no-costs)))
-
-
-;;; Compute-SC-Restrictions  --  Internal
-;;;
-;;;    Return the SC restriction bit-vector for Op.  If there are no
-;;; restrictions, or Load false, then return No-Restriction.
-;;;
-(defun compute-sc-restrictions (op)
-  (declare (type operand-parse op))
-  (let ((scs (operand-parse-scs op)))
-    (if (and scs (operand-parse-load op))
-	(let ((restr (make-array sc-number-limit :element-type 'bit
-				 :initial-element 0)))
-	  (dolist (name scs)
-	    (setf (sbit restr (sc-number-or-lose name)) 1))
-	  restr)
-	no-restriction)))
-
-
-;;; Make-Costs-And-Restrictions  --  Internal
-;;;
-(defun make-costs-and-restrictions (parse)
-  `(
-    :cost ,(vop-parse-cost parse)
-    
-    :arg-costs
-    ',(mapcar #'(lambda (x)
-		  (compute-loading-costs x t))
-	      (vop-parse-args parse))
-    
-    :result-costs
-    ',(mapcar #'(lambda (x)
-		  (compute-loading-costs x nil))
-	      (vop-parse-results parse))
-    
-    :more-arg-costs
-    ',(if (vop-parse-more-args parse)
-	  (compute-loading-costs (vop-parse-more-args parse) t)
-	  nil)
-    
-    :more-result-costs
-    ',(if (vop-parse-more-results parse)
-	  (compute-loading-costs (vop-parse-more-results parse) nil)
-	  nil)
-    
-    :arg-restrictions
-    ',(mapcar #'compute-sc-restrictions (vop-parse-args parse))
-    
-    :result-restrictions
-    ',(mapcar #'compute-sc-restrictions (vop-parse-results parse))))
-
-
-;;;; Operand checking and stuff:
-
-;;; Check-Operand-Types  --  Internal
-;;;
-;;;    If the operand types are specified, then check the number specified
-;;; against the number of defined operands.
-;;;
-;;; [### This would be a good place to check if the operand type is consistent
-;;; with the SC restriction.]
-;;;
-(defun check-operand-types (ops more-op types what)
-  (declare (list ops) (type (or list (member :unspecified)) types)
-	   (type (or operand-parse null) more-op) (string what))
-  (let ((num (+ (length ops) (if more-op 1 0))))
-    (unless (or (eq types :unspecified) (= (length types) num))
-      (error "Expected ~D ~A type~P: ~S." num what types num)))
-  (undefined-value))
-
-
-;;; Grovel-Operands  --  Internal
-;;;
-;;;    Compute stuff that can only be computed after we are done parsing
-;;; everying.  We set the VOP-Parse-Operands, and do various error checks.
-;;;
-(defun grovel-operands (parse)
-  (declare (type vop-parse parse))
-
-  (setf (vop-parse-operands parse)
-	(append (vop-parse-args parse)
-		(if (vop-parse-more-args parse)
-		    (list (vop-parse-more-args parse)))
-		(vop-parse-results parse)
-		(if (vop-parse-more-results parse)
-		    (list (vop-parse-more-results parse)))
-		(vop-parse-temps parse)))
-
-  (check-operand-types (vop-parse-args parse)
-		       (vop-parse-more-args parse)
-		       (vop-parse-arg-types parse)
-		       "argument")
-
-  
-  (check-operand-types (vop-parse-results parse)
-		       (vop-parse-more-results parse)
-		       (vop-parse-result-types parse)
-		       "result")
-
-  (undefined-value))
-
-
-;;;; Function translation stuff:
-
-;;; Adjoin-Template  --  Internal
-;;;
-;;;    Add Template into Info's Templates, removing any old template with the
-;;; same name.
-;;;
-(defun adjoin-template (info template)
-  (declare (type function-info info) (type template template))
-  (setf (function-info-templates info)
-	(sort (cons template
-		    (remove (template-name template)
-			    (function-info-templates info)
-			    :key #'template-name))
-	      #'<=
-	      :key #'template-cost))
-  (undefined-value))
-
-
-;;; Set-Up-Function-Translation  --  Internal
-;;;
-;;;    Return forms to establish this VOP as a IR2 translation template for the
-;;; :Translate functions specified in the VOP-Parse.  We also set the
-;;; Predicate attribute for each translated function when the VOP is
-;;; conditional, causing IR1 conversion to ensure that a call to the translated
-;;; is always used in a predicate position.
-;;;
-(defun set-up-function-translation (parse n-template)
-  (declare (type vop-parse parse))
-  (mapcar #'(lambda (name)
-	      `(let ((info (function-info-or-lose ',name)))
-		 (adjoin-template info ,n-template)
-		 ,@(when (vop-parse-conditional-p parse)
-		     '((setf (function-info-attributes info)
-			     (attributes-union
-			      (ir1-attributes predicate)
-			      (function-info-attributes info)))))))
-	  (vop-parse-translate parse)))
-
-
-;;; Make-Operand-Type  --  Internal
-;;;
-(defun make-operand-type (type)
-  (if (eq type '*)
-      ''*
-      `(primitive-type-or-lose ',type)))
-
-;;; Specify-Operand-Types  --  Internal
-;;;
-(defun specify-operand-types (types ops more-ops)
-  (if (eq types :unspecified)
-      (make-list (+ (length ops) (if more-ops 1 0)) :initial-element t)
-      types))
-
-;;; Make-VOP-Info-Types  --  Internal
-;;;
-;;;    Return a list of forms to use as keyword args to Make-VOP-Info for
-;;; setting up the template argument and result types.  Here we make an initial
-;;; dummy Template-Type, since it is awkward to compute the type until the
-;;; template has been made.
-;;;
-(defun make-vop-info-types (parse)
-  (let* ((more-args (vop-parse-more-args parse))
-	 (all-args (specify-operand-types (vop-parse-arg-types parse)
-					  (vop-parse-args parse)
-					  more-args))
-	 (args (if more-args (butlast all-args) all-args))
-	 (more-arg (when more-args (car (last all-args))))
-	 (more-results (vop-parse-more-results parse))
-	 (all-results (specify-operand-types (vop-parse-result-types parse)
-					     (vop-parse-results parse)
-					     more-results))
-	 (results (if more-results (butlast all-results) all-results))
-	 (more-result (when more-results (car (last all-results))))
-	 (conditional (vop-parse-conditional-p parse)))
-    
-    `(
-      :type (specifier-type '(function () nil))
-      :arg-types (list ,@(mapcar #'make-operand-type args))
-      :more-args-type ,(when more-args (make-operand-type more-arg))
-      :result-types ,(if conditional
-			 :conditional
-			 `(list ,@(mapcar #'make-operand-type results)))
-      :more-results-type ,(when more-results
-			    (make-operand-type more-result)))))
-
-
-
-;;;; Set up VOP-Info:
-
-(defconstant slot-inherit-alist
-  '((:emit-function . vop-info-emit-function)
-    (:generator-function . vop-info-generator-function)
-    (:target-function . vop-info-target-function)))
-
-;;; Inherit-VOP-Info  --  Internal
-;;;
-;;;    Something to help with inheriting VOP-Info slots.  We return a
-;;; keyword/value pair that can be passed to the constructor.  Slot is the
-;;; keyword name of the slot, Parse is a form that evaluates to the VOP-Parse
-;;; structure for the VOP inherited.  If Parse is NIL, then we do nothing.  If
-;;; the Test form evaluates to true, then we return a form that selects the
-;;; named slot from the VOP-Info structure corresponding to Parse.  Otherwise,
-;;; we return the Form so that the slot is recomputed.
-;;;
-(defmacro inherit-vop-info (slot parse test form)
-  `(if (and iparse ,test)
-       (list ,slot `(,',(or (cdr (assoc slot slot-inherit-alist))
-			    (error "Unknown slot ~S." slot))
-		     (template-or-lose ',(vop-parse-name ,parse))))
-       (list ,slot ,form)))
-
-
-;;; Set-Up-VOP-Info  --  Internal
-;;;
-;;;    Return a form that creates a VOP-Info structure which describes VOP.
-;;;
-(defun set-up-vop-info (iparse parse)
-  (declare (type vop-parse parse) (type (or vop-parse null) iparse))
-  (let ((same-operands
-	 (and iparse
-	      (equal (vop-parse-operands parse)
-		     (vop-parse-operands iparse))
-	      (equal (vop-parse-info-args iparse)
-		     (vop-parse-info-args parse))))
-	(variant (vop-parse-variant parse)))
-
-    (let ((nvars (length (vop-parse-variant-vars parse))))
-      (unless (= (length variant) nvars)
-	(error "Expected ~D variant values: ~S." nvars variant)))
-
-    `(make-vop-info
-      :name ',(vop-parse-name parse)
-      ,@(make-vop-info-types parse)
-      :guard ,(when (vop-parse-guard parse)
-		`#'(lambda () ,(vop-parse-guard parse)))
-      :note ',(vop-parse-note parse)
-      :info-arg-count ,(length (vop-parse-info-args parse))
-      :policy ',(vop-parse-policy parse)
-      :save-p ',(vop-parse-save-p parse)
-      :effects (vop-attributes ,@(vop-parse-effects parse))
-      :affected (vop-attributes ,@(vop-parse-affected parse))
-      ,@(make-costs-and-restrictions parse)
-      ,@(inherit-vop-info :emit-function iparse
-	  same-operands
-	  (make-emit-function parse))
-      ,@(inherit-vop-info :generator-function iparse
-	  (and same-operands
-	       (equal (vop-parse-body parse) (vop-parse-body iparse)))
-	  (unless (eq (vop-parse-body parse) :unspecified)
-	    (make-generator-function parse)))
-      ,@(inherit-vop-info :target-function iparse
-	  same-operands
-	  (when (some #'operand-parse-target (vop-parse-operands parse))
-	    (make-target-function parse)))
-      :variant (list ,@variant))))
-
-); Eval-When (Compile Load Eval)
-
-
-;;; Template-Type-Specifier  --  Internal
-;;;
-;;;    Return a function type specifier describing Template's type computed
-;;; from the operand type restrictions.
-;;;
-(defun template-type-specifier (template)
-  (declare (type template template))
-  (flet ((convert (types more-types)
-	   (flet ((frob (x)
-		    (if (eq x '*)
-			't
-			(type-specifier (primitive-type-type x)))))
-	     `(,@(mapcar #'frob types)
-	       ,@(when more-types
-		   `(&rest ,(frob more-types)))))))
-    (let* ((args (convert (template-arg-types template)
-			  (template-more-args-type template)))
-	   (result-restr (template-result-types template))
-	   (results (if (eq result-restr :conditional)
-			'(boolean)
-			(convert result-restr
-				 (cond ((template-more-results-type template))
-				       ((/= (length result-restr) 1) '*)
-				       (t nil))))))
-      `(function ,args
-		 ,(if (= (length results) 1)
-		      (first results)
-		      `(values ,@results))))))
-
-
-;;; Define-VOP  --  Public
-;;;
-;;;    Parse the syntax into a VOP-Parse structure, and then expand into code
-;;; that creates the appropriate VOP-Info structure at load time.  We implement
-;;; inheritance by copying the VOP-Parse structure for the inherited structure.
-;;;
-(defmacro define-vop ((name &optional inherits) &rest specs)
-  "Define-VOP (Name [Inherits]) Spec*
-  Define the symbol Name to be a Virtual OPeration in the compiler.  If
-  specified, Inherits is the name of a VOP that we default unspecified
-  information from.  Each Spec is a list beginning with a keyword indicating
-  the interpretation of the other forms in the Spec:
-  
-  :Args {(Name {Key Value}*)}*
-  :Results {(Name {Key Value}*)}*
-      The Args and Results are specifications of the operand TNs passed to the
-      VOP.  The following operand options are defined:
-
-      :SCs (SC*)
-      :Load T-or-NIL
-	  :SCs specifies good SCs for this operand.  Other SCs will be
-	  penalized according to move costs.  If :Load is true (the default),
-	  then a load TN will be allocated if necessary, guaranteeing that the
-	  operand is always one of the specified SCs.
-
-      :More T-or-NIL
-	  If specified, Name is bound to the TN-Ref for the first argument or
-	  result following the fixed arguments or results.  A more operand must
-	  appear last, and cannot be targeted or restricted.
-
-      :Target Operand
-	  This operand is targeted to the named operand, indicating a desire to
-	  pack in the same location.  Not legal for results.
-  
-  :Conditional
-      This is used in place of :Results with conditional branch VOPs.  There
-      are no result values: the result is a transfer of control.  The
-      consequent and alternative continuations are passed as the first and
-      second :Info arguments.  A side-effect is to set the Predicate attribute
-      for functions in the :Translate option.
-  
-  :Temporary ({Key Value}*) Name*
-      Allocate a temporary TN for each Name, binding that variable to the TN
-      within the body of the generators.  In addition to :Target (which is 
-      is the same as for operands), the following options are
-      defined:
-
-      :Type Type
-          Specify the primitive type for the temporary, default T.
-
-      :SC SC-Name
-      :Offset SB-Offset
-	  Force the temporary to be allocated in the specified SC with the
-	  specified offset.  Offset is evaluated at macroexpand time.
-
-      :SCs (SC*)
-	  Restrict the temporary to a subset of the SCs allowed by the type,
-	  possibly requiring packing in a finite SC.
-
-      :From Time-Spec
-      :To Time-Spec
-	  Specify the beginning and end of the temporary's lives.  The defaults
-	  are :Load and :Save, i.e. the duration of the VOP.  The other
-	  intervening phases are :Argument, :Eval and :Result.  Non-zero
-	  sub-phases can be specified by a list, e.g. the second argument's
-	  life ends at (:Argument 1).
-  
-  :Generator Cost Form*
-      Specifies the translation into assembly code. Cost is the estimated cost
-      of the code emitted by this generator. The body is arbitrary Lisp code
-      that emits the assembly language translation of the VOP.  An Assemble
-      form is wrapped around the body, so code may be emitted by using the
-      local Inst macro.  During the evaluation of the body, the names of the
-      operands and temporaries are bound to the actual TNs.
-  
-  :Effects Effect*
-  :Affected Effect*
-      Specifies the side effects that this VOP has and the side effects that
-      effect its execution.  If unspecified, these default to the worst case.
-  
-  :Info Name*
-      Define some magic arguments that are passed directly to the code
-      generator.  The corresponding trailing arguments to VOP or %Primitive are
-      stored in the VOP structure.  Within the body of the generators, the
-      named variables are bound to these values.  Except in the case of
-      :Conditional VOPs, :Info arguments cannot be specified for VOPS that are
-      the direct translation for a function (specified by :Translate).
-
-  :Ignore Name*
-      Causes the named variables to be declared IGNORE in the generator body.
-
-  :Variant Thing*
-  :Variant-Vars Name*
-      These options provide a way to parameterize families of VOPs that differ
-      only trivially.  :Variant makes the specified evaluated Things be the
-      \"variant\" associated with this VOP.  :Variant-Vars causes the named
-      variables to be bound to the corresponding Things within the body of the
-      generator.
-
-  :Variant-Cost Cost
-      Specifies the cost of this VOP, overriding the cost of any inherited
-      generator.
-
-  :Note String
-      A short noun-like phrase describing what this VOP \"does\", i.e. the
-      implementation strategy.  This is for use in efficiency notes.
-
-  :Arg-Types Type*
-  :Result-Types Type*
-      Specify the template type restrictions used for automatic translation.
-      If there is a :More operand, the last type is the more type. 
-  
-  :Translate Name*
-      This option causes the VOP template to be entered as an IR2 translation
-      for the named functions.
-
-  :Policy {:Small | :Fast | :Safe | :Fast-Safe}
-      Specifies the policy under which this VOP is the best translation.
-
-  :Guard Form
-      Specifies a Form that is evaluated in the global environment.  If
-      form returns NIL, then emission of this VOP is prohibited even when
-      all other restrictions are met.
-
-  :VOP-Var Name
-  :Node-Var Name
-      In the generator, bind the specified variable to the VOP or the Node that
-      generated this VOP.
-
-  :Save-P {NIL | T | :Compute-Only | :Force-To-Stack}
-      Indicates how a VOP wants live registers saved."
-  
-  (check-type name symbol)
-  
-  (let* ((iparse (when inherits
-		   (vop-parse-or-lose inherits)))
-	 (parse (if inherits
-		    (copy-vop-parse iparse)
-		    (make-vop-parse)))
-	 (n-res (gensym)))
-    (setf (vop-parse-name parse) name)
-    (setf (vop-parse-inherits parse) inherits)
-
-    (parse-define-vop parse specs)
-    (grovel-operands parse)
-      
-    `(progn
-       (eval-when (compile load eval)
-	 (setf (gethash ',name *parsed-vops*) ',parse))
-
-       (let ((,n-res ,(set-up-vop-info iparse parse)))
-	 (setf (gethash ',name *template-names*) ,n-res)
-	 (setf (template-type ,n-res)
-	       (specifier-type (template-type-specifier ,n-res)))
-	 ,@(set-up-function-translation parse n-res))
-       ',name)))
-
-
-;;;; Emission macros:
-
-(eval-when (compile load eval)
-
-;;; Make-Operand-List  --  Internal
-;;;
-;;;    Return code to make a list of VOP arguments or results, linked by
-;;; TN-Ref-Across.  The first value is code, the second value is LET* forms,
-;;; and the third value is a variable that evaluates to the head of the list,
-;;; or NIL if there are no operands.  Fixed is a list of forms that evaluate to
-;;; TNs for the fixed operands.  TN-Refs will be made for these operands
-;;; according using the specified value of Write-P.  More is an expression that
-;;; evaluates to a list of TN-Refs that will be made the tail of the list.  If
-;;; it is constant NIL, then we don't bother to set the tail.
-;;;
-(defun make-operand-list (fixed more write-p)
-  (collect ((forms)
-	    (binds))
-    (let ((n-head nil)
-	  (n-prev nil))
-      (dolist (op fixed)
-	(let ((n-ref (gensym)))
-	  (binds `(,n-ref (reference-tn ,op ,write-p)))
-	  (if n-prev
-	      (forms `(setf (tn-ref-across ,n-prev) ,n-ref))
-	    (setq n-head n-ref))
-	  (setq n-prev n-ref)))
-
-      (when more
-	(let ((n-more (gensym)))
-	  (binds `(,n-more ,more))
-	  (if n-prev
-	      (forms `(setf (tn-ref-across ,n-prev) ,n-more))
-	      (setq n-head n-more))))
-
-      (values (forms) (binds) n-head))))
-
-); Eval-When (Compile Load Eval)
-
-
-;;; Emit-Template  -- Interface
-;;;
-(defmacro emit-template (node block template args results &optional info)
-  "Emit-Template Node Block Template Args Results [Info]
-  Call the emit function for Template, linking the result in at the end of
-  Block."
-  (let ((n-first (gensym))
-	(n-last (gensym)))
-    (once-only ((n-node node)
-		(n-block block)
-		(n-template template))
-      `(multiple-value-bind
-	   (,n-first ,n-last)
-	   (funcall (template-emit-function ,n-template)
-		    ,n-node ,n-block ,n-template ,args ,results
-		    ,@(when info `(,info)))
-	 (insert-vop-sequence ,n-first ,n-last ,n-block nil)))))
-
-  
-;;; VOP  --  Interface
-;;;
-(defmacro vop (name node block &rest operands)
-  "VOP Name Node Block Arg* Info* Result*
-  Emit the VOP (or other template) Name at the end of the IR2-Block Block,
-  using Node for the source context.  The interpretation of the remaining
-  arguments depends on the number of operands of various kinds that are
-  declared in the template definition.  VOP cannot be used for templates that
-  have more-args or more-results, since the number of arguments and results is
-  indeterminate for these templates.  Use VOP* instead.
-  
-  Args and Results are the TNs that are to be referenced by the template
-  as arguments and results.  If the template has codegen-info arguments, then
-  the appropriate number of Info forms following the Arguments are used for
-  codegen info."
-  (let* ((parse (vop-parse-or-lose name))
-	 (arg-count (length (vop-parse-args parse)))
-	 (result-count (length (vop-parse-results parse)))
-	 (info-count (length (vop-parse-info-args parse)))
-	 (noperands (+ arg-count result-count info-count))
-	 (n-node (gensym))
-	 (n-block (gensym))
-	 (n-template (gensym)))
-    
-    (when (or (vop-parse-more-args parse) (vop-parse-more-results parse))
-      (error "Cannot use VOP with variable operand count templates."))
-    (unless (= noperands (length operands))
-      (error "Called with ~D operands, but was expecting ~D."
-	     (length operands) noperands))
-    
-    (multiple-value-bind
-	(acode abinds n-args)
-	(make-operand-list (subseq operands 0 arg-count) nil nil)
-      (multiple-value-bind
-	  (rcode rbinds n-results)
-	  (make-operand-list (subseq operands (+ arg-count info-count)) nil t)
-	
-	(collect ((ibinds)
-		  (ivars))
-	  (dolist (info (subseq operands arg-count (+ arg-count info-count)))
-	    (let ((temp (gensym)))
-	      (ibinds `(,temp ,info))
-	      (ivars temp)))
-	  
-	  `(let* ((,n-node ,node)
-		  (,n-block ,block)
-		  (,n-template (template-or-lose ',name))
-		  ,@abinds
-		  ,@(ibinds)
-		  ,@rbinds)
-	     ,@acode
-	     ,@rcode
-	     (emit-template ,n-node ,n-block ,n-template ,n-args
-			    ,n-results 
-			    ,@(when (ivars)
-				`((list ,@(ivars)))))
-	     (undefined-value)))))))
-
-
-;;; VOP*  --  Interface
-;;;
-(defmacro vop* (name node block args results &rest info)
-  "VOP* Name Node Block (Arg* More-Args) (Result* More-Results) Info*
-  Like VOP, but allows for emission of templates with arbitrary numbers of
-  arguments, and for emission of templates using already-created TN-Ref lists.
-
-  The Arguments and Results are TNs to be referenced as the first arguments
-  and results to the template.  More-Args and More-Results are heads of TN-Ref
-  lists that are added onto the end of the TN-Refs for the explicitly supplied
-  operand TNs.  The TN-Refs for the more operands must have the TN and Write-P
-  slots correctly initialized.
-
-  As with VOP, the Info forms are evaluated and passed as codegen info
-  arguments."
-  (check-type args cons)
-  (check-type results cons)
-  (let* ((parse (vop-parse-or-lose name))
-	 (arg-count (length (vop-parse-args parse)))
-	 (result-count (length (vop-parse-results parse)))
-	 (info-count (length (vop-parse-info-args parse)))
-	 (fixed-args (butlast args))
-	 (fixed-results (butlast results))
-	 (n-node (gensym))
-	 (n-block (gensym))
-	 (n-template (gensym)))
-    
-    (unless (or (vop-parse-more-args parse)
-		(<= (length fixed-args) arg-count))
-      (error "Too many fixed arguments."))
-    (unless (or (vop-parse-more-results parse)
-		(<= (length fixed-results) result-count))
-      (error "Too many fixed results."))
-    (unless (= (length info) info-count)
-      (error "Expected ~D info args." info-count))
-    
-    (multiple-value-bind
-	(acode abinds n-args)
-	(make-operand-list fixed-args (car (last args)) nil)
-      (multiple-value-bind
-	  (rcode rbinds n-results)
-	  (make-operand-list fixed-results (car (last results)) t)
-	
-	`(let* ((,n-node ,node)
-		(,n-block ,block)
-		(,n-template (template-or-lose ',name))
-		,@abinds
-		,@rbinds)
-	   ,@acode
-	   ,@rcode
-	   (emit-template ,n-node ,n-block ,n-template ,n-args ,n-results
-			  ,@(when info
-			      `((list ,@info))))
-	   (undefined-value))))))
-
-
-;;;; Random macros:
-
-;;; SC-Case  --  Public
-;;;
-(defmacro sc-case (tn &rest forms)
-  "SC-Case TN {({(SC-Name*) | SC-Name | T} Form*)}*
-  Case off of TN's SC.  The first clause containing TN's SC is evaulated,
-  returning the values of the last form.  A clause beginning with T specifies a
-  default.  If it appears, it must be last.  If no default is specified, and no
-  clause matches, then an error is signalled."
-  (let ((n-sc (gensym))
-	(n-tn (gensym)))
-    (collect ((clauses))
-      (do ((cases forms (rest cases)))
-	  ((null cases)
-	   (clauses `(t (error "Unknown SC to SC-Case for ~S." ,n-tn))))
-	(let ((case (first cases)))
-	  (when (atom case) 
-	    (error "Illegal SC-Case clause: ~S." case))
-	  (let ((head (first case)))
-	    (when (eq head t)
-	      (when (rest cases)
-		(error "T case is not last in SC-Case."))
-	      (clauses `(t nil ,@(rest case)))
-	      (return))
-	    (clauses `((or ,@(mapcar #'(lambda (x)
-					 `(eql ,(sc-number-or-lose x)
-					       ,n-sc))
-				     (if (atom head) (list head) head)))
-		       nil ,@(rest case))))))
-
-      `(let* ((,n-tn ,tn)
-	      (,n-sc (sc-number (tn-sc ,n-tn))))
-	 (cond ,@(clauses))))))
-
-
-;;; SC-Is  --  Interface
-;;;
-(defmacro sc-is (tn &rest scs)
-  "SC-Is TN SC*
-  Returns true if TNs SC is any of the named SCs, false otherwise."
-  (once-only ((n-sc `(sc-number (tn-sc ,tn))))
-    `(or ,@(mapcar #'(lambda (x)
-		       `(eql ,n-sc ,(sc-number-or-lose x)))
-		   scs))))
-
-
-;;; Do-IR2-Blocks  --  Interface
-;;;
-(defmacro do-ir2-blocks ((block-var component &optional result)
-			 &body forms)
-  "Do-IR2-Blocks (Block-Var Component [Result]) Form*
-  Iterate over the IR2 blocks in component, in emission order."
-  `(do ((,block-var (block-info (component-head ,component))
-		    (ir2-block-next ,block-var)))
-       ((null ,block-var) ,result)
-     ,@forms)))
-
-
-;;; DO-LIVE-TNS  --  Interface
-;;;
-(defmacro do-live-tns ((tn-var live block &optional result) &body body)
-  "DO-LIVE-TNS (TN-Var Live Block [Result]) Form*
-  Iterate over all the TNs live at some point, with the live set represented by
-  a local conflicts bit-vector and the IR2-Block containing the location.
-  :More TNs are ignored, but :More TNs never appear in save-sets."
-  (let ((n-conf (gensym))
-	(n-bod (gensym))
-	(i (gensym))
-	(ltns (gensym)))
-    (once-only ((n-live live)
-		(n-block block))
-      `(block nil
-	 (flet ((,n-bod (,tn-var) ,@body))
-	   ;;
-	   ;; Do environment-live TNs.
-	   (dolist (,tn-var (ir2-environment-live-tns
-			     (environment-info
-			      (ir2-block-environment ,n-block))))
-	     (,n-bod ,tn-var))
-	   ;;
-	   ;; Do TNs always-live in this block.
-	   (do ((,n-conf (ir2-block-global-tns ,n-block)
-			 (global-conflicts-next ,n-conf)))
-	       ((null ,n-conf))
-	     (when (eq (global-conflicts-kind ,n-conf) :always-live)
-	       (,n-bod (global-conflicts-tn ,n-conf))))
-	   ;;
-	   ;; Do TNs locally live in the designated live set.
-	   (let ((,ltns (ir2-block-local-tns ,n-block)))
-	     (dotimes (,i (ir2-block-local-tn-count ,n-block) ,result)
-	       (unless (zerop (sbit ,n-live ,i))
-		 (let ((,tn-var (svref ,ltns ,i)))
-		   (when (and ,tn-var (not (eq ,tn-var :more)))
-		     (,n-bod ,tn-var)))))))))))
-
-
-;;; DO-ENVIRONMENT-IR2-BLOCKS  --  Interface
-;;;
-(defmacro do-environment-ir2-blocks ((block-var env &optional result)
-				     &body body)
-  "DO-ENVIRONMENT-IR2-BLOCKS (Block-Var Env [Result]) Form*
-  Iterate over all the IR2 blocks in the environment Env, in emit order."
-  (once-only ((n-env env))
-    (once-only ((n-tail `(block-info
-			  (component-tail
-			   (block-component
-			    (node-block
-			     (lambda-bind (environment-function ,n-env))))))))
-      `(do ((,block-var (block-info (node-block (lambda-bind fun)))
-			(ir2-block-next ,block-var)))
-	   ((or (eq ,block-var ,n-tail)
-		(not (eq (ir2-block-environment ,block-var) ,n-env)))
-	    ,result)
-	 ,@body))))
-
-
-;;; NOTE-THIS-LOCATION  --  Interface
-;;;
-(defmacro note-this-location (vop kind)
-  "NOTE-THIS-LOCATION VOP Kind
-  Node that the current code location is an interesting (to the debugger)
-  location of the specified Kind.  VOP is the VOP responsible for this code.
-  This VOP must specify some non-null :SAVE-P value (perhaps :COMPUTE-ONLY) so
-  that the live set is computed."
-  (once-only ((n-lab '(gen-label)))
-    `(progn
-       (emit-label ,n-lab)
-       (note-debug-location ,vop ,n-lab ,kind))))
-
-
-;;;; Utilities for defining miscops:
-
-(eval-when (compile load eval)
-  
-;;; Miscop-Name  --  Internal
-;;;
-;;;    Return the name for a miscop with the specified args/results.
-;;;
-(defun miscop-name (nargs nresults conditional)
-  (intern (if conditional
-	      (format nil "~:@(~R-ARG-CONDITIONAL-MISCOP~)"
-		      nargs)
-	      (format nil "~:@(~R-ARG~[-NO-VALUE~;~:;-~:*~R-VALUE~]-MISCOP~)"
-		      nargs nresults))
-	  (find-package "C")))
-
-); Eval-When (Compile Load Eval)
-
-
-;;; Define-Miscop-Variants  --  Interface
-;;;
-;;;    Define a bunch of miscops VOPs that inherit the specified VOP and whose
-;;; Template name, Miscop name and translate function are all the same.
-;;; 
-;;; ### We intern the Variant name in the COMPILER package to get around
-;;; bootstrapping package lossage.
-;;;
-(defmacro define-miscop-variants (vop &rest names)
-  (collect ((res))
-    (dolist (name names)
-      (res `(define-vop (,name ,vop)
-	      (:translate ,name)
-	      (:variant ',(intern (symbol-name name)
-				  (find-package "COMPILER"))))))
-    `(progn ,@(res))))
-
-
-;;; Define-Miscop  --  Interface
-;;;
-;;;    Define a miscop with the specified args/results and options.
-;;;
-(defmacro define-miscop (name args &key (results '(r)) translate
-			      policy arg-types result-types
-			      cost conditional)
-  `(define-vop (,name ,(miscop-name (length args) (length results)
-				    conditional))
-     (:variant ',(intern (symbol-name name)
-			 (find-package "COMPILER")))
-     ,@(when arg-types
-	 `((:arg-types ,@arg-types)))
-     ,@(when result-types
-	 `((:result-types ,@result-types)))
-     ,@(when policy
-	 `((:policy ,policy)))
-     ,@(when cost
-	 `((:variant-cost ,cost)))
-     ,@(when translate
-	 `((:translate ,translate)))))
diff --git a/compiler/vop.lisp b/compiler/vop.lisp
deleted file mode 100644
index bf937881e0970680a19b395ebf38e289e420b7f5..0000000000000000000000000000000000000000
--- a/compiler/vop.lisp
+++ /dev/null
@@ -1,1030 +0,0 @@
-;;; -*- Package: C; Log: C.Log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;;    Structures for the second (virtual machine) intermediate representation
-;;; in the compiler, IR2.
-;;;
-;;; Written by Rob MacLachlan
-;;;
-(in-package 'c)
-
-(proclaim '(special *sc-numbers*))
-
-(eval-when (compile load eval)
-
-;;;
-;;; The largest number of TNs whose liveness changes that we can have in any
-;;; block.
-(defconstant local-tn-limit 64)
-
-(deftype local-tn-number () `(integer 0 (,local-tn-limit)))
-(deftype local-tn-count () `(integer 0 ,local-tn-limit)) 
-(deftype local-tn-vector () `(simple-vector ,local-tn-limit))
-(deftype local-tn-bit-vector () `(simple-bit-vector ,local-tn-limit))
-
-;;; Type of an SC number.
-(deftype sc-number () `(integer 0 (,sc-number-limit)))
-
-;;; Types for vectors indexed by SC numbers.
-(deftype sc-vector () `(simple-vector ,sc-number-limit))
-(deftype sc-bit-vector () `(simple-bit-vector ,sc-number-limit))
-
-;;; The different policies we can use to determine the coding strategy.
-;;;
-(deftype policies ()
-  '(member :safe :small :fast :fast-safe))
-
-); Eval-When (Compile Load Eval)
-
-
-;;;; Primitive types:
-;;;
-;;;    The primitive type is used to represent the aspects of type interesting
-;;; to the VM.  Selection of IR2 translation templates is done on the basis of
-;;; the primitive types of the operands, and the primitive type of a value
-;;; is used to constrain the possible representations of that value.
-;;;
-(defstruct (primitive-type (:print-function %print-primitive-type))
-  ;;
-  ;; The name of this primitive-type.
-  (name nil :type symbol)
-  ;;
-  ;; A list the SC numbers for all the SCs that a TN of this type can be
-  ;; allocated in.
-  (scs nil :type list)
-  ;;
-  ;; The Lisp type equivalent to this type.  If this type could never be
-  ;; returned by Primitive-Type, then this is the NIL (or empty) type.
-  (type nil :type ctype)
-  ;;
-  ;; These slots tell how to do implicit representation conversions and moves.
-  ;; If null, then the operation can be done using the standard Move
-  ;; VOP, otherwise the value is a template that is emitted to do the move or
-  ;; coercion.
-  ;;
-  ;; Coerce-To-T and Coerce-From-T convert objects of this type to and from the
-  ;; default descriptor (boxed) representation.  The Move slot is used to
-  ;; determine whether a special move operation is needed to do moves between
-  ;; TNs of this primitive type.  Since primitive types are disjoint except for
-  ;; their overlap with T, these are all the coercions that we need.
-  (coerce-to-t nil :type (or template null))
-  (coerce-from-t nil :type (or template null))
-  (move nil :type (or template null))
-  ;;
-  ;; The template used to check that an object is of this type.  This is
-  ;; a template of one argument and one result, both of primitive-type T.  If
-  ;; the argument is of the correct type, then it is delivered into the result.
-  ;; If the type is incorrect, then an error is signalled.
-  (check nil :type (or template null)))
-
-(defprinter primitive-type
-  name
-  (type :test (not (eq (type-specifier type)
-		       (primitive-type-name structure)))
-	:prin1 (type-specifier type)))
-
-
-;;;; IR1 annotations used for IR2 conversion:
-;;;
-;;; Block-Info
-;;;    Holds the IR2-Block structure.  If there are overflow blocks, then this
-;;;    points to the first IR2-Block.  The Block-Info of the dummy component
-;;;    head and tail are dummy IR2 blocks that begin and end the emission order
-;;;    thread.
-;;;
-;;; Component-Info
-;;;    Holds the IR2-Component structure.
-;;;
-;;; Continuation-Info
-;;;    Holds the IR2-Continuation structure.  Continuations whose values aren't
-;;;    used won't have any.
-;;;
-;;; Cleanup-Info
-;;;    If non-null, then a TN in which the affected dynamic environment pointer
-;;;    should be saved after the binding is instantiated.
-;;;
-;;; Environment-Info
-;;;    Holds the IR2-Environment structure.
-;;;
-;;; Tail-Set-Info
-;;;    Holds the Return-Info structure.
-;;;
-;;; NLX-Info-Info
-;;;    Holds the IR2-NLX-Info structure.
-;;;
-;;; Leaf-Info
-;;;    If a non-set lexical variable, the TN that holds the value in the home
-;;;    environment.  If a constant, then the corresponding constant TN.
-;;;    If an XEP lambda, then the corresponding Entry-Info structure.
-;;;
-;;; Basic-Combination-Info
-;;;    The Template chosen for this call by LTN, null if the call has an
-;;;    IR2-Convert method, or if it isn't special-cased at all.
-;;;    
-
-;;; The IR2-Block structure holds information about a block that is used during
-;;; and after IR2 conversion.  It is stored in the Block-Info slot for the
-;;; associated block.
-;;;
-(defstruct (ir2-block
-	    (:constructor make-ir2-block (block))
-	    (:print-function %print-ir2-block))
-  ;;
-  ;; The IR2-Block's number, which differs from Block's Block-Number if any
-  ;; blocks are split.  This is assigned by lifetime analysis.
-  (number nil :type (or unsigned-byte null))
-  ;;
-  ;; The IR1 block that this block is in the Info for.  
-  (block nil :type cblock)
-  ;;
-  ;; The next and previous block in emission order (not DFO).  This determines
-  ;; which block we drop though to, and also used to chain together overflow
-  ;; blocks that result from splitting of IR2 blocks in lifetime analysis.
-  (next nil :type (or ir2-block null))
-  (prev nil :type (or ir2-block null))
-  ;;
-  ;; A thread running through all IR2 blocks in this environment, in no
-  ;; particular order.
-  (environment-next nil :type (or ir2-block null))
-  ;;
-  ;; Information about unknown-values continuations that is used by stack
-  ;; analysis to do stack simulation.  A unknown-values continuation is Pushed
-  ;; if it's Dest is in another block.  Similarly, a continuation is Popped if
-  ;; its Dest is in this block but has its uses elsewhere.  The continuations
-  ;; are in the order that are pushed/popped in the block.  Note that the args
-  ;; to a single MV-Combination appear reversed in Popped, since we must
-  ;; effectively pop the last argument first.  All pops must come before all
-  ;; pushes (although internal MV uses may be interleaved.)  Popped is computed
-  ;; by LTN, and Pushed is computed by stack analysis.
-  (pushed () :type list)
-  (popped () :type list)
-  ;;
-  ;; The result of stack analysis: lists of all the unknown-values
-  ;; continuations on the stack at the block start and end, topmost
-  ;; continuation first.
-  (start-stack () :type list)
-  (end-stack () :type list)
-  ;;
-  ;; The first and last VOP in this block.  If there are none, both slots are
-  ;; null.
-  (start-vop nil (or vop null))
-  (last-vop nil (or vop null))
-  ;;
-  ;; Number of local TNs actually allocated.
-  (local-tn-count 0 :type local-tn-count)
-  ;;
-  ;; A vector that maps local TN numbers to TNs.  Some entries may be NIL,
-  ;; indicating that that number is unused.  (This allows us to delete local
-  ;; conflict information without compressing the LTN numbers.)
-  ;;
-  ;; If an entry is :More, then this block contains only a single VOP.  This
-  ;; VOP has so many more arguments and/or results that they cannot all be
-  ;; assigned distinct LTN numbers.  In this case, we assign all the more args
-  ;; one LTN number, and all the more results another LTN number.  We can do
-  ;; this, since more operands are referenced simultaneously as far as conflict
-  ;; analysis is concerned.  Note that all these :More TNs will be global TNs.
-  (local-tns (make-array local-tn-limit) :type local-tn-vector)
-  ;;
-  ;; Bit-vectors used during lifetime analysis to keep track of references to
-  ;; local TNs.  When indexed by the LTN number, the index for a TN is non-zero
-  ;; in Written if it is ever written in the block, and in Live-Out if
-  ;; the first reference is a read.
-  (written (make-array local-tn-limit :element-type 'bit
-		       :initial-element 0)
-	   :type local-tn-bit-vector)
-  (live-out (make-array local-tn-limit :element-type 'bit)
-	    :type local-tn-bit-vector)
-  ;;
-  ;; Similar to the above, but is updated by lifetime flow analysis to have a 1
-  ;; for LTN numbers of TNs live at the end of the block.  This takes into
-  ;; account all TNs that aren't :Live.
-  (live-in (make-array local-tn-limit :element-type 'bit
-		       :initial-element 0)
-	   :type local-tn-bit-vector)
-  ;;
-  ;; A thread running through the global-conflicts structures for this block,
-  ;; sorted by TN number.
-  (global-tns nil :type (or global-conflicts null))
-  ;;
-  ;; The assembler label that points to the beginning of the code for this
-  ;; block.  Null when we haven't assigned a label yet.
-  (%label nil)
-  ;;
-  ;; List of Location-Info structures describing all the interesting (to the
-  ;; debugger) locations in this block.
-  (locations nil :type list))
-
-
-(defprinter ir2-block
-  (pushed :test pushed)
-  (popped :test popped)
-  (start-vop :test start-vop)
-  (last-vop :test last-vop)
-  (local-tn-count :test (not (zerop local-tn-count)))
-  (%label :test %label))
-
-
-;;; The IR2-Continuation structure is used to annotate continuations that are
-;;; used as a function result continuation or that receive MVs.
-;;;
-(defstruct (ir2-continuation
-	    (:constructor make-ir2-continuation (primitive-type))
-	    (:print-function %print-ir2-continuation))
-  ;;
-  ;; If this is :Delayed, then this is a single value continuation for which
-  ;; the evaluation of the use is to be postponed until the evaluation of
-  ;; destination.  This can be done for ref nodes or predicates whose
-  ;; destination is an IF.
-  ;;
-  ;; If this is :Fixed, then this continuation has a fixed number of values,
-  ;; with the TNs in Locs.
-  ;;
-  ;; If this is :Unknown, then this is an unknown-values continuation, using
-  ;; the passing locations in Locs.
-  ;;
-  ;; If this is :Unused, then this continuation should never actually be used
-  ;; as the destination of a value: it is only used tail-recursively.
-  (kind :fixed :type (member :delayed :fixed :unknown :unused))
-  ;;
-  ;; The primitive-type of the first value of this continuation.  This is
-  ;; primarily for internal use during LTN, but it also records the type
-  ;; restriction on delayed references.  In multiple-value contexts, this is
-  ;; null to indicate that it is meaningless.
-  (primitive-type nil :type (or primitive-type null))
-  ;;
-  ;; Locations used to hold the values of the continuation.  If the number
-  ;; of values if fixed, then there is one TN per value.  If the number of
-  ;; values is unknown, then this is a two-list of TNs holding the start of the
-  ;; values glob and the number of values.
-  (locs nil :type list))
-
-(defprinter ir2-continuation
-  kind
-  primitive-type
-  locs)
-
-
-;;; The IR2-Component serves mostly to accumulate non-code information about
-;;; the component being compiled.
-;;;;
-(defstruct ir2-component
-  ;;
-  ;; The counter used to allocate global TN numbers.
-  (global-tn-counter 0 :type unsigned-byte)
-  ;;
-  ;; Normal-TNs is the head of the list of all the normal TNs that need to be
-  ;; packed, linked through the Next slot.  We place TNs on this list when we
-  ;; allocate them so that Pack can find them.
-  ;;
-  ;; Restricted-TNs are TNs that must be packed within a finite SC.  We pack
-  ;; these TNs first to ensure that the restrictions will be satisfied (if
-  ;; possible).
-  ;;
-  ;; Wired-TNs are TNs that must be packed at a specific location.  The SC
-  ;; and Offset are already filled in.
-  ;;
-  ;; Constant-TNs are non-packed TNs that represent constants.  :Constant TNs
-  ;; may eventually be converted to :Cached-Constant normal TNs.
-  (normal-tns nil :type (or tn null))
-  (restricted-tns nil :type (or tn null))
-  (wired-tns nil :type (or tn null))
-  (constant-tns nil :type (or tn null))
-  ;;
-  ;; A list of all the pre-packed save TNs, so that they can have their
-  ;; lifetime info fixed up by conflicts analysis.
-  (pre-packed-save-tns nil :type list)
-  ;;
-  ;; Values-Generators is a list of all the blocks whose ir2-block has a
-  ;; non-null value for Popped.  Values-Generators is a list of all blocks that
-  ;; contain a use of a continuation that is in some block's Popped.  These
-  ;; slots are initialized by LTN-Analyze as an input to Stack-Analyze. 
-  (values-receivers nil :type list)
-  (values-generators nil :type list)
-  ;;
-  ;; A list of all the Exit nodes for non-local exits.
-  (exits nil :type list)
-  ;;
-  ;; An adjustable vector that records all the constants in the constant pool.
-  ;; A non-immediate :Constant TN with offset 0 refers to the constant in
-  ;; element 0, etc.  Normal constants are represented by the placing the
-  ;; Constant leaf in this vector.  A load-time constant is distinguished by
-  ;; being a cons (Kind . What).  Kind is a keyword indicating how the constant
-  ;; is computed, and What is some context.
-  ;; 
-  ;; These load-time constants are recognized:
-  ;; 
-  ;; (:entry . <function>)
-  ;;    Is replaced by the code pointer for the specified function.  This is
-  ;; 	how compiled code (including DEFUN) gets its hands on a function.
-  ;; 	<function> is the XEP lambda for the called function; it's Leaf-Info
-  ;; 	should be an Entry-Info structure.
-  ;;
-  ;; (:label . <label>)
-  ;;    Is replaced with the byte offset of that label from the start of the
-  ;;    code vector (including the header length.)
-  ;;
-  ;; A null entry in this vector is a placeholder for implementation overhead
-  ;; that is eventually stuffed in somehow.
-  ;;
-  (constants (make-array 10 :fill-pointer 0 :adjustable t) :type vector)
-  ;;
-  ;; Some kind of info about the component's run-time representation.  This is
-  ;; filled in by the VM supplied Select-Component-Format function.
-  format
-  ;;
-  ;; A list of the Entry-Info structures describing all of the entries into
-  ;; this component.  Filled in by entry analysis.
-  (entries nil :type list))
-
-
-;;; The Entry-Info structure condenses all the information that the dumper
-;;; needs to create each XEP's function entry data structure.
-;;;
-(defstruct entry-info
-  ;;
-  ;; True if this function has a non-null closure environment.
-  (closure-p nil :type boolean)
-  ;;
-  ;; A label pointing to the entry vector for this function.
-  (offset nil :type label)
-  ;;
-  ;; If this function was defined using DEFUN, then this is the name of the
-  ;; function, a symbol or (SETF <symbol>).  Otherwise, this is some string
-  ;; that is intended to be informative.
-  (name nil :type (or simple-string list symbol))
-  ;;
-  ;; A string representing the argument list that the function was defined
-  ;; with.
-  (arguments nil :type simple-string)
-  ;;
-  ;; A function type specifier representing the arguments and results of this
-  ;; function.
-  (type nil :type list))
-
-
-;;; The IR2-Environment is used to annotate non-let lambdas with their passing
-;;; locations.  It is stored in the Environment-Info.
-;;;
-(defstruct (ir2-environment
-	    (:print-function %print-ir2-environment))
-  ;;
-  ;; A list of the argument passing TNs.  The explict arguments are first,
-  ;; followed by the implict environment arguments.  In an XEP, there are no
-  ;; arg TNs corresponding to any environment TNs, since the environment is
-  ;; accessed from the closure.
-  (arg-locs nil :type list)
-  ;;
-  ;; The TNs that hold the passed environment within the function.  This is an
-  ;; alist translating from the NLX-Info or lambda-var to the TN that holds
-  ;; the corresponding value within this function.  This list is in the same
-  ;; order as the ENVIRONMENT-CLOSURE and environment passing locations in the
-  ;; ARG-LOCS.
-  (environment nil :type list)
-  ;;
-  ;; The TNs that hold the Old-Cont and Return-PC within the function.  We
-  ;; always save these so that the debugger can do a backtrace, even if the
-  ;; function has no return (and thus never uses them).  Null only temporarily.
-  (old-cont nil :type (or tn null))
-  (return-pc nil :type (or tn null))
-  ;;
-  ;; The passing locations for Old-Cont and Return-PC.
-  (old-cont-pass nil :type tn)
-  (return-pc-pass nil :type tn)
-  ;;
-  ;; The passing location for the pointer to any stack arguments.
-  (argument-pointer nil :type tn)
-  ;;
-  ;; A list of all the :Environment TNs live in this environment.
-  (live-tns nil :type list)
-  ;;
-  ;; A list of all the keep-around TNs live in this environment.
-  (keep-around-tns nil :type list)
-  ;;
-  ;; A list of all the IR2-Blocks in this environment, threaded by
-  ;; IR2-Block-Environment-Next.  This is filled in by control analysis.
-  (blocks nil :type (or ir2-block null)))
-
-
-(defprinter ir2-environment
-  arg-locs
-  environment
-  old-cont
-  old-cont-pass
-  return-pc
-  return-pc-pass
-  argument-pointer)
-
-
-;;; The Return-Info structure is used by GTN to represent the return strategy
-;;; and locations for all the functions in a given Tail-Set.  It is stored in
-;;; the Tail-Set-Info.
-;;;
-(defstruct (return-info
-	    (:print-function %print-return-info))
-  ;;
-  ;; The return convention used:
-  ;; -- If :Unknown, we use the standard return convention.
-  ;; -- If :Fixed, we use the known-values convention.
-  (kind nil :type (member :fixed :unknown))
-  ;;
-  ;; The number of values returned, or :Unknown if we don't know.  Count may be
-  ;; known when Kind is :Unknown, since we may choose the standard return
-  ;; convention for other reasons.
-  (count nil :type (or unsigned-byte (member :unknown)))
-  ;;
-  ;; If count isn't :Unknown, then this is a list of the primitive-types of
-  ;; each value.
-  (types () :type list)
-  ;;
-  ;; If kind is :Fixed, then this is the list of the TNs that we return the
-  ;; values in. 
-  (locations () :type list))
-
-
-(defprinter return-info
-  kind
-  count
-  types
-  locations)
-
-
-(defstruct (ir2-nlx-info (:print-function %print-ir2-nlx-info))
-  ;;
-  ;; If the kind is :Entry (a lexical exit), then in the home environment, this
-  ;; holds a Value-Cell object containing the unwind block pointer.  In the
-  ;; other cases nobody directly references the unwind-block, so we leave this
-  ;; slot null.
-  (home nil :type (or tn null))
-  ;;
-  ;; The saved control stack pointer.
-  (save-sp nil :type tn)
-  ;;
-  ;; The list of dynamic state save TNs.
-  (dynamic-state (make-dynamic-state-tns) :type list))
-
-
-(defprinter ir2-nlx-info
-  home
-  save-sp
-  dynamic-state)
-
-
-#|
-;;; The Loop structure holds information about a loop.
-;;;
-(defstruct (cloop (:print-function %print-loop)
-		  (:conc-name loop-)
-		  (:predicate loop-p)
-		  (:constructor make-loop)
-		  (:copier copy-loop))
-  ;;
-  ;; The kind of loop that this is.  These values are legal:
-  ;;
-  ;;    :Outer
-  ;;        This is the outermost loop structure, and represents all the
-  ;;        code in a component.
-  ;;
-  ;;    :Natural
-  ;;        A normal loop with only one entry.
-  ;;
-  ;;    :Strange
-  ;;        A segment of a "strange loop" in a non-reducible flow graph.
-  ;;
-  (kind nil :type (member :outer :natural :strange))
-  ;;
-  ;; The first and last blocks in the loop.  There may be more than one tail,
-  ;; since there may be multiple back branches to the same head.
-  (head nil :type (or cblock null))
-  (tail nil :type list)
-  ;;
-  ;; A list of all the blocks in this loop or its inferiors that have a
-  ;; successor outside of the loop.
-  (exits nil :type list)
-  ;;
-  ;; The loop that this loop is nested within.  This is null in the outermost
-  ;; loop structure.
-  (superior nil :type (or cloop null))
-  ;;
-  ;; A list of the loops nested directly within this one.
-  (inferiors nil :type list)
-  ;;
-  ;; The head of the list of blocks directly within this loop.  We must recurse
-  ;; on Inferiors to find all the blocks.
-  (blocks nil :type (or null cblock)))
-
-(defprinter loop
-  kind
-  head
-  tail
-  exits)
-|#
-
-
-;;;; VOPs and Templates:
-
-;;; A VOP is a Virtual Operation.  It represents an operation and the operands
-;;; to the operation.
-;;;
-(defstruct (vop (:print-function %print-vop)
-		(:constructor make-vop (block node info args results)))
-  ;;
-  ;; VOP-Info structure containing static info about the operation.
-  (info nil :type (or vop-info null))
-  ;;
-  ;; The IR2-Block this VOP is in.
-  (block nil :type ir2-block)
-  ;;
-  ;; VOPs evaluated after and before this one.  Null at the beginning/end of
-  ;; the block, and temporarily during IR2 translation.
-  (next nil :type (or vop null))
-  (prev nil :type (or vop null))
-  ;;
-  ;; Heads of the TN-Ref lists for operand TNs, linked using the Across slot.
-  (args nil :type (or tn-ref null))  
-  (results nil :type (or tn-ref null))
-  ;;
-  ;; Head of the list of write refs for each explicitly allocated temporary,
-  ;; linked together using the Across slot.
-  (temps nil :type (or tn-ref null))
-  ;;
-  ;; Head of the list of all TN-refs for references in this VOP, linked by the
-  ;; Next-Ref slot.  There will be one entry for each operand and two (a read
-  ;; and a write) for each temporary.
-  (refs nil :type (or tn-ref null))
-  ;;
-  ;; Stuff that is passed uninterpreted from IR2 conversion to codegen.  The
-  ;; meaning of this slot is totally dependent on the VOP.
-  codegen-info
-  ;;
-  ;; Node that generated this VOP, for keeping track of debug info.
-  (node nil :type (or node null))
-  ;;
-  ;; Local-TN bit vector representing the set of TNs live after args are read
-  ;; and before results are written.  This is only filled in when
-  ;; VOP-INFO-SAVE-P is non-null.
-  (save-set nil :type (or local-tn-bit-vector null)))
-
-(defprinter vop
-  (info :prin1 (vop-info-name info))
-  args
-  results
-  (codegen-info :test codegen-info))
-
-
-;;; The TN-Ref structure contains information about a particular reference to a
-;;; TN.  The information in the TN-Refs largely determines how TNs are packed.
-;;; 
-(defstruct (tn-ref (:print-function %print-tn-ref)
-		   (:constructor make-tn-ref (tn write-p)))
-  ;;
-  ;; The TN referenced.
-  (tn nil :type tn)
-  ;;
-  ;; True if this is a write reference, false if a read.
-  (write-p nil :type boolean)
-  ;;
-  ;; Thread running through all TN-Refs for this TN of the same kind (read or
-  ;; write).
-  (next nil :type (or tn-ref null))
-  ;;
-  ;; The VOP where the reference happens.  The this is null only temporarily.
-  (vop nil :type (or vop null))
-  ;;
-  ;; Thread running through all TN-Refs in VOP, in reverse order of reference.
-  (next-ref nil :type (or tn-ref null))
-  ;;
-  ;; Thread the TN-Refs in VOP of the same kind (argument, result, temp).
-  (across nil :type (or tn-ref null))
-  ;;
-  ;; If true, this is a TN-Ref also in VOP whose TN we would like packed in the
-  ;; same location as our TN.  Read and write refs are always paired: Target in
-  ;; the read points to the write, and vice-versa.
-  (target nil :type (or null tn-ref)))
-
-(defprinter tn-ref
-  tn
-  write-p
-  (vop :test vop :prin1 (vop-info-name (vop-info vop))))
-
-
-;;; The Template represents a particular IR2 coding strategy for a known
-;;; function.
-;;;
-(defstruct (template
-	    (:print-function %print-template))
-  ;;
-  ;; The symbol name of this VOP.  This is used when printing the VOP and is
-  ;; also used to provide a handle for definition and translation.
-  (name nil :type symbol)
-  ;;
-  ;; A Function-Type describing the arg/result type restrictions.  We compute
-  ;; this from the Primitive-Type restrictions to make life easier for IR1
-  ;; phases that need to anticipate LTN's template selection.
-  (type nil :type function-type)
-  ;;
-  ;; Lists of the primitive types for the fixed arguments and results.  A list
-  ;; element may be *, indicating no restriction on that particular argument or
-  ;; result.
-  ;;
-  ;; If Result-Types is :Conditional, then this is an IF-xxx style conditional
-  ;; that yeilds its result as a control transfer.  The emit function takes some
-  ;; kind of additional arguments describing where to go to in the true and
-  ;; false cases.
-  (arg-types nil :type list)
-  (result-types nil :type (or list (member :conditional)))
-  ;;
-  ;; The primitive type restriction applied to each extra argument or result
-  ;; following the fixed operands.  If *, then there is no restriction.  If
-  ;; null, then extra operands are not allowed.
-  (more-args-type nil :type (or (member nil *) primitive-type))
-  (more-results-type nil :type (or (member nil *) primitive-type))
-  ;;
-  ;; If true, this is a function that is called with no arguments to see if
-  ;; this template can be emitted.  This is used to conditionally compile for
-  ;; different target hardware configuarations (e.g. FP hardware.)
-  (guard nil :type (or function null))
-  ;;
-  ;; The policy under which this template is the best translation.  Note that
-  ;; LTN might use this template under other policies if it can't figure our
-  ;; anything better to do.
-  (policy nil :type policies)
-  ;;
-  ;; The base cost for this template, given optimistic assumptions such as no
-  ;; operand loading, etc.
-  (cost nil :type unsigned-byte)
-  ;;
-  ;; If true, then a short noun-like phrase describing what this VOP "does",
-  ;; i.e. the implementation strategy.  This is for use in efficiency notes.
-  (note nil :type (or string null))
-  ;;
-  ;; The number of trailing arguments to VOP or %Primitive that we bundle into
-  ;; a list and pass into the emit function.  This provides a way to pass
-  ;; uninterpreted stuff directly to the code generator.
-  (info-arg-count 0 :type unsigned-byte)
-  ;;
-  ;; A function that emits the VOPs for this template.  Arguments:
-  ;;  1] Node for source context.
-  ;;  2] IR2-Block that we place the VOP in.
-  ;;  3] This structure.
-  ;;  4] Head of argument TN-Ref list.
-  ;;  5] Head of result TN-Ref list.
-  ;;  6] If Info-Arg-Count is non-zero, then a list of the magic arguments.
-  ;;
-  ;; Two values are returned: the first and last VOP emitted.  This vop
-  ;; sequence must be linked into the VOP Next/Prev chain for the block.  At
-  ;; least one VOP is always emitted.
-  (emit-function nil :type function))
-
-(defprinter template
-  name
-  (arg-types :prin1 (mapcar #'primitive-type-name arg-types))
-  (result-types :prin1 (if (listp result-types)
-			   (mapcar #'primitive-type-name result-types)
-			   result-types))
-  (more-args-type :test more-args-type
-		  :prin1 (primitive-type-name more-args-type))
-  (more-results-type :test more-results-type
-		     :prin1 (primitive-type-name more-results-type))
-  policy
-  cost
-  (note :test note)
-  (info-arg-count :test (not (zerop info-arg-count))))
-
-
-;;; The VOP-Info structure holds the constant information for a given virtual
-;;; operation.  We include Template so functions with a direct VOP equivalent
-;;; can be translated easily.
-;;;
-(defstruct (vop-info
-	    (:include template)
-	    (:print-function %print-template))
-  ;;
-  ;; Side-effects of this VOP and side-effects that affect the value of this
-  ;; VOP.
-  (effects nil :type attributes)
-  (affected nil :type attributes)
-  ;;
-  ;; If true, causes special casing of TNs live after this VOP that aren't
-  ;; results:
-  ;; -- If T, all such TNs that are allocated in a SC with a defined save-sc
-  ;;    will be saved in a TN in the save SC before the VOP and restored after
-  ;;    the VOP.  This is used by call VOPs.  The list of TNs live TNs is
-  ;;    stored in the first codegen info argument, which must exist (with a
-  ;;    dummy value.)
-  ;; -- If :Force-To-Stack, all such TNs will made into :Environment TNs and
-  ;;    forced to be allocated in SCs without any save-sc.  This is used by NLX
-  ;;    entry vops.
-  ;;
-  (save-p nil :type (member t nil :force-to-stack))
-  ;;
-  ;; A list of sc-vectors representing the loading costs of each fixed argument
-  ;; and result.
-  (arg-costs nil :type list)
-  (result-costs nil :type list)
-  ;;
-  ;; If true, sc-vectors representing the loading costs for any more args and
-  ;; results.
-  (more-arg-costs nil :type (or sc-vector null))
-  (more-result-costs nil :type (or sc-vector null))
-  ;;
-  ;; Lists of sc-bit-vectors representing the SC restrictions on each fixed
-  ;; argument and result.
-  (arg-restrictions nil :type list)
-  (result-restrictions nil :type list)
-  ;;
-  ;; If true, a function that is called with the VOP to do operand targeting.
-  ;; This is done by modifiying the TN-Ref-Target slots in the TN-Refs so that
-  ;; they point to other TN-Refs in the same VOP.
-  (target-function nil :type (or null function))
-  ;;
-  ;; A function that emits assembly code for a use of this VOP when it is
-  ;; called with the VOP structure.  Null if this VOP has no specified
-  ;; generator (i.e. it exists only to be inherited by other VOPs.)
-  (generator-function nil :type (or function null))
-  ;;
-  ;; A list of things that are used to parameterize an inherited generator.
-  ;; This allows the same generator function to be used for a group of VOPs
-  ;; with similar implementations.
-  (variant nil :type list))
-
-
-;;;; SBs and SCs:
-
-(eval-when (#-new-compiler compile load eval)
-
-;;; The SB structure represents the global information associated with a
-;;; storage base.
-;;;
-(defstruct (sb (:print-function %print-sb))
-  ;;
-  ;; Name, for printing and reference.
-  (name nil :type symbol)
-  ;;
-  ;; The kind of storage base (which determines the packing algorithm).
-  (kind :non-packed :type (member :finite :unbounded :non-packed))
-  ;;
-  ;; The number of elements in the SB.  If finite, this is the total size.  If
-  ;; unbounded, this is the size that the SB is initially allocated at.
-  (size 0 :type unsigned-byte))
-
-(defprinter sb
-  name)
-
-
-;;; The Finite-SB structure holds information needed by the packing algorithm
-;;; for finite SBs.
-;;;
-(defstruct (finite-sb (:include sb)
-		      (:print-function %print-sb))
-  ;;
-  ;;
-  ;; The number of locations currently allocated in this SB.
-  (current-size 0 :type unsigned-byte)
-  ;;
-  ;; The last location packed in, used by pack to scatter TNs to prevent a few
-  ;; locations from getting all the TNs, and thus getting overcrowded, reducing
-  ;; the possiblilities for targeting.
-  (last-offset 0 :type unsigned-byte)
-  ;;
-  ;; A vector containing, for each location in this SB, a vector indexed by IR2
-  ;; block numbers, holding local conflict bit vectors.  A TN must not be
-  ;; packed in a given location within a particular block if the LTN number for
-  ;; that TN in that block corresponds to a set bit in the bit-vector.
-  (conflicts '#() :type simple-vector)
-  ;;
-  ;; A vector containing, for each location in this SB, a bit-vector indexed by
-  ;; IR2 block numbers.  If the bit corresponding to a block is set, then the
-  ;; location is in use somewhere in the block, and thus has a conflict for
-  ;; always-live TNs.
-  (always-live '#() :type simple-vector)
-  ;;
-  ;; A vector containing the TN currently live in each location in the SB, or
-  ;; NIL if the location is unused.  This is used during load-tn pack.
-  (live-tns '#() :type simple-vector))
-
-
-;;; the SC structure holds the storage base that storage is allocated in and
-;;; information used to select locations within the SB.
-;;;
-(defstruct (sc (:print-function %print-sc))
-  ;;
-  ;; Name, for printing and reference.
-  (name nil :type symbol)
-  ;;
-  ;; The number used to index SC cost vectors.
-  (number 0 :type sc-number)
-  ;;
-  ;; The storage base that this SC allocates storage from.
-  (sb nil :type (or sb null))
-  ;;
-  ;; The size of elements in this SC, in units of locations in the SB.
-  (element-size 0 :type unsigned-byte)
-  ;;
-  ;; If our SB is finite, a list of the locations in this SC.
-  (locations nil :type list))
-
-(defprinter sc
-  name)
-
-); eval-when (compile load eval)
-  
-
-;;;; TNs:
-
-(eval-when (#-new-compiler compile load eval)
-
-(defstruct (tn (:include sset-element)
-	       (:constructor make-random-tn)
-	       (:constructor make-tn (number kind primitive-type sc))
-	       (:print-function %print-tn))
-  ;;
-  ;; The kind of TN this is:
-  ;;
-  ;;   :Normal
-  ;;        A normal, non-constant TN, representing a variable or temporary.
-  ;;        Lifetime information is computed so that packing can be done.
-  ;;
-  ;;   :Environment
-  ;;        A TN that has hidden references (debugger or NLX), and thus must be
-  ;;        allocated for the duration of the environment it is referenced in.
-  ;;        All references must be in the environment that was specified to
-  ;;        Make-Environment-TN.  Conflicts are represented specially.  These
-  ;;        TNs never appear in the IR2-Block-XXX-TNs.  Environment TNs never
-  ;;        have Local or Local-Number.
-  ;;
-  ;;   :Save
-  ;;   :Save-Once
-  ;;        A TN used for saving a :Normal TN across function calls.  The
-  ;;        lifetime information slots are unitialized: get the original TN our
-  ;;        of the SAVE-TN slot and use it for conflicts. Save-Once is like
-  ;;        :Save, except that it is only save once at the single writer of the
-  ;;        original TN.
-  ;;
-  ;;   :Load
-  ;;        A load-TN used to compute an argument or result that is restricted
-  ;;        to some finite SB.  Load TNs don't have any conflict information.
-  ;;        Load TN pack uses a special local conflict determination method.
-  ;;
-  ;;   :Constant
-  ;;        Represents a constant, with TN-Leaf a Constant leaf.  Lifetime
-  ;;        information isn't computed, since the value isn't allocated by
-  ;;        pack, but is instead generated as a load at each use.  Since
-  ;;        lifetime analysis isn't done on :Constant TNs, they don't have 
-  ;;        Local-Numbers and similar stuff.
-  ;;
-  ;;   :Cached-Constant
-  ;;        Represents a constant for which caching in a register would be
-  ;;        desirable.  Lifetime information is computed so that the cached
-  ;;        copies can be allocated.
-  ;;
-  (kind nil :type (member :normal :environment :save :save-once :load :constant
-			  :cached-constant))
-  ;;
-  ;; The primitive-type for this TN's value.  Since the allocation costs for
-  ;; VOP temporaries are explicitly specified, this slot is null in such TNs.
-  (primitive-type nil :type (or primitive-type null))
-  ;;
-  ;; If this TN represents a variable or constant, then this is the
-  ;; corresponding Leaf.
-  (leaf nil :type (or leaf null))
-  ;;
-  ;; Thread that links TNs together so that we can find them.
-  (next nil :type (or tn null))
-  ;;
-  ;; Head of TN-Ref lists for reads and writes of this TN.
-  (reads nil :type (or tn-ref null))
-  (writes nil :type (or tn-ref null))
-  ;;
-  ;; A link we use when building various temporary TN lists.
-  (next* nil :type (or tn null))
-  ;;
-  ;; Some block that contains a reference to this TN, or Nil if we haven't seen
-  ;; any reference yet.  If the TN is local, then this is the block it is local
-  ;; to.
-  (local nil :type (or ir2-block null))
-  ;;
-  ;; If a local TN, the block relative number for this TN.  Global TNs whose
-  ;; liveness changes within a block are also assigned a local number during
-  ;; the conflicts analysis of that block.  If the TN has no local number
-  ;; within the block, then this is Nil.
-  (local-number nil :type (or local-tn-number null))
-  ;;
-  ;; If a local TN, a bit-vector with 1 for the local-number of every TN that
-  ;; we conflict with.
-  (local-conflicts (make-array local-tn-limit :element-type 'bit
-			       :initial-element 0)
-		   :type local-tn-bit-vector)
-  ;;
-  ;; Head of the list of Global-Conflicts structures for a global TN.  This
-  ;; list is sorted by block number (i.e. reverse DFO), allowing the
-  ;; intersection between the lifetimes for two global TNs to be easily found.
-  ;; If null, then this TN is a local TN.
-  (global-conflicts nil :type (or global-conflicts null))
-  ;;
-  ;; During lifetime analysis, this is used as a pointer into the conflicts
-  ;; chain, for scanning through blocks in reverse DFO.
-  (current-conflict nil)
-  ;;
-  ;; In a :Save TN, this is the TN saved.  In a :Normal TN, this is the
-  ;; associated save TN.  In TNs with no save TN, this is null.
-  (save-tn nil :type (or tn null))
-  ;;
-  ;; This is a vector indexed by SC numbers with the cost for packing in that
-  ;; SC.  If an entry for an SC is null, then it is not possible to pack in
-  ;; that SC, either because it is illegal or because the SC is full.
-  (costs (make-array sc-number-limit :initial-element nil)
-	 :type sc-vector)
-  ;;
-  ;; The SC packed into, or NIL if not packed.
-  (sc nil :type (or sc null))
-  ;;
-  ;; The offset within the SB that this TN is packed into.  This is what
-  ;; indicates that the TN is packed.
-  (offset nil :type (or unsigned-byte null)))
-
-); Eval-When (Compile Load Eval)
-
-(defun %print-tn (s stream d)
-  (declare (ignore d))
-  (write-string "#<TN " stream)
-  (print-tn s stream)
-  (write-char #\> stream))
-
-#|
-(defprinter tn
-  (number :test (/= number 0) :prin1 (tn-id structure))
-  kind
-  (primitive-type :test primitive-type
-		  :prin1 (primitive-type-name primitive-type))
-  (leaf :test leaf)
-  (sc :test sc :prin1 (sc-name sc))
-  (offset :test offset))
-|#
-
-;;; The Global-Conflicts structure represents the conflicts for global TNs.
-;;; Each global TN has a list of these structures, one for each block that it
-;;; is live in.  In addition to repsenting the result of lifetime analysis, the
-;;; global conflicts structure is used during lifetime analysis to represent
-;;; the set of TNs live at the start of the IR2 block.
-;;;
-(defstruct (global-conflicts
-	    (:constructor make-global-conflicts (kind tn block number))
-	    (:print-function %print-global-conflicts))
-
-  ;;
-  ;; The IR2-Block that this structure represents the conflicts for.
-  (block nil :type ir2-block)
-  ;;
-  ;; Thread running through all the Global-Conflict for Block.  This
-  ;; thread is sorted by TN number.
-  (next nil :type (or global-conflicts null))
-  ;;
-  ;; The way that TN is used by Block:
-  ;;
-  ;;    :Read
-  ;;        The TN is read before it is written.  It starts the block live, but
-  ;;        is written within the block.
-  ;;
-  ;;    :Write
-  ;;        The TN is written before any read.  It starts the block dead, and
-  ;;        need not have a read within the block.
-  ;;
-  ;;    :Read-Only
-  ;;        The TN is read, but never written.  It starts the block live, and
-  ;;        is not killed by the block.  Lifetime analysis will promote
-  ;;        :Read-Only TNs to :Live if they are live at the block end.
-  ;;
-  ;;    :Live
-  ;;        The TN is not referenced.  It is live everywhere in the block.
-  ;;
-  (kind :read-only :type (member :read :write :read-only :live))
-  ;;
-  ;; A local conflicts vector representing conflicts with TNs live in Block.
-  ;; The index for the local TN number of each TN we conflict with in this
-  ;; block is 1.  To find the full conflict set, the :Live TNs for Block must
-  ;; also be included.  This slot is not meaningful when Kind is :Live. 
-  (conflicts (make-array local-tn-limit
-			 :element-type 'bit
-			 :initial-element 0)
-	     :type local-tn-bit-vector)
-  ;;
-  ;; The TN we are recording conflicts for.
-  (tn nil :type tn)
-  ;;
-  ;; Thread through all the Global-Conflicts for TN.
-  (tn-next nil :type (or global-conflicts null))
-  ;;
-  ;; TN's local TN number in Block.  :Live TNs don't have local numbers. 
-  (number nil :type (or local-tn-number null)))
-
-(defprinter global-conflicts
-  tn
-  block
-  kind
-  (number :test number))
diff --git a/hemlock/rcs.lisp b/hemlock/rcs.lisp
deleted file mode 100644
index 67db62d192b39ac9ba57e7ba84f5d8654e272ab0..0000000000000000000000000000000000000000
--- a/hemlock/rcs.lisp
+++ /dev/null
@@ -1,488 +0,0 @@
-;;; -*- Package: HEMLOCK; Mode: Lisp -*-
-;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/rcs.lisp,v 1.14 1990/03/03 01:24:42 ch Exp $
-;;;
-;;; Various commands for dealing with RCS under Hemlock.
-;;; 
-(in-package "HEMLOCK")
-
-
-;;;;
-
-(defhvar "RCS Check Out Keep Original As Backup"
-  "If non-NIL, all comamnds which perform an RCS check out will rename
-  any existing original file to a backup filename."
-  :value nil)
-
-(defun current-buffer-pathname ()
-  (let ((pathname (buffer-pathname (current-buffer))))
-    (unless pathname
-      (editor-error "The buffer has no pathname."))
-    pathname))
-
-
-(defmacro in-directory (directory &body forms)
-  (let ((cwd (gensym)))
-    `(let ((,cwd (ext:default-directory)))
-       (unwind-protect
-	   (progn
-	     (setf (ext:default-directory) (directory-namestring ,directory))
-	     ,@forms)
-	 (setf (ext:default-directory) ,cwd)))))
-
-
-(defvar *error-stream* (make-string-output-stream))
-
-(defmacro do-command (&rest args)
-  (let ((proc (gensym)))
-    `(progn
-       (get-output-stream-string *error-stream*)
-       (let ((,proc (ext:run-program ,@args :error *error-stream*)))
-	 (case (ext:process-status ,proc)
-	   (:exited
-	    (unless (zerop (ext:process-exit-code ,proc))
-	      (editor-error "~A" (get-output-stream-string *error-stream*))))
-	   (:signaled
-	    (editor-error "~A killed with signal ~A ~@[core dumped]"
-			  ',(car args)
-			  (ext:process-exit-code ,proc)
-			  (ext:process-core-dumped ,proc)))
-	   (t
-	    (editor-error "~S still alive?" ,proc)))))))
-
-(defun buffer-different-from-file (buffer filename)
-  (with-open-file (file filename)
-    (do ((buffer-line (mark-line (buffer-start-mark buffer))
-		      (line-next buffer-line))
-	 (file-line (read-line file nil nil)
-		    (read-line file nil nil)))
-	((and (or (null buffer-line)
-		  (zerop (line-length buffer-line)))
-	      (null file-line))
-	 nil)
-      (when (or (null buffer-line)
-		(null file-line)
-		(string/= (line-string buffer-line) file-line))
-	(return t)))))
-
-(defun turn-auto-save-off (buffer)
-  (setf (buffer-minor-mode buffer "Save") nil)
-  ;;
-  ;; William's personal hack
-  (when (getstring "Ckp" *mode-names*)
-    (setf (buffer-minor-mode buffer "Ckp") nil)))
-
-
-(defhvar "RCS Lock File Hook"
-  "RCS Lock File Hook"
-  :value nil)
-
-(defun rcs-lock-file (buffer pathname)
-  (message "Locking ~A ..." (namestring pathname))
-  (in-directory pathname
-    (let ((file (file-namestring pathname)))
-      (do-command "rcs" `("-l" ,file))
-      (multiple-value-bind (won dev ino mode) (mach:unix-stat file)
-	(declare (ignore ino))
-	(cond (won
-	       (mach:unix-chmod file (logior mode mach:writeown)))
-	      (t
-	       (editor-error "MACH:UNIX-STAT lost in RCS-LOCK-FILE: ~A"
-			     (mach:get-unix-error-msg dev)))))))
-  (invoke-hook rcs-lock-file-hook buffer pathname))
-
-
-(defhvar "RCS Unlock File Hook"
-  "RCS Unlock File Hook"
-  :value nil)
-
-(defun rcs-unlock-file (buffer pathname)
-  (message "Unlocking ~A ..." (namestring pathname))
-  (in-directory pathname
-    (do-command "rcs" `("-u" ,(file-namestring pathname))))
-  (invoke-hook rcs-unlock-file-hook buffer pathname))
-
-
-;;;; Check In
-
-(defhvar "RCS Check In File Hook"
-  "RCS Check In File Hook"
-  :value nil)
-
-(defun rcs-check-in-file (buffer pathname keep-lock)
-  (let ((old-buffer (current-buffer))
-	(allow-delete nil)
-	(log-buffer nil))
-    (unwind-protect
-	(when (block in-recursive-edit
-		(do ((i 0 (1+ i)))
-		    ((not (null log-buffer)))
-		  (setf log-buffer
-			(make-buffer
-			 (format nil "RCS Log Entry ~D for ~S" i
-				 (file-namestring pathname))
-			 :modes '("Text")
-			 :delete-hook
-			 (list #'(lambda (buffer)
-				   (declare (ignore buffer))
-				   (unless allow-delete
-				     (return-from in-recursive-edit t)))))))
-		(turn-auto-save-off log-buffer)
-		(change-to-buffer log-buffer)
-		(do-recursive-edit)
-	  
-		(message "Checking in ~A~:[~; keeping the lock~] ..."
-			 (namestring pathname) keep-lock)
-		(let ((log-stream (make-hemlock-region-stream
-				   (buffer-region log-buffer))))
-		  (sub-check-in-file pathname keep-lock log-stream))
-		(invoke-hook rcs-check-in-file-hook buffer pathname)
-		nil)
-	  (editor-error "Someone deleted the RCS Log Entry buffer."))
-      (change-to-buffer old-buffer)
-      (setf allow-delete t)
-      (delete-buffer-if-possible log-buffer))))
-
-(defun sub-check-in-file (pathname keep-lock log-stream)
-  (let* ((filename (file-namestring pathname))
-	 (rcs-filename (concatenate 'simple-string
-				    "./RCS/" filename ",v")))
-    (in-directory pathname
-      (do-command "rcsci" `(,@(if keep-lock '("-l"))
-			      "-u"
-			      ,filename)
-		  :input log-stream)
-      ;; 
-      ;; Set the times on the user's file to be equivalent to that of
-      ;; the rcs file.
-      (multiple-value-bind
-	  (dev ino mode nlink uid gid rdev size atime mtime)
-	  (mach:unix-stat rcs-filename)
-	(declare (ignore mode nlink uid gid rdev size))
-	(cond (dev
-	       (multiple-value-bind
-		   (wonp errno)
-		   (mach:unix-utimes filename (list atime 0 mtime 0))
-		 (unless wonp
-		   (editor-error "MACH:UNIX-UTIMES failed: ~A"
-				 (mach:get-unix-error-msg errno)))))
-	      (t
-	       (editor-error "MACH:UNIX-STAT failed: ~A"
-			     (mach:get-unix-error-msg ino))))))))
-
-
-;;;; Check Out
-
-(defhvar "RCS Check Out File Hook"
-  "RCS Check Out File Hook"
-  :value nil)
-
-(defun maybe-rcs-check-out-file (buffer pathname lock always-overwrite-p)
-  (sub-maybe-rcs-check-out-files buffer (list pathname)
-				 lock always-overwrite-p))
-
-(defun maybe-rcs-check-out-files (pathnames lock always-overwrite-p)
-  (sub-maybe-rcs-check-out-files nil pathnames lock always-overwrite-p))
-
-(defun sub-maybe-rcs-check-out-files (buffer pathnames lock always-overwrite-p)
-  (let ((check-out-count 0))
-    (macrolet ((frob ()
-		 `(progn
-		    (rcs-check-out-file buffer pathname lock)
-		    (incf check-out-count))))
-      (dolist (pathname pathnames)
-	(cond
-	 ((and (not always-overwrite-p)
-	       (probe-file pathname) (ext:file-writable pathname))
-	  ;; File exists and is writable so check and see if the user really
-	  ;; wants to check it out.
-	  (command-case (:prompt
-			 (format nil "The file ~A is writable.  Overwrite? "
-				 (file-namestring pathname))
-			 :help
-			 "Type one of the following single-character commands:")
-	    ((:yes :confirm)
-	     "Overwrite the file."
-	     (frob))
-	    (:no
-	     "Skip checking out this file.")
-	    ((#\r #\R)
-	     "Rename the file before checking it out."
-	     (let ((new-pathname (prompt-for-file
-				  :prompt "New Filename: "
-				  :default (buffer-default-pathname
-					      (current-buffer))
-				  :must-exist nil)))
-	       (rename-file pathname new-pathname)
-	       (frob)))
-	    (:do-all
-	     "Overwrite this file and all remaining files."
-	     (setf always-overwrite-p t)
-	     (frob))
-	    (:do-once
-	     "Overwrite this file and then exit."
-	     (frob)
-	     (return))))
-	 (t
-	  (frob)))))
-    check-out-count))
-
-(defun rcs-check-out-file (buffer pathname lock)
-  (message "Checking out ~A~:[~; with a lock~] ..." (namestring pathname) lock)
-  (in-directory pathname
-    (let ((backup
-	   (if (probe-file pathname)
-	       (lisp::pick-backup-name (namestring pathname))
-	       nil)))
-      (when backup (rename-file pathname backup))
-      (do-command "rcsco" `(,@(if lock '("-l")) ,(file-namestring pathname)))
-      (invoke-hook rcs-check-out-file-hook buffer pathname)
-      (when (and backup (not (value rcs-check-out-keep-original-as-backup)))
-	(delete-file backup)))))
-
-(defun pick-temp-file (defaults)
-  (let ((index 0))
-    (loop
-      (let ((name (merge-pathnames (format nil ",rcstmp-~D" index) defaults)))
-	(cond ((probe-file name)
-	       (incf index))
-	      (t
-	       (return name)))))))
-
-
-;;;; Checking In / Checking Out and Locking / Unlocking 
-
-(defcommand "RCS Lock Buffer File" (p)
-  "Attempt to lock the file in the current buffer."
-  "Attempt to lock the file in the current buffer."
-  (declare (ignore p))
-  (let ((file (current-buffer-pathname))
-	(buffer (current-buffer))
-	(name (pick-temp-file "/tmp/")))
-    (rcs-lock-file buffer file)
-    (unwind-protect
-	(progn
-	  (in-directory file
-	    (do-command "rcsco" `("-p" ,(file-namestring file))
-			:output (namestring name)))
-	  (when (buffer-different-from-file buffer name)
-	    (message
-	     "RCS file is different: be sure to merge in your changes."))
-	  (setf (buffer-writable buffer) t)
-	  (message "Buffer is now writable."))
-      (when (probe-file name)
-	(delete-file name)))))
-
-(defcommand "RCS Lock File" (p)
-  "Prompt for a file, and attempt to lock it."
-  "Prompt for a file, and attempt to lock it."
-  (declare (ignore p))
-  (rcs-lock-file nil (prompt-for-file :prompt "File to lock: "
-				      :default (buffer-default-pathname
-						(current-buffer))
-				      :must-exist nil)))
-
-(defcommand "RCS Unlock Buffer File" (p)
-  "Unlock the file in the current buffer."
-  "Unlock the file in the current buffer."
-  (declare (ignore p))
-  (rcs-unlock-file (current-buffer) (current-buffer-pathname))
-  (setf (buffer-writable (current-buffer)) nil)
-  (message "Buffer is no longer writable."))
-
-(defcommand "RCS Unlock File" (p)
-  "Prompt for a file, and attempt to unlock it."
-  "Prompt for a file, and attempt to unlock it."
-  (declare (ignore p))
-  (rcs-unlock-file nil (prompt-for-file :prompt "File to unlock: "
-					:default (buffer-default-pathname
-						  (current-buffer))
-					:must-exist nil)))
-
-(defcommand "RCS Check In Buffer File" (p)
-  "Checkin the file in the current buffer.  With an argument, do not
-  release the lock."
-  "Checkin the file in the current buffer.  With an argument, do not
-  release the lock."
-  (let ((buffer (current-buffer))
-	(pathname (current-buffer-pathname)))
-    (when (buffer-modified buffer)
-      (save-file-command nil))
-    (rcs-check-in-file buffer pathname p)
-    (visit-file-command nil pathname buffer)))
-
-(defcommand "RCS Check In File" (p)
-  "Prompt for a file, and attempt to check it in.  With an argument, do
-  not release the lock."
-  "Prompt for a file, and attempt to check it in.  With an argument, do
-  not release the lock."
-  (rcs-check-in-file nil (prompt-for-file :prompt "File to lock: "
-					  :default
-					  (buffer-default-pathname
-					   (current-buffer))
-					  :must-exist nil)
-		     p))
-
-(defcommand "RCS Check Out Buffer File" (p)
-  "Checkout the file in the current buffer.  With an argument, lock the
-  file."
-  "Checkout the file in the current buffer.  With an argument, lock the
-  file."
-  (let* ((buffer (current-buffer))
-	 (pathname (current-buffer-pathname))
-	 (point (current-point))
-	 (lines (1- (count-lines (region (buffer-start-mark buffer) point)))))
-    (when (buffer-modified buffer)
-      (when (not (prompt-for-y-or-n :prompt "Buffer is modified, overwrite? "))
-	(editor-error "Aborted.")))
-    (maybe-rcs-check-out-file buffer pathname p nil)
-    (setf (buffer-modified buffer) nil)
-    (when p
-      (setf (buffer-writable buffer) t)
-      (message "Buffer is now writable."))
-    (visit-file-command nil pathname)
-    (unless (line-offset point lines)
-      (buffer-end point))))
-
-(defcommand "RCS Check Out File" (p)
-  "Prompt for a file and attempt to check it out.  With an argument,
-  lock the file."
-  "Prompt for a file and attempt to check it out.  With an argument,
-  lock the file."
-  (let ((pathname (prompt-for-file :prompt "File to check out: "
-				   :default (buffer-default-pathname
-					     (current-buffer))
-				   :must-exist nil)))
-    (maybe-rcs-check-out-file nil pathname p nil)
-    (find-file-command nil pathname)))
-
-
-;;;; Log File
-
-(defhvar "RCS Log Entry Buffer"
-  "Name of the buffer to put RCS log entries into."
-  :value "RCS Log")
-
-(defhvar "RCS Log Buffer Hook"
-  "RCS Log Buffer Hook"
-  :value nil)
-
-(defun get-log-buffer ()
-  (let ((buffer (getstring (value rcs-log-entry-buffer) *buffer-names*)))
-    (unless buffer
-      (setf buffer (make-buffer (value rcs-log-entry-buffer)))
-      (turn-auto-save-off buffer)
-      (invoke-hook rcs-log-buffer-hook buffer))
-    buffer))
-
-(defcommand "RCS Buffer File Log Entry" (p)
-  "Get the RCS Log for the file in the current buffer in a buffer."
-  "Get the RCS Log for the file in the current buffer in a buffer."
-  (declare (ignore p))
-  (let ((buffer (get-log-buffer))
-	(pathname (current-buffer-pathname)))
-    (delete-region (buffer-region buffer))
-    (message "Extracting log info ...")
-    (with-mark ((mark (buffer-start-mark buffer) :left-inserting))
-      (in-directory pathname
-	(do-command "rlog" (list (file-namestring pathname))
-		    :output (make-hemlock-output-stream mark))))
-    (change-to-buffer buffer)
-    (buffer-start (current-point))
-    (setf (buffer-modified buffer) nil)))
-
-(defcommand "RCS File Log Entry" (p)
-  "Prompt for a file and get its RCS log entry in a buffer."
-  "Prompt for a file and get its RCS log entry in a buffer."
-  (declare (ignore p))
-  (let ((file (prompt-for-file :prompt "File to get log of: "
-			       :default (buffer-default-pathname
-					 (current-buffer))
-			       :must-exist nil))
-	(buffer (get-log-buffer)))
-    (delete-region (buffer-region buffer))
-    (message "Extracing log info ...")
-    (with-mark ((mark (buffer-start-mark buffer) :left-inserting))
-      (in-directory file
-	(do-command "rlog" (list (file-namestring file))
-		    :output (make-hemlock-output-stream mark))))
-    (change-to-buffer buffer)
-    (buffer-start (current-point))
-    (setf (buffer-modified buffer) nil)))
-
-
-;;;; Directory Support
-
-(defun list-out-of-date-files (dir)
-  (let ((rcsdir (make-pathname :host (pathname-host dir)
-			       :device (pathname-device dir)
-			       :directory (concatenate 'simple-vector
-						       (pathname-directory dir)
-						       (vector "RCS"))))
-	(out-of-date-files nil))
-    (unless (directoryp rcsdir)
-      (editor-error "Could not find the RCS directory."))
-    (dolist (rcsfile (directory rcsdir))
-      (let ((rcsname (file-namestring rcsfile)))
-	(when (string= rcsname ",v" :start1 (- (length rcsname) 2))
-	  (let* ((name (subseq rcsname 0 (- (length rcsname) 2)))
-		 (file (merge-pathnames (parse-namestring name) dir)))
-	    (unless (and (probe-file file)
-			 (>= (file-write-date file) (file-write-date rcsfile)))
-	      (push file out-of-date-files))))))
-    out-of-date-files))
-
-(defun rcs-prompt-for-directory (prompt)
-  (let* ((default (buffer-default-pathname (current-buffer)))
-	 (dir (prompt-for-file :prompt prompt
-			       :default (make-pathname
-					 :host (pathname-host default)
-					 :device (pathname-device default)
-					 :directory (pathname-directory default)
-					 :defaults nil)
-			       :must-exist nil)))
-    (unless (directoryp dir)
-      (let ((with-slash (parse-namestring (concatenate 'simple-string
-						       (namestring dir)
-						       "/"))))
-	(unless (directoryp with-slash)
-	  (editor-error "~S is not a directory" (namestring dir)))
-	(setf dir with-slash)))
-    dir))
-
-(defcommand "RCS Update Directory" (p)
-  "Prompt for a directory and check out all files that are older than
-  their corresponding RCS files.  With an argument, never ask about
-  overwriting writable files."
-  "Prompt for a directory and check out all files that are older than
-  the corresponding RCS file.  With an argument, never ask about
-  overwriting writable files."
-  (let* ((directory (rcs-prompt-for-directory "Directory to update: "))
-	 (out-of-date-files (list-out-of-date-files directory))
-	 (n-out-of-date (length out-of-date-files)))
-    (cond ((zerop n-out-of-date)
-	   (message "All RCS files in ~A are up to date."
-		    (namestring directory)))
-	  (t
-	   (let ((n-checked-out
-		  (maybe-rcs-check-out-files out-of-date-files nil p)))
-	     (message "Number of files out of date: ~D; ~
-	     number of files checked out: ~D"
-		      n-out-of-date n-checked-out)))))))
-
-(defcommand "RCS List Out Of Date Files" (p)
-  "Prompt for a directory and list all of the files that are older than
-  their corresponding RCS files."
-  "Prompt for a directory and list all of the files that are older than
-  their corresponding RCS files."
-  (declare (ignore p))
-  (let* ((directory (rcs-prompt-for-directory "Directory: "))
-	 (out-of-date-files (list-out-of-date-files directory)))
-    (cond ((null out-of-date-files)
-	   (message "All RCS files in ~A are up to date."
-		    (namestring directory)))
-	  (t
-	   (with-pop-up-display (s :buffer-name "*RCS Out of Date Files*")
-	     (format s "Directory: ~A~%~%" (namestring directory))
-	     (dolist (file out-of-date-files)
-	       (format s "~A~%" (file-namestring file))))))))
diff --git a/ldb/Makefile.orig b/ldb/Makefile.orig
deleted file mode 100644
index fd1fa3b829020256b03b769e0b1e5a889294d380..0000000000000000000000000000000000000000
--- a/ldb/Makefile.orig
+++ /dev/null
@@ -1,85 +0,0 @@
-# $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/Makefile.orig,v 1.2 1990/02/28 18:19:49 wlott Exp $
-CFLAGS = -g
-
-OBJS = ldb.o egets.o coreparse.o alloc.o monitor.o print.o os.o vars.o assem.o parse.o interrupt.o test.o
-
-ldb.map: ldb
-	echo -n 'Map file for ldb version ' > ldb.map
-	cat version >> ldb.map
-	nm -gp ldb >> ldb.map
-
-
-ldb: ${OBJS}
-	echo -n '1 + ' | cat - version | bc > ,version
-	mv ,version version
-	cc ${CFLAGS} -DVERSION=`cat version` -c version.c
-	cc -o ,ldb ${OBJS} version.o -lmach -lc
-	mv ,ldb ldb
-
-
-# If we get an interrupt while in lisp code, the global pointer
-# is trash.  Therefore, we can't use the GP relative addressing
-# mode in the interrupt handlers.
-
-interrupt.o: interrupt.c
-	cc ${CFLAGS} -G 0 -c interrupt.c
-
-
-
-
-
-depends:
-	rm -f Makefile.BAK
-	ln Makefile Makefile.BAK
-	sed -n '1,/^#@/p' Makefile > Makefile.NEW
-	cc -M *.[cs] | egrep -v ' /usr/' >> Makefile.NEW
-	mv Makefile.NEW Makefile
-	rm Makefile.BAK
-
-#@ Do not edit anything after this line.
-alloc.o: alloc.c
-alloc.o: lisp.h
-alloc.o: ldb.h
-alloc.o: alloc.h
-assem.o: assem.s
-assem.o: lisp.h
-assem.o: lispregs.h
-coreparse.o: coreparse.c
-egets.o: egets.c
-interrupt.o: interrupt.c
-interrupt.o: lisp.h
-interrupt.o: ldb.h
-interrupt.o: lispregs.h
-ldb.o: ldb.c
-ldb.o: ldb.h
-ldb.o: lisp.h
-ldb.o: alloc.h
-ldb.o: vars.h
-monitor.o: monitor.c
-monitor.o: ldb.h
-monitor.o: lisp.h
-monitor.o: vars.h
-monitor.o: parse.h
-os.o: os.c
-os.o: ldb.h
-parse.o: parse.c
-parse.o: ldb.h
-parse.o: lisp.h
-parse.o: vars.h
-parse.o: parse.h
-print.o: print.c
-print.o: ldb.h
-print.o: print.h
-print.o: lisp.h
-print.o: vars.h
-search.o: search.c
-search.o: lisp.h
-search.o: ldb.h
-test.o: test.c
-test.o: lisp.h
-test.o: ldb.h
-vars.o: vars.c
-vars.o: ldb.h
-vars.o: lisp.h
-vars.o: vars.h
-version.o: version.c
diff --git a/ldb/alloc.c b/ldb/alloc.c
deleted file mode 100644
index 356be0d9da4d6f877ac11b34d7e8323584587aed..0000000000000000000000000000000000000000
--- a/ldb/alloc.c
+++ /dev/null
@@ -1,91 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/alloc.c,v 1.1 1990/02/24 19:37:10 wlott Exp $ */
-#include "lisp.h"
-#include "ldb.h"
-#include "alloc.h"
-
-
-/****************************************************************
-Allocation Routines.
-****************************************************************/
-
-static char *alloc(bytes)
-int bytes;
-{
-    char *result;
-
-    /* Round to dual word boundry. */
-    bytes = (bytes + lowtag_Mask) & ~lowtag_Mask;
-
-    result = (char *)SymbolValue(SAVED_ALLOCATION_POINTER);
-    SetSymbolValue(SAVED_ALLOCATION_POINTER, (lispobj)(result + bytes));
-
-    return result;
-}
-
-char *alloc_unboxed(type, words)
-int type, words;
-{
-    char *result = alloc((1 + words) * sizeof(long));
-
-    *((long *)result) = (words << type_Bits) | type;
-
-    return result;
-}
-
-lispobj alloc_vector(type, length, size)
-int type, length, size;
-{
-    struct vector *result = (struct vector *)alloc((2 + (length*size + 31) / 32) * sizeof(long));
-
-    result->header = type;
-    result->length = fixnum(length);
-
-    return ((lispobj)result)|type_OtherPointer;
-}
-
-lispobj alloc_cons(car, cdr)
-lispobj car, cdr;
-{
-    struct cons *ptr = (struct cons *)alloc(sizeof(struct cons));
-
-    ptr->car = car;
-    ptr->cdr = cdr;
-
-    return (lispobj)ptr | type_ListPointer;
-}
-
-lispobj alloc_number(n)
-long n;
-{
-    struct bignum *ptr;
-
-    if (-0x20000000 < n && n < 0x20000000)
-        return fixnum(n);
-    else {
-        ptr = (struct bignum *)alloc_unboxed(type_Bignum, 1);
-
-        ptr->digits[0] = n;
-    }
-}
-
-lispobj alloc_string(str)
-char *str;
-{
-    int len = strlen(str);
-    lispobj result = alloc_vector(type_SimpleString, len+1, 8);
-    struct vector *vec = (struct vector *)PTR(result);
-
-    vec->length = fixnum(len);
-    strcpy(vec->data, str);
-
-    return result;
-}
-
-lispobj alloc_sap(ptr)
-char *ptr;
-{
-    struct sap *sap = (struct sap *)alloc_unboxed(type_Sap, 2);
-
-    sap->pointer = ptr;
-}
-
diff --git a/ldb/alloc.h b/ldb/alloc.h
deleted file mode 100644
index 4ca5f14466ee6c6bba2a15e5f2e97d9d6dfd92ea..0000000000000000000000000000000000000000
--- a/ldb/alloc.h
+++ /dev/null
@@ -1,3 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/alloc.h,v 1.1 1990/02/24 19:37:11 wlott Exp $ */
-
-lispobj alloc_cons(), alloc_string(), alloc_number();
diff --git a/ldb/coreparse.c b/ldb/coreparse.c
deleted file mode 100644
index 6701922158d511f5034c14c55aa4b2c3b28a9bbe..0000000000000000000000000000000000000000
--- a/ldb/coreparse.c
+++ /dev/null
@@ -1,105 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/coreparse.c,v 1.1 1990/02/24 19:37:14 wlott Exp $ */
-#include <stdio.h>
-#include <mach.h>
-#include <sys/types.h>
-#include <sys/file.h>
-
-extern int version;
-
-#define CORE_PAGESIZE (4*1024)
-#define CORE_MAGIC (('C' << 24) | ('O' << 16) | ('R' << 8) | 'E')
-#define CORE_END 3840
-#define CORE_DIRECTORY 3841
-#define CORE_VALIDATE 3845
-#define CORE_VERSION 3860
-
-static void process_validate(ptr, count)
-long *ptr;
-{
-    long addr, len;
-
-    while (count-- > 0) {
-        addr = *ptr++ * CORE_PAGESIZE;
-        len = *ptr++ * CORE_PAGESIZE;
-        printf("validating %d bytes at 0x%x\n", len, addr);
-        os_validate(addr, len);
-    }
-}
-
-static void process_directory(fd, ptr, count)
-long *ptr;
-int count;
-{
-    long offset, addr, len;
-
-    while (count-- > 0) {
-        offset = CORE_PAGESIZE * (1 + *ptr++);
-        addr = CORE_PAGESIZE * *ptr++;
-        len = CORE_PAGESIZE * *ptr++;
-
-        if (len != 0) {
-            printf("mapping %d bytes at 0x%x\n", len, addr);
-            os_map(fd, offset, addr, len);
-        }
-    }
-}
-
-void load_core_file(file)
-char *file;
-{
-    int fd = open(file, O_RDONLY), count;
-    long header[CORE_PAGESIZE / sizeof(long)], val, len, *ptr;
-
-    if (fd < 0) {
-        perror("open");
-        exit(1);
-    }
-
-    count = read(fd, header, CORE_PAGESIZE);
-    if (count < 0) {
-        perror("read");
-        exit(1);
-    }
-    if (count < CORE_PAGESIZE) {
-        fprintf(stderr, "Premature EOF.\n");
-        exit(1);
-    }   
-
-    ptr = header;
-    val = *ptr++;
-
-    if (val != CORE_MAGIC) {
-        fprintf(stderr, "Invalid magic number: 0x%x should have been 0x%x\n", val, CORE_MAGIC);
-        exit(1);
-    }
-
-    while (val != CORE_END) {
-        val = *ptr++;
-        len = *ptr++;
-
-        switch (val) {
-            case CORE_END:
-                break;
-
-            case CORE_VERSION:
-                if (*ptr != version) {
-                    fprintf(stderr, "*** Warning, ldb version (%d) different from core version (%d)\nYou will probably lose big.\n", version, *ptr);
-                }
-                break;
-
-            case CORE_VALIDATE:
-                process_validate(ptr, (len-2)/2);
-                break;
-
-            case CORE_DIRECTORY:
-                process_directory(fd, ptr, (len-2)/3);
-                break;
-
-            default:
-                printf("Unknown header entry: %d. Skipping.\n", val);
-                break;
-        }
-
-        ptr += len - 2;
-    }
-}
diff --git a/ldb/egets.c b/ldb/egets.c
deleted file mode 100644
index 18a08affc9ac7fdd2ba8d222e998fe7a722bbcb5..0000000000000000000000000000000000000000
--- a/ldb/egets.c
+++ /dev/null
@@ -1,628 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/egets.c,v 1.1 1990/02/24 19:37:15 wlott Exp $ */
-/********************************************************************
-*                                                                   *
-*                                                                   *
-*     Copyright (C) 1987, Carnegie Mellon University                *
-*                                                                   *
-*                                                                   *
-********************************************************************/
-
-/* egets.c --	replacement for C library's gets(3s)
- *		allows emacs style command editing if stdin is a tty
- *						Derek Beatty
- * HISTORY
- *	20 Nov 87 Beatty: added code for more-mode.
- *		More-mode is handled by this file so gets can reset
- *		its line count.
- */
-#include <stdio.h>
-#include <ctype.h>
-#include <sgtty.h>
-#include <signal.h>
-#include <strings.h>
-#include <setjmp.h>
-
-int getpid();		/* this should have been declared somewhere */
-
-/*LINTLIBRARY*/
-
-#define TRUE (1)
-#define FALSE (0)
-
-typedef unsigned char uchar;
-
-#define HISTBUF		(2000)
-#define LINEBUF		(132)
-
-#define CONTROL(x)	((x)&0x1F)
-#define META(x)		((x)|0x80)
-#define BELL		CONTROL('g')
-#define ESC		(0x1B)
-#define RUBOUT		(0x7F)
-#define ISCONTROL(x)	((x)<0x20 || (x)>0x7E)		/* includes meta */
-#define NOTPREFIX(c)	((c)!=ESC)
-
-/** Global Variables for user settings */
-int ScrollPauseSwitch;
-int ScreenLengthLimit;
-int EditSwitch = TRUE;
-
-/** Shared by MORE and GETS **/
-static int CurrentLine = 1;
-static int Initialized = FALSE;/* true iff initialize has been called */
-
-/** VARIABLES FOR GETS **/
-static struct sgttyb OttyFlags, NttyFlags;
-static struct ltchars OltChars, NltChars;
-  
-#ifdef SIGTSTP
-static int (*TstpHandler)();
-#endif SIGTSTP
-  
-static int Active = TRUE;	/* true iff egets is working */
-static uchar History[HISTBUF];	/* history buffer */
-static uchar
-	*FirstHistory,		/* ptr to earliest line in history buffer */
-	*YankedHistory;		/* ptr to history last yanked */
-static uchar KillBuf[LINEBUF+1];	/* kill buffer */
-static uchar Line[LINEBUF+1];	/* line being entered, plus null */
-static uchar
-	*Cursor,		/* ptr to character cursor is on */
-	*Bol,			/* ptr to first char of line */
-	*Eol;			/* ptr to null that terminates line */
-
-static uchar tLine[LINEBUF+1];	/* line displayed on terminal */
-static uchar *tCursor, *tBol, *tEol;
-
-static uchar Meta = 0;	/* meta bit; 0x80 if meta key was last */
-static int Bleep = FALSE;   /* TRUE iff bell needed at next screen update */
-
-static jmp_buf out_of_here;
-
-static void saveTtyModes(), restoreTtyModes(), initialize(), showLine(),
-	killToEol(), yankNext(), yankPrev(),	yankKillBuf(), 
-	transpose(), openSpace(), closeSpace();
-
-/* saveTtyModes -- save tty state and put tty into cbreak mode */
-static void 
-saveTtyModes()
-{
-    (void) ioctl(fileno(stdin), TIOCGETP, (char*) &OttyFlags);
-    NttyFlags = OttyFlags;
-    NttyFlags.sg_flags |= CBREAK;
-    NttyFlags.sg_flags &= ~XTABS;
-    NttyFlags.sg_flags &= ~ECHO;
-    (void) ioctl(fileno(stdin), TIOCSETN, (char*) &NttyFlags);
-    (void) ioctl(fileno(stdin), TIOCGLTC, (char*) &OltChars);
-    NltChars = OltChars;
-    NltChars.t_dsuspc = NltChars.t_suspc;
-    (void) ioctl(fileno(stdin), TIOCSLTC, (char*) &NltChars);
-}
-
-/* restoreTtyModes -- restore tty state */
-static void 
-restoreTtyModes()
-{
-    (void) ioctl(fileno(stdin), TIOCSLTC, (char*) &OltChars);
-    (void) ioctl(fileno(stdin), TIOCSETN, (char*) &OttyFlags);
-}
-
-/* isaCRT -- return nonzero iff fd is a tty with CRT bits set */
-static int 
-isaCRT( fd)
-int fd;
-{
-    int             ltbits;
-
-    (void) ioctl(fd, TIOCLGET, (char*) &ltbits);
-    return (ltbits & (LCRTERA | LCRTKIL));
-}
-
-/* tstp -- handler for SIGTSTP: restore tty and suspend */
-#ifdef SIGTSTP
-int 
-tstp()
-{
-    if (TstpHandler == SIG_IGN)
-	return;
-    restoreTtyModes();
-    if (TstpHandler == SIG_DFL)
-	(void) kill(getpid(), SIGSTOP);
-    else
-	(*TstpHandler) ();
-    saveTtyModes();
-    tBol = tEol = tCursor = tLine;
-    tLine[0] = '\0';
-    showLine();
-}
-#endif
-
-/* initialize -- init data structures used by gets and more. called once. */
-static void 
-initialize()
-{
-    int             i;
-
-    /* initialization for gets */
-    Initialized = TRUE;
-    YankedHistory = FirstHistory = History;
-    for (i = 0; i < HISTBUF; i++)
-	History[i] = '\0';
-    KillBuf[0] = '\0';
-
-    /* initialization for more */
-    ScrollPauseSwitch= isaCRT(fileno(stdin)) && isatty(fileno(stdout));
-
-    ScreenLengthLimit= -1;
-#ifdef TIOCGWINSZ /* 4.3bsd window size */
-    {
-	struct winsize wss;
-	ioctl(fileno(stdin), TIOCGWINSZ, (char*) &wss);
-	ScreenLengthLimit= wss.ws_row-1;
-    }
-#endif
-#ifdef TIOCGSIZE /* sun window size */
-    {
-	struct ttysize tss;
-	ioctl(fileno(stdin), TIOCGSIZE, (char*) &tss);
-	ScreenLengthLimit= tss.ts_lines-1;
-    }
-#endif
-    if (ScreenLengthLimit==-1)
-	ScreenLengthLimit = 24;
-}
-
-
-/* killToEol -- delete characters on and following cursor into kill buffer */
-static void 
-killToEol()
-{
-    int             n = strlen( (char*) Cursor);
-
-    (void) strcpy((char*) KillBuf, (char*) Cursor);
-    closeSpace(n);
-}
-
-/* transpose -- transpose two characters preceding cursor */
-static void 
-transpose()
-{
-    if (Cursor <= Bol + 1)
-	Bleep = TRUE;
-    else {
-	uchar           c = *(Cursor - 1);
-	*(Cursor - 1) = *(Cursor - 2);
-	*(Cursor - 2) = c;
-    }
-}
-
-/* numInWord -- return number of chars through word before or after cursor */
-static int
-numInWord( before)
-  int before;		/* true iff want count in word before cursor */
-{
-    uchar          *tempCursor = Cursor;
-    int             n;
-
-    if (before) {
-	if (tempCursor > Bol)
-	    tempCursor--;
-	else
-	    Bleep = TRUE;
-	while (tempCursor > Bol && !isalnum(*tempCursor))
-	    tempCursor--;
-	while (tempCursor > Bol && isalnum(*tempCursor))
-	    tempCursor--;
-	n = Cursor - tempCursor;
-	if (n != 0 && !isalnum(*tempCursor))
-	    n--;
-	return (n);
-    } else {
-	if (tempCursor >= Eol)
-	    Bleep = TRUE;
-	while (tempCursor < Eol && !isalnum(*tempCursor))
-	    tempCursor++;
-	while (tempCursor < Eol && isalnum(*tempCursor))
-	    tempCursor++;
-	return (tempCursor - Cursor);
-    }
-}
-
-/* yankHistory -- yank line at YankedHistory into Line */
-static void 
-yankHistory()
-{
-    uchar          *tempHistory;
-
-    YankedHistory++;
-    if (YankedHistory >= History + HISTBUF)
-	YankedHistory = History;
-    tempHistory = YankedHistory;
-    Bol = Cursor = Line;
-    while (*tempHistory) {
-	*Cursor++ = *tempHistory++;
-	if (tempHistory >= History + HISTBUF)
-	    tempHistory = History;
-    }
-    *Cursor = '\0';
-    Eol = Cursor;
-}
-
-/* yankNext -- yank the next line from the history buffer */
-static void 
-yankNext()
-{
-    while (*YankedHistory) {
-	YankedHistory++;
-	if (YankedHistory >= History + HISTBUF)
-	    YankedHistory = History;
-    }
-    yankHistory();
-}
-
-/* yankPrev -- yank the previous line from the history buffer */
-static void 
-yankPrev()
-{
-    YankedHistory--;
-    if (YankedHistory < History)
-	YankedHistory = History + HISTBUF - 1;
-    YankedHistory--;
-    if (YankedHistory < History)
-	YankedHistory = History + HISTBUF - 1;
-    while (*YankedHistory) {
-	YankedHistory--;
-	if (YankedHistory < History)
-	    YankedHistory = History + HISTBUF - 1;
-    }
-    yankHistory();
-}
-
-/* addHistory -- add the current line to the history buffer */
-static void 
-addHistory()
-{
-    uchar          *tempCursor = Bol;
-
-    while (*tempCursor) {
-	*FirstHistory++ = *tempCursor++;
-	if (FirstHistory >= History + HISTBUF)
-	    FirstHistory = History;
-    }
-    *FirstHistory++ = '\0';
-    if (FirstHistory >= History + HISTBUF)
-	FirstHistory = History;
-    YankedHistory = FirstHistory;
-}
-
-/* yankKillBuf -- insert kill buffer in current line.  Bleep if trouble */
-static void 
-yankKillBuf()
-{
-    uchar          *sourceCursor = KillBuf;
-    uchar          *destCursor = Cursor;
-    int             n = strlen((char*) KillBuf);
-
-    if (Eol + n > Line + LINEBUF)
-	Bleep = TRUE;
-    else {
-	openSpace(n);
-	while (*sourceCursor)
-	    *destCursor++ = *sourceCursor++;
-	Cursor += n;
-    }
-}
-
-/* redraw -- force showLine to redraw current line on screen */
-static void 
-redraw()
-{
-    tCursor = tBol = tEol = tLine;
-    tLine[0] = '\0';
-    printf("\n");
-    (void) fflush(stdout);
-}
-
-/* showLine -- update screen and tLine to reflect Line */
-static void 
-showLine()
-{
-    uchar          *Dif, *tDif;
-
-
-    /* find first place the lines differ */
-    Dif = Bol;
-    tDif = tBol;
-    while (*Dif && *tDif && *Dif == *tDif) {
-	Dif++;
-	tDif++;
-    }
-    if (*Dif || *tDif) {
-	/* lines differ: move tCursor to the point of difference */
-	while (tCursor > tDif) {
-	    printf("\b");
-	    tCursor--;
-	}
-	while (tCursor < tDif)
-	    printf("%c", *tCursor++);
-	/* write remainder of Line */
-	while (*Dif)
-	    printf("%c", *tCursor++ = *Dif++);
-	/* add blanks to bring tLine up to length of Line */
-	while (tCursor < tEol) {
-	    printf(" ");
-	    *tCursor++ = '\0';
-	}
-	/* adjust tEol */
-	tEol = tBol + (Eol - Bol);
-    }
-    /* move tCursor to proper place */
-    while (tCursor - tBol > Cursor - Bol) {
-	printf("\b");
-	tCursor--;
-    }
-    while (tCursor - tBol < Cursor - Bol)
-	printf("%c", *tCursor++);
-    /* cleanup */
-    if (Bleep) {
-	printf("%c", BELL);
-	Bleep = FALSE;
-    }
-    (void) fflush(stdout);
-}
-
-/* openSpace -- open space for n characters at cursor.  Beep if trouble. */
-static void 
-openSpace( n)
-  int n;
-{
-    uchar          *sourceCursor, *destCursor;
-
-    if (n == 0)
-	return;
-    destCursor = Eol + n;
-    if (destCursor > Line + LINEBUF + 1)
-	Bleep = TRUE;
-    else {
-	sourceCursor = Eol;
-	Eol = destCursor;
-	while (sourceCursor >= Cursor)
-	    *destCursor-- = *sourceCursor--;
-    }
-}
-
-/* closeSpace -- close space for n characters at cursor.  Bleep if trouble. */
-static void 
-closeSpace( n)
-  int n;
-{
-    uchar          *sourceCursor, *destCursor;
-
-    if (n == 0)
-	return;
-    if (n > Eol - Cursor) {
-	Bleep = TRUE;
-	n = Eol - Cursor;
-    }
-    sourceCursor = Cursor + n;
-    destCursor = Cursor;
-    while (sourceCursor <= Eol)
-	*destCursor++ = *sourceCursor++;
-    Eol = destCursor - 1;
-}
-
-/* ogets -- get a line without command line editing */
-static char *
-ogets(s, n)
-char *s;
-int n;				/* total length of string */
-{
-	int c, i;
-	char *t;
-
-	t = s; i = n;
-
-	if (n <= 0)
-		return NULL;
-
-	while ((--i > 0) && ((c = getchar()) != '\n') && (c != EOF))
-		*t++ = c;
-	if ((n != 1) && (c == EOF) && (s == t))
-		return NULL;
-	*t = '\0';
-
-	return(s);
-}
-
-static sigint_handler()
-{
-    longjmp(out_of_here, 1);
-}
-
-
-/* egets -- get a line from stdin with command line editing */
-char * 
-egets()
-{
-    uchar           c= '\0';
-    int            done, returnEOF;
-    long int        buffered= 0L;
-    int             n;
-    int             arg = 0;
-    int            gettingArg = FALSE, gettingDigitArg = FALSE;
-    int            stillGettingArg = FALSE;
-    struct sigvec sv, old_int_sv;
-
-    if (!EditSwitch
-	|| !Active
-	|| (!Initialized && (!isatty(fileno(stdin)) ))
-	|| !isaCRT(fileno(stdin))) {
-	Active = FALSE;
-	return (ogets(Line, LINEBUF + 1));
-    }
-    if (!Initialized)
-	initialize();
-    fflush(stdout);
-    CurrentLine=1;		/* Reset line count for more-mode. */
-    Line[0] = '\0';
-    tLine[0] = '\0';
-    Cursor = Bol = Eol = Line;
-    tCursor = tBol = tEol = tLine;
-#ifdef SIGTSTP
-    TstpHandler = signal(SIGTSTP, tstp);
-#endif
-    saveTtyModes();
-    if (setjmp(out_of_here))
-        returnEOF = TRUE;
-    else {
-        sv.sv_handler = sigint_handler;
-        sv.sv_mask = 0;
-        sv.sv_flags = 0;
-        sigvec(SIGINT, &sv, &old_int_sv);
-
-        returnEOF = done = FALSE;
-        while (!done) {
-            /* lint complains that c may be used before set */
-            if (!gettingArg && arg > 0 && NOTPREFIX(c))
-                arg--;
-            else {
-                if (read(fileno(stdin), (char*) &c, 1) == 0)
-                    c = CONTROL('m');
-                else {
-                    c |= Meta;
-                    Meta = 0;
-                }
-            }
-            if (ISCONTROL(c)) {
-                switch (c) {
-                    case CONTROL('a'):
-                        Cursor = Bol;
-                        break;
-                    case CONTROL('b'):
-                        if (Cursor > Bol)
-                            Cursor--;
-                        else
-                            Bleep = TRUE;
-                        break;
-                    case CONTROL('d'):
-                        if (Cursor < Eol)
-                            closeSpace(1);
-                        else
-                            Bleep = TRUE;
-                        break;
-                    case CONTROL('e'):
-                        Cursor = Eol;
-                        break;
-                    case CONTROL('f'):
-                        if (Cursor < Eol)
-                            Cursor++;
-                        else
-                            Bleep = TRUE;
-                        break;
-                    case CONTROL('h'):
-                    case RUBOUT:
-                        if (Cursor > Bol) {
-                            Cursor--;
-                            closeSpace(1);
-                        } else
-                            Bleep = TRUE;
-                        break;
-                    case CONTROL('j'):
-                        done = TRUE;
-                        break;
-                    case CONTROL('k'):
-                        killToEol();
-                        break;
-                    case CONTROL('m'):
-                        done = TRUE;
-                        break;
-                    case CONTROL('n'):
-                        yankNext();
-                        break;
-                    case CONTROL('p'):
-                        yankPrev();
-                        break;
-                    case CONTROL('r'):
-                        redraw();
-                        break;
-                    case CONTROL('t'):
-                        transpose();
-                        break;
-                    case CONTROL('u'):
-                        if (gettingArg)
-                            arg *= 4;
-                        else
-                            arg = 4;
-                        stillGettingArg = TRUE;
-                        gettingDigitArg = FALSE;
-                        break;
-                    case CONTROL('y'):
-                        yankKillBuf();
-                        break;
-                    case ESC:
-                        Meta = 0x80;
-                        break;
-                    case META('f'):
-                        Cursor += numInWord(0);
-                        break;
-                    case META('b'):
-                        Cursor -= numInWord(1);
-                        break;
-                    case META('d'):
-                        closeSpace(numInWord(0));
-                        break;
-                    case CONTROL('w'):
-                    case META('h'):
-                        n = numInWord(1);
-                        Cursor -= n;
-                        closeSpace(n);
-                        break;
-                    case META(CONTROL('d')):
-                        if (Bol == Eol)
-                            done = returnEOF = TRUE;
-                        else
-                            Bleep = TRUE;
-                        break;
-                    default:
-                        Bleep = TRUE;
-                        break;
-                }
-            } else if (!gettingArg || !isdigit(c)) {
-                if (Eol + 1 > Line + LINEBUF)
-                    Bleep = TRUE;
-                else {
-                    openSpace(1);
-                    *Cursor++ = c;
-                }
-            } else {
-                /* getting argument digits */
-                if (gettingDigitArg)
-                    arg = 10 * arg + c - '0';
-                else
-                    arg = c - '0';
-                stillGettingArg = TRUE;
-                gettingDigitArg = TRUE;
-            }
-            if (gettingArg && !stillGettingArg)
-                arg--;
-            gettingArg = stillGettingArg;
-            stillGettingArg = FALSE;
-            if (Bleep)
-                arg = 0;
-            (void) ioctl(fileno(stdin), FIONREAD, (char*) &buffered);
-            if ((buffered == 0L && arg == 0) || done)
-                showLine();
-        }
-        addHistory();
-    }
-
-    if (!returnEOF) printf("\n");
-    (void) fflush(stdout);
-
-    restoreTtyModes();
-#ifdef SIGTSTP
-    (void) signal(SIGTSTP, TstpHandler);
-#endif
-    sigvec(SIGINT, &old_int_sv, NULL);
-    return (returnEOF ? NULL : (char *) Line);
-}
diff --git a/ldb/interrupt.c b/ldb/interrupt.c
deleted file mode 100644
index f40276fbc00739c77c214a91de89ca70f9d60b0b..0000000000000000000000000000000000000000
--- a/ldb/interrupt.c
+++ /dev/null
@@ -1,156 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/interrupt.c,v 1.1 1990/02/24 19:37:17 wlott Exp $ */
-#include <signal.h>
-#include <mips/cpu.h>
-
-#include "lisp.h"
-#include "ldb.h"
-#include "lispregs.h"
-
-/* Interrupt handing magic. */
-
-static union handler {
-    lispobj lisp;
-    int (*c)();
-} Handler[NSIG];
-      
-static int pending_signal, pending_code, pending_mask;
-
-#define BLOCKABLE (sigmask(SIGHUP)|sigmask(SIGINT)|sigmask(SIGQUIT)|sigmask(SIGPIPE)|sigmask(SIGALRM)|sigmask(SIGURG)|sigmask(SIGTSTP)|sigmask(SIGCHLD)|sigmask(SIGIO)|sigmask(SIGXCPU)|sigmask(SIGXFSZ)|sigmask(SIGVTALRM)|sigmask(SIGPROF)|sigmask(SIGWINCH)|sigmask(SIGUSR1)|sigmask(SIGUSR2))
-
-
-static handle_now(signal, code, context)
-int signal, code;
-struct sigcontext *context;
-{
-    boolean were_in_lisp = (SymbolValue(FOREIGN_FUNCTION_CALL_ACTIVE) == NIL);
-    union handler handler = Handler[signal];
-    lispobj args[6]; /* Six is the minimum */
-    lispobj callname, function;
-
-    if (were_in_lisp) {
-        /* Get LISP state from context */
-        SetSymbolValue(SAVED_ALLOCATION_POINTER, context->sc_regs[ALLOC]);
-        SetSymbolValue(SAVED_CONTROL_STACK_POINTER, context->sc_regs[CSP]);
-        SetSymbolValue(SAVED_BINDING_STACK_POINTER, context->sc_regs[BSP]);
-        SetSymbolValue(SAVED_FLAGS_REGISTER, context->sc_regs[FLAGS]|(1<<flag_Atomic));
-
-        /* Restore the GP */
-        set_global_pointer(SymbolValue(SAVED_GLOBAL_POINTER));
-
-        /* Push context pointer on control stack. */
-        /* ### */
-
-        SetSymbolValue(FOREIGN_FUNCTION_CALL_ACTIVE, T);
-    }
-
-    if (LowtagOf(handler.lisp) == type_EvenFixnum || LowtagOf(handler.lisp) == type_OddFixnum)
-        (*handler.c)(signal, code, context);
-    else {
-        args[0] = fixnum(signal);
-        args[1] = fixnum(code);
-        args[2] = alloc_sap(context);
-        callname = handler.lisp;
-        if (LowtagOf(callname) == type_FunctionPointer)
-            function = callname;
-        else
-            function = ((struct symbol *)PTR(callname))->function;
-        call_into_lisp(callname, function, args, 3);
-    }
-
-    if (were_in_lisp) {
-        sigblock(BLOCKABLE);
-        SetSymbolValue(FOREIGN_FUNCTION_CALL_ACTIVE, NIL);
-
-        /* Put ALLOC back into context. */
-        context->sc_regs[ALLOC] = SymbolValue(SAVED_ALLOCATION_POINTER);
-    }
-}
-
-static maybe_now_maybe_later(signal, code, context)
-int signal, code;
-struct sigcontext *context;
-{
-    if (SymbolValue(FOREIGN_FUNCTION_CALL_ACTIVE) == NIL && context->sc_regs[FLAGS] & (1<<flag_Atomic)) {
-        pending_signal = signal;
-        pending_code = code;
-        pending_mask = context->sc_mask;
-        context->sc_mask |= BLOCKABLE;
-        context->sc_regs[FLAGS] |= (1<<flag_Interrupted);
-    }
-    else
-        handle_now(signal, code, context);
-}
-
-static segv_handler(signal, code, context)
-int signal, code;
-struct sigcontext *context;
-{
-#if 0
-    if (bogus_page == guard_page) {
-        unprotext(guard_page);
-        if (SymbolValue(FOREIGN_FUNCTION_CALL_ACTIVE) == NIL && context->sc_regs[FLAGS] & (1<<flag_Atomic)) {
-            pending_signal = signal;
-            pending_code = code;
-            pending_mask = context->sc_mask;
-            context->sc_mask |= BLOCKABLE;
-            context->sc_regs[FLAGS] |= (1<<flag_Interrupted);
-        }
-        SetSymbolValue(GC_TRIGGER_HIT, T);
-    }
-    else
-#endif
-        handle_now(signal, code, context);
-}
-
-static trap_handler(signal, code, context)
-int signal, code;
-struct sigcontext *context;
-{
-    if (code == trap_PendingInterrupt) {
-        signal = pending_signal;
-        code = pending_code;
-        context->sc_mask = pending_mask;
-        pending_signal = 0;
-        pending_code = 0;
-        pending_mask = 0;
-    }
-    handle_now(signal, code, context);
-}
-
-static fpe_handler(signal, code, context)
-int signal, code;
-struct sigcontext *context;
-{
-    switch (signal) {
-        case EXC_OV:
-            /* integer overflow.  Make a bignum. */
-            /* For now, drop through. */
-
-        default:
-            handle_now(signal, code, context);
-    }
-}
-
-void install_handler(signal, handler)
-int signal;
-union handler handler;
-{
-    struct sigvec sv;
-
-    if (sigmask(signal)&BLOCKABLE)
-        sv.sv_handler = maybe_now_maybe_later;
-    else if (signal == SIGSEGV)
-        sv.sv_handler = segv_handler;
-    else if (signal == SIGTRAP)
-        sv.sv_handler = trap_handler;
-    else if (signal == SIGFPE)
-        sv.sv_handler = fpe_handler;
-    else
-        sv.sv_handler = handle_now;
-    sv.sv_mask = BLOCKABLE;
-    sv.sv_flags = 0;
-
-    Handler[signal] = handler;
-
-    sigvec(signal, &sv, NULL);
-}
diff --git a/ldb/ldb.c b/ldb/ldb.c
deleted file mode 100644
index b3d05b8b43ac870c2318b5d8954caaa3a0773fcf..0000000000000000000000000000000000000000
--- a/ldb/ldb.c
+++ /dev/null
@@ -1,78 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/ldb.c,v 1.1 1990/02/24 19:37:18 wlott Exp $ */
-/* Lisp kernel core debugger */
-
-#include <stdio.h>
-#include <sys/types.h>
-#include <sys/file.h>
-#include <mach.h>
-
-#include "ldb.h"
-#include "lisp.h"
-#include "alloc.h"
-#include "vars.h"
-
-lispobj lisp_nil_reg = NIL;
-char *lisp_csp_reg, *lisp_bsp_reg;
-
-static lispobj alloc_str_list(list)
-char *list[];
-{
-    lispobj result, newcons;
-    struct cons *ptr;
-
-    if (*list == NULL)
-        result = NIL;
-    else {
-        result = newcons = alloc_cons(alloc_string(*list++), NIL);
-
-        while (*list != NULL) {
-            ptr = (struct cons *)PTR(newcons);
-            newcons = alloc_cons(alloc_string(*list++), NIL);
-            ptr->cdr = newcons;
-        }
-    }
-
-    return result;
-}
-
-
-main(argc, argv, argp)
-int argc;
-char *argv[];
-char *argp[];
-{
-    char *arg, **argptr;
-    char *core = NULL;
-
-    define_var("nil", NIL, TRUE);
-    define_var("t", T, TRUE);
-
-    argptr = argv;
-    while ((arg = *++argptr) != NULL) {
-        if (strcmp(arg, "-core") == 0) {
-            if (core != NULL) {
-                fprintf(stderr, "can only spesify one core file.\n");
-                exit(1);
-            }
-            core = *++argptr;
-            if (core == NULL) {
-                fprintf(stderr, "-core must be followed by the name of the core file to use.\n");
-                exit(1);
-            }
-        }
-    }
-
-    if (core == NULL)
-        core = "test.core";
-    load_core_file(core);
-
-    SetSymbolValue(SAVED_GLOBAL_POINTER, current_global_pointer());
-
-    SetSymbolValue(LISP_COMMAND_LINE_LIST, alloc_str_list(argv));
-    SetSymbolValue(LISP_ENVIRONMENT_LIST, alloc_str_list(argp));
-
-    test_init();
-
-    while (1)
-        monitor();
-}
diff --git a/ldb/ldb.h b/ldb/ldb.h
deleted file mode 100644
index a205b94f5765841950a98f5c05849a7b534ca70f..0000000000000000000000000000000000000000
--- a/ldb/ldb.h
+++ /dev/null
@@ -1,18 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/ldb.h,v 1.1 1990/02/24 19:37:19 wlott Exp $ */
-#ifndef _LDB_H_
-#define _LDB_H_
-
-#ifndef NULL
-#define NULL 0
-#endif
-
-#define boolean int
-#define TRUE 1
-#define FALSE 0
-
-#define SymbolValue(sym) (((struct symbol *)PTR(sym))->value)
-#define SetSymbolValue(sym,val) (((struct symbol *)PTR(sym))->value = (val))
-#define SymbolFunction(sym) (((struct symbol *)PTR(sym))->function)
-#define SetSymbolFunction(sym,val) (((struct symbol *)PTR(sym))->function = (val))
-
-#endif _LDB_H_
diff --git a/ldb/lispregs.h b/ldb/lispregs.h
deleted file mode 100644
index b7f06db75eddd7609d2238428644d45db73637c8..0000000000000000000000000000000000000000
--- a/ldb/lispregs.h
+++ /dev/null
@@ -1,37 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/lispregs.h,v 1.1 1990/02/24 19:37:22 wlott Exp $ */
-#ifdef LANGUAGE_ASSEMBLY
-#define REG(num) $num
-#else
-#define REG(num) num
-#endif
-
-#define ZERO    REG(0)
-#define LIP     REG(1)
-#define NL0     REG(2)
-#define NL1     REG(3)
-#define NL2     REG(4)
-#define NL3     REG(5)
-#define NL4     REG(6)
-#define NARGS   REG(7)
-#define A0      REG(8)
-#define A1      REG(9)
-#define A2      REG(10)
-#define A3      REG(11)
-#define A4      REG(12)
-#define A5      REG(13)
-#define CNAME   REG(14)
-#define LEXENV  REG(15)
-#define ARGS    REG(16)
-#define OLDCONT REG(17)
-#define LRA     REG(18)
-#define L0      REG(19)
-#define NULLREG REG(20)
-#define BSP     REG(21)
-#define CONT    REG(22)
-#define CSP     REG(23)
-#define FLAGS   REG(24)
-#define ALLOC   REG(25)
-#define L1      REG(28)
-#define NSP     REG(29)
-#define CODE    REG(30)
-#define L2      REG(31)
diff --git a/ldb/mips-assem.s b/ldb/mips-assem.s
deleted file mode 100644
index f7cd17ebce7bfa2b2a3ba9505cdd115f70fd51bb..0000000000000000000000000000000000000000
--- a/ldb/mips-assem.s
+++ /dev/null
@@ -1,269 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/mips-assem.s,v 1.2 1990/02/28 18:20:35 wlott Exp $ */
-#include <machine/regdef.h>
-
-#include "lisp.h"
-#include "lispregs.h"
-
-/*
- * Function to save the global pointer.
- */
-	.text
-	.globl	current_global_pointer
-	.ent	current_global_pointer
-current_global_pointer:
-	move	v0, gp
-	j	ra
-	.end	current_global_pointer
-
-/*
- * And a function to restore the global pointer.
- */
-	.text
-	.globl	set_global_pointer
-	.ent	set_global_pointer
-set_global_pointer:
-	move	gp, a0
-	j	ra
-	.end	set_global_pointer
-
-
-/*
- * Function to transfer control into lisp.
- */
-	.text
-	.globl	call_into_lisp
-	.ent	call_into_lisp
-call_into_lisp:
-#define framesize 11*4
-	subu	sp, framesize
-	.frame	sp, framesize, ra
-	/* Save all the C regs. */
-	.mask	0xd0ff0000, 0
-	sw	ra, framesize(sp)
-	sw	s8, framesize-4(sp)
-	sw	gp, framesize-8(sp)
-	sw	s7, framesize-12(sp)
-	sw	s6, framesize-16(sp)
-	sw	s5, framesize-20(sp)
-	sw	s4, framesize-24(sp)
-	sw	s3, framesize-28(sp)
-	sw	s2, framesize-32(sp)
-	sw	s1, framesize-36(sp)
-	sw	s0, framesize-40(sp)
-
-	/* Clear descriptor regs */
-	move	t0, zero
-	move	t1, zero
-	move	t2, zero
-	move	t3, zero
-	move	t4, zero
-	move	t5, zero
-	move	t6, zero
-	move	t7, zero
-	move	s0, zero
-	move	s1, zero
-	move	s2, zero
-	move	s3, zero
-	move	gp, zero
-	move	ra, zero
-
-	.set	noreorder
-
-	/* The saved FLAGS has the pseudo-atomic bit set. */
-	li	NULLREG, NIL
-	lw	FLAGS, (SAVED_FLAGS_REGISTER - NIL + SYMBOL_VALUE_OFFSET)(NULLREG)
-
-	/* No longer in foreign call. */
-	sw	NULLREG, (FOREIGN_FUNCTION_CALL_ACTIVE - NIL + SYMBOL_VALUE_OFFSET)(NULLREG)
-
-	/* Load the rest of the LISP state. */
-	lw	ALLOC, (SAVED_ALLOCATION_POINTER - NIL + SYMBOL_VALUE_OFFSET)(NULLREG)
-	lw	BSP, (SAVED_BINDING_STACK_POINTER - NIL + SYMBOL_VALUE_OFFSET)(NULLREG)
-	lw	CSP, (SAVED_CONTROL_STACK_POINTER - NIL + SYMBOL_VALUE_OFFSET)(NULLREG)
-
-	/* Check for interrupt */
-	and	FLAGS, (0xffff^(1<<flag_Atomic))
-	and	v0, FLAGS, (1<<flag_Interrupted)
-	beq	v0, zero, 1f
-	nop
-
-	/* We were interrupted. Hit the trap. */
-	break	trap_PendingInterrupt
-1:
-
-	.set	reorder
-
-	/* Pass in args */
-	move	CNAME, $4
-	move	LEXENV, $5
-	move	ARGS, $6
-	sll	NARGS, $7, 2
-	lw	A0, 0(ARGS)
-	lw	A1, 4(ARGS)
-	lw	A2, 8(ARGS)
-	lw	A3, 12(ARGS)
-	lw	A4, 16(ARGS)
-	lw	A5, 20(ARGS)
-
-	/* Calculate LRA */
-	la	LRA, lra + type_OtherPointer
-
-	/* Establish context pointers */
-	move	OLDCONT, $0 /* C doesn't have a context ptr */
-	move	CONT, CSP
-
-	/* Indirect closure */
-	lw	CODE, 4-1(LEXENV)
-
-	/* Jump into lisp land. */
-	addu	$2, CODE, 6*4 - type_FunctionPointer
-	j	$2
-
-	.set	noreorder
-
-	.align	3
-lra:
-	.word	type_ReturnPcHeader
-
-	/* Multiple value return spot, clear stack */
-	move	CSP, ARGS
-	nop
-
-	/* Pass one return value back to C land. */
-	move	v0, A0
-
-	/* Set pseudo-atomic flag. */
-	or	FLAGS, (1<<flag_Atomic)
-
-	/* Save LISP registers. */
-	sw	ALLOC, SAVED_ALLOCATION_POINTER + SYMBOL_VALUE_OFFSET
-	sw	BSP, SAVED_BINDING_STACK_POINTER + SYMBOL_VALUE_OFFSET
-	sw	CSP, SAVED_CONTROL_STACK_POINTER + SYMBOL_VALUE_OFFSET
-	sw	FLAGS, SAVED_FLAGS_REGISTER + SYMBOL_VALUE_OFFSET
-
-	/* Back in foreign function call */
-	addu	t0, NULLREG, T - NIL
-	sw	t0, (FOREIGN_FUNCTION_CALL_ACTIVE - NIL + SYMBOL_VALUE_OFFSET)(NULLREG)
-
-	/* Check for interrupt */
-	and	FLAGS, (0xffff^(1<<flag_Atomic))
-	and	v1, FLAGS, (1<<flag_Interrupted)
-	beq	v1, zero, 1f
-	nop
-
-	/* We were interrupted. Hit the trap. */
-	break	trap_PendingInterrupt
-1:
-
-	.set	reorder
-
-	/* Restore C regs */
-	lw	ra, framesize(sp)
-	lw	s8, framesize-4(sp)
-	lw	gp, framesize-8(sp)
-	lw	s7, framesize-12(sp)
-	lw	s6, framesize-16(sp)
-	lw	s5, framesize-20(sp)
-	lw	s4, framesize-24(sp)
-	lw	s3, framesize-28(sp)
-	lw	s2, framesize-32(sp)
-	lw	s1, framesize-36(sp)
-	lw	s0, framesize-40(sp)
-
-	/* Restore C stack. */
-	addu	sp, framesize
-
-	/* Back we go. */
-	j	ra
-
-	.end	call_into_lisp
-
-/*
- * Transfering control from Lisp into C
- */
-	.text
-	.globl	call_into_c
-	.ent	call_into_c
-call_into_c:
-	.set	noreorder
-	/* Note: the C stack is already set up. */
-	
-	/* Set the pseudo-atomic flag. */
-	or	FLAGS, (1<<flag_Atomic)
-
-	/* Save lisp state in symbols. */
-	sw	ALLOC, (SAVED_ALLOCATION_POINTER - NIL + SYMBOL_VALUE_OFFSET)(NULLREG)
-	sw	BSP, (SAVED_BINDING_STACK_POINTER - NIL + SYMBOL_VALUE_OFFSET)(NULLREG)
-	sw	CSP, (SAVED_CONTROL_STACK_POINTER - NIL + SYMBOL_VALUE_OFFSET)(NULLREG)
-	sw	FLAGS, (SAVED_FLAGS_REGISTER - NIL + SYMBOL_VALUE_OFFSET)(NULLREG)
-
-	/* Mark us as in C land. */
-	addu	t0, NULLREG, T - NIL
-	sw	t0, (FOREIGN_FUNCTION_CALL_ACTIVE - NIL + SYMBOL_VALUE_OFFSET)(NULLREG)
-
-	/* Restore GP */
-	lw	gp, SAVED_GLOBAL_POINTER + SYMBOL_VALUE_OFFSET
-
-	/* Were we interrupted? */
-	and	FLAGS, (0xffff^(1<<flag_Atomic))
-	and	v1, FLAGS, (1<<flag_Interrupted)
-	beq	v1, zero, 1f
-	nop
-
-	/* We were interrupted. Hit the trap. */
-	break	trap_PendingInterrupt
-1:
-
-	.set	reorder
-
-	/* Get first 4 args. */
-	lw	a0, 0(sp)
-	lw	a1, 4(sp)
-	lw	a2, 8(sp)
-	lw	a3, 12(sp)
-
-	/* Into C land we go. */
-	jal	v0
-
-	/* Clear unsaved descriptor regs */
-	move	t0, zero
-	move	t1, zero
-	move	t2, zero
-	move	t3, zero
-	move	t4, zero
-	move	t5, zero
-	move	t6, zero
-	move	t7, zero
-	move	gp, zero
-	move	ra, zero
-
-	.set	noreorder
-
-	/* Restore FLAGS (which set the pseudo-atomic flag) */
-	lw	FLAGS, SAVED_FLAGS_REGISTER + SYMBOL_VALUE_OFFSET
-
-	/* Mark us at in Lisp land. */
-	sw	NULLREG, (FOREIGN_FUNCTION_CALL_ACTIVE - NIL + SYMBOL_VALUE_OFFSET)(NULLREG)
-
-	/* Restore other lisp state. */
-	lw	ALLOC, SAVED_ALLOCATION_POINTER + SYMBOL_VALUE_OFFSET
-	lw	BSP, SAVED_BINDING_STACK_POINTER + SYMBOL_VALUE_OFFSET
-	lw	CSP, SAVED_CONTROL_STACK_POINTER + SYMBOL_VALUE_OFFSET
-
-	/* Check for interrupt */
-	and	FLAGS, (0xffff^(1<<flag_Atomic))
-	and	a0, FLAGS, (1<<flag_Interrupted)
-	beq	a0, zero, 1f
-	nop
-
-	/* We were interrupted. Hit the trap. */
-	break	trap_PendingInterrupt
-1:
-
-	.set	reorder
-
-	/* Return to LISP. */
-	addu	a0, LRA, 4-type_OtherPointer
-	j	a0
-
-	.end	call_into_c
diff --git a/ldb/monitor.c b/ldb/monitor.c
deleted file mode 100644
index 1a4aa8c1fffdb6efd1a1a95b296737cd5b9f2ab8..0000000000000000000000000000000000000000
--- a/ldb/monitor.c
+++ /dev/null
@@ -1,356 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/monitor.c,v 1.2 1990/02/28 18:23:28 wlott Exp $ */
-#include <stdio.h>
-#include <setjmp.h>
-
-
-#include "ldb.h"
-#include "lisp.h"
-#include "vars.h"
-#include "parse.h"
-
-static void call_cmd(), dump_cmd(), print_cmd(), quit(), help(), flush_cmd(), search_cmd(), regs_cmd(), exit_cmd(), throw_cmd();
-
-static struct cmd {
-    char *cmd, *help;
-    void (*fn)();
-} Cmds[] = {
-    {"help", "Display this info", help},
-    {"?", NULL, help},
-    {"call", "call FUNCTION with ARG1, ARG2, ...", call_cmd},
-    {"dump", "dump memory starting at ADDRESS for COUNT words", dump_cmd},
-    {"d", NULL, dump_cmd},
-    {"exit", "Exit this instance of the monitor.", exit_cmd},
-    {"flush", "flush all temp variables.", flush_cmd},
-    {"print", "print object at ADDRESS", print_cmd},
-    {"p", NULL, print_cmd},
-    {"quit", "quit", quit},
-    {"regs", "display current lisp regs.", regs_cmd},
-    {"search", "search for TYPE starting at ADDRESS for a max of COUNT words.", search_cmd},
-    {"s", NULL, search_cmd},
-    {"throw", "Throw to the top level monitor.", throw_cmd},
-    {NULL, NULL, NULL}
-};
-
-
-static int visable(c)
-unsigned char c;
-{
-    if (c < ' ' || c > '~')
-        return ' ';
-    else
-        return c;
-}
-
-static void dump_cmd(ptr)
-char **ptr;
-{
-    static char *lastaddr = 0;
-    static int lastcount = 20;
-
-    char *addr = lastaddr;
-    int count = lastcount, displacement;
-
-    if (more_p(ptr)) {
-        addr = parse_addr(ptr);
-
-        if (more_p(ptr))
-            count = parse_number(ptr);
-    }
-
-    if (count == 0) {
-        printf("COUNT must be non-zero.\n");
-        return;
-    }
-        
-    lastcount = count;
-
-    if (count > 0)
-        displacement = 4;
-    else {
-        displacement = -4;
-        count = -count;
-    }
-
-    while (count-- > 0) {
-        printf("0x%08x: ", addr);
-        if (valid_addr(addr)) {
-            unsigned long *lptr = (unsigned long *)addr;
-            unsigned short *sptr = (unsigned short *)addr;
-            unsigned char *cptr = (unsigned char *)addr;
-
-            printf("0x%08x   0x%04x 0x%04x   0x%02x 0x%02x 0x%02x 0x%02x    %c%c%c%c\n", lptr[0], sptr[0], sptr[1], cptr[0], cptr[1], cptr[2], cptr[3], visable(cptr[0]), visable(cptr[1]), visable(cptr[2]), visable(cptr[3]));
-        }
-        else
-            printf("invalid address\n");
-
-        addr += displacement;
-    }
-
-    lastaddr = addr;
-}
-
-static void print_cmd(ptr)
-char **ptr;
-{
-    lispobj obj = parse_lispobj(ptr);
-    
-    print(obj);
-}
-
-static void regs_cmd(ptr)
-char **ptr;
-{
-    printf("ALLOC=0x%x\n", SymbolValue(SAVED_ALLOCATION_POINTER));
-    printf("CSP=0x%x\n", SymbolValue(SAVED_CONTROL_STACK_POINTER));
-    printf("BSP=0x%x\n", SymbolValue(SAVED_BINDING_STACK_POINTER));
-    printf("FLAGS=0x%x\n", SymbolValue(SAVED_FLAGS_REGISTER));
-}
-
-static void search_cmd(ptr)
-char **ptr;
-{
-    static int lastval = 0, lastcount = 0;
-    static lispobj *start = 0, *end = 0;
-    int val, count;
-    lispobj *addr, obj;
-
-    if (more_p(ptr)) {
-        val = parse_number(ptr);
-        if (val < 0 || val > 0xff) {
-            printf("Can only search for single bytes.\n");
-            return;
-        }
-        if (more_p(ptr)) {
-            addr = (lispobj *)PTR((long)parse_addr(ptr));
-            if (more_p(ptr)) {
-                count = parse_number(ptr);
-            }
-            else {
-                /* Speced value and address, but no count. Only one. */
-                count = -1;
-            }
-        }
-        else {
-            /* Speced a value, but no address, so search same range. */
-            addr = start;
-            count = lastcount;
-        }
-    }
-    else {
-        /* Speced nothing, search again for val. */
-        val = lastval;
-        addr = end;
-        count = lastcount;
-    }
-
-    lastval = val;
-    start = end = addr;
-    lastcount = count;
-
-    printf("searching for 0x%x at 0x%x\n", val, end);
-
-    while ((count == -1 || (count-- > 0)) && valid_addr(end)) {
-        obj = *end;
-        addr = end;
-        end += 2;
-
-        if (((long)obj & 0xff) == val) {
-            printf("found 0x%x at 0x%x:\n", val, addr);
-            if (LowtagOf(obj) == type_OtherImmediate0 ||    LowtagOf(obj) == type_OtherImmediate1)
-                print((long)addr | type_OtherPointer);
-            else
-                print(addr);
-            if (count == -1)
-                return;
-        }
-    }
-}
-
-static void call_cmd(ptr)
-char **ptr;
-{
-    extern lispobj call_into_lisp();
-
-    static lispobj args[16];
-
-    lispobj call_name = parse_lispobj(ptr);
-    lispobj function, result, arg, *argptr;
-    int numargs;
-
-    if (LowtagOf(call_name) == type_OtherPointer && TypeOf(call_name) == type_SymbolHeader) {
-        struct symbol *sym = (struct symbol *)PTR(call_name);
-
-        function = sym->function;
-        if (LowtagOf(function) != type_FunctionPointer) {
-            printf("undefined function: ``%s''\n", (char *)PTR(sym->name) + 8);
-            return;
-        }
-    }
-    else if (LowtagOf(call_name) != type_FunctionPointer) {
-        printf("0x%x is not a function pointer.\n", call_name);
-        return;
-    }
-    else
-        function = call_name;
-
-    numargs = 0;
-    argptr = args;
-    while (more_p(ptr)) {
-        *argptr++ = parse_lispobj(ptr);
-        numargs++;
-    }
-    while (argptr < args + 6)
-        *argptr++ = NIL;
-
-    result = call_into_lisp(call_name, function, args, numargs);
-
-    print(result);
-}
-
-static void flush_cmd()
-{
-    flush_vars();
-}
-
-static void quit()
-{
-    char buf[10];
-
-    printf("Really quit? [n] ");
-    fflush(stdout);
-    fgets(buf, sizeof(buf), stdin);
-    if (buf[0] == 'y' || buf[0] == 'Y')
-        exit(0);
-}
-
-static void help()
-{
-    struct cmd *cmd;
-
-    for (cmd = Cmds; cmd->cmd != NULL; cmd++)
-        if (cmd->help != NULL)
-            printf("%s\t%s\n", cmd->cmd, cmd->help);
-}
-
-static void throw_cmd()
-{
-    void throw_to_top();
-    char buf[10];
-
-    printf("Really throw? [n] ");
-    fflush(stdout);
-    fgets(buf, sizeof(buf), stdin);
-    if (buf[0] == 'y' || buf[0] == 'Y')
-        throw_to_top(0);
-}
-
-static int done;
-
-static void exit_cmd()
-{
-    done = TRUE;
-}
-
-static void sub_monitor(csp, bsp)
-unsigned long csp, bsp;
-{
-    extern char *egets();
-    struct cmd *cmd, *found;
-    char *line, *ptr, *token;
-    static char *last = NULL;
-    int ambig;
-    unsigned long new;
-
-    while (!done) {
-        if ((new = SymbolValue(SAVED_CONTROL_STACK_POINTER)) != csp) {
-            printf("CSP changed from 0x%x to 0x%x; Restoring.\n", csp, new);
-            SetSymbolValue(SAVED_CONTROL_STACK_POINTER, csp);
-        }
-        if ((new = SymbolValue(SAVED_BINDING_STACK_POINTER)) != bsp) {
-            printf("BSP changed from 0x%x to 0x%x; Restoring.\n", bsp, new);
-            SetSymbolValue(SAVED_BINDING_STACK_POINTER, bsp);
-        }
-
-        printf("ldb> ");
-        fflush(stdout);
-        line = egets();
-        if (line == NULL) {
-            last = NULL;
-            putchar('\n');
-            continue;
-        }
-        ptr = line;
-        if ((token = parse_token(&ptr)) == NULL) {
-            if (last == NULL)
-                continue;
-            token = last;
-        }
-        ambig = 0;
-        found = NULL;
-        for (cmd = Cmds; cmd->cmd != NULL; cmd++) {
-            if (strcmp(token, cmd->cmd) == 0) {
-                found = cmd;
-                ambig = 0;
-                break;
-            }
-            else if (strncmp(token, cmd->cmd, strlen(token)) == 0) {
-                if (found)
-                    ambig = 1;
-                else
-                    found = cmd;
-            }
-        }
-        if (ambig)
-            printf("``%s'' is ambiguous.\n", token);
-        else if (found == NULL)
-            printf("unknown command: ``%s''\n", token);
-        else {
-            last = found->cmd;
-            (*found->fn)(&ptr);
-        }
-    }
-}
-
-
-static jmp_buf topbuf;
-static jmp_buf curbuf;
-static int level = 0;
-
-void monitor()
-{
-    jmp_buf oldbuf;
-    unsigned long csp, bsp;
-
-    csp = SymbolValue(SAVED_CONTROL_STACK_POINTER);
-    bsp = SymbolValue(SAVED_BINDING_STACK_POINTER);
-
-    bcopy(curbuf, oldbuf, sizeof(oldbuf));
-
-    if (level == 0) {
-        setjmp(topbuf);
-        level = 0;
-    }
-
-    level++;
-    printf("LDB monitor (level=%d)\n", level);
-
-    setjmp(curbuf);
-
-    sub_monitor(csp, bsp);
-
-    done = FALSE;
-
-    bcopy(oldbuf, curbuf, sizeof(curbuf));
-
-    level--;
-}
-
-void throw_to_monitor()
-{
-    longjmp(curbuf, 1);
-}
-
-void throw_to_top()
-{
-    longjmp(topbuf, 1);
-}
diff --git a/ldb/parse.c b/ldb/parse.c
deleted file mode 100644
index de51683bab82f699b917bca86cfd42c78256d62f..0000000000000000000000000000000000000000
--- a/ldb/parse.c
+++ /dev/null
@@ -1,259 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/parse.c,v 1.1 1990/02/24 19:37:26 wlott Exp $ */
-#include <stdio.h>
-
-#include "ldb.h"
-#include "lisp.h"
-#include "vars.h"
-#include "parse.h"
-
-
-static void skip_ws(ptr)
-char **ptr;
-{
-    while (**ptr <= ' ' && **ptr != '\0')
-        (*ptr)++;
-}
-
-static boolean string_to_long(token, value)
-char *token;
-long *value;
-{
-    int base, digit;
-    long num;
-    char *ptr;
-
-    if (token == 0)
-        return FALSE;
-
-    if (token[0] == '0')
-        if (token[1] == 'x') {
-            base = 16;
-            token += 2;
-        }
-        else {
-            base = 8;
-            token++;
-        }
-    else if (token[0] == '#') {
-        switch (token[1]) {
-            case 'x':
-            case 'X':
-                base = 16;
-                token += 2;
-                break;            
-            case 'o':
-            case 'O':
-                base = 8;
-                token += 2;
-                break;
-            default:
-                return FALSE;
-        }
-    }
-    else
-        base = 10;
-
-    num = 0;
-    ptr = token;
-    while (*ptr != '\0') {
-        if (*ptr >= 'a' && *ptr <= 'f')
-            digit = *ptr + 10 - 'a';
-        else if (*ptr >= 'A' && *ptr <= 'F')
-            digit = *ptr + 10 - 'A';
-        else if (*ptr >= '0' && *ptr <= '9')
-            digit = *ptr - '0';
-        else
-            return FALSE;
-        if (digit < 0 || digit >= base)
-            return FALSE;
-
-        ptr++;
-        num = num * base + digit;
-    }
-
-    *value = num;
-    return TRUE;
-}
-
-static boolean lookup_variable(name, result)
-char *name;
-lispobj *result;
-{
-    struct var *var = lookup_by_name(name);
-
-    if (var == NULL)
-        return FALSE;
-    else {
-        *result = var_value(var);
-        return TRUE;
-    }
-}
-
-
-boolean more_p(ptr)
-char **ptr;
-{
-    skip_ws(ptr);
-
-    if (**ptr == '\0')
-        return FALSE;
-    else
-        return TRUE;
-}
-
-char *parse_token(ptr)
-char **ptr;
-{
-    char *token;
-
-    skip_ws(ptr);
-    
-    if (**ptr == '\0')
-        return NULL;
-
-    token = *ptr;
-
-    while (**ptr > ' ')
-        (*ptr)++;
-
-    if (**ptr != '\0') {
-        **ptr = '\0';
-        (*ptr)++;
-    }
-
-    return token;
-}
-
-#if 0
-static boolean number_p(token)
-char *token;
-{
-    char *okay;
-
-    if (token == NULL)
-        return FALSE;
-
-    okay = "abcdefABCDEF987654321d0";
-
-    if (token[0] == '0')
-        if (token[1] == 'x' || token[1] == 'X')
-            token += 2;
-        else {
-            token++;
-            okay += 14;
-        }
-    else if (token[0] == '#') {
-        switch (token[1]) {
-            case 'x':
-            case 'X':
-                break;
-            case 'o':
-            case 'O':
-                okay += 14;
-                break;
-            default:
-                return FALSE;
-        }
-    }
-    else
-        okay += 12;
-
-    while (*token != '\0')
-        if (index(okay, *token++) == NULL)
-            return FALSE;
-    return TRUE;
-}
-#endif
-
-long parse_number(ptr)
-char **ptr;
-{
-    char *token = parse_token(ptr);
-    long result;
-
-    if (token == NULL) {
-        printf("Expected a number.\n");
-        throw_to_monitor();
-    }
-    else if (string_to_long(token, &result))
-        return result;
-    else {
-        printf("Invalid number: ``%s''\n", token);
-        throw_to_monitor();
-    }
-}
-
-char *parse_addr(ptr)
-char **ptr;
-{
-    char *token = parse_token(ptr);
-    long result;
-
-    if (token == NULL) {
-        printf("Expected an address.\n");
-        throw_to_monitor();
-    }
-    else if (token[0] == '$') {
-        if (!lookup_variable(token+1, (lispobj *)&result)) {
-            printf("Unknown variable: ``%s''\n", token);
-            throw_to_monitor();
-        }
-        result &= ~7;
-    }
-    else {
-        if (!string_to_long(token, &result)) {
-            printf("Invalid number: ``%s''\n", token);
-            throw_to_monitor();
-        }
-        result &= ~3;
-    }
-
-    if (!valid_addr(result)) {
-        printf("Invalid address: 0x%x\n", result);
-        throw_to_monitor();
-    }
-
-    return (char *)result;
-}
-
-lispobj parse_lispobj(ptr)
-char **ptr;
-{
-    char *token = parse_token(ptr);
-    long pointer;
-    lispobj result;
-
-    if (token == NULL) {
-        printf("Expected an object.\n");
-        throw_to_monitor();
-    }
-    else if (token[0] == '$') {
-        if (!lookup_variable(token+1, &result)) {
-            printf("Unknown variable: ``%s''\n", token);
-            throw_to_monitor();
-        }
-    }
-    else if (token[0] == '*') {
-        if (string_to_long(token+1, &pointer)) {
-            pointer &= ~3;
-            if (valid_addr(pointer))
-                result = *(lispobj *)pointer;
-            else {
-                printf("Invalid address: ``%s''\n", token+1);
-                throw_to_monitor();
-            }
-        }
-        else {
-            printf("Invalid address: ``%s''\n", token+1);
-            throw_to_monitor();
-        }
-    }
-    else {
-        if (!string_to_long(token, (long *)&result)) {
-            printf("Invalid number: ``%s''\n", token);
-            throw_to_monitor();
-        }
-    }
-
-    return result;
-}
diff --git a/ldb/parse.h b/ldb/parse.h
deleted file mode 100644
index ebd096bd104a97156378ae35e998d1078c36bce8..0000000000000000000000000000000000000000
--- a/ldb/parse.h
+++ /dev/null
@@ -1,9 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/parse.h,v 1.1 1990/02/24 19:37:27 wlott Exp $ */
-
-/* All parse routines take a char ** as their only argument */
-
-boolean more_p();
-char *parse_token();
-lispobj parse_lispobj();
-char *parse_addr();
-long parse_number();
diff --git a/ldb/print.c b/ldb/print.c
deleted file mode 100644
index 39f8db9c1f08e568a72e605640bdd3f3a8514598..0000000000000000000000000000000000000000
--- a/ldb/print.c
+++ /dev/null
@@ -1,348 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/print.c,v 1.3 1990/02/28 18:26:09 wlott Exp $ */
-#include <stdio.h>
-
-#include "ldb.h"
-#include "print.h"
-#include "lisp.h"
-#include "vars.h"
-
-static int max_lines = 20, cur_lines = 0;
-static int max_depth = 5, cur_depth = 0;
-static boolean dont_decend = FALSE, skip_newline = FALSE;
-static cur_clock = 0;
-
-static void print_obj();
-
-#define NEWLINE if (continue_p()) newline(NULL); else return;
-
-char *lowtag_Names[] = {
-    "even fixnum",
-    "function pointer",
-    "other immediate [0]",
-    "list pointer",
-    "odd fixnum",
-    "structure pointer",
-    "other immediate [1]",
-    "other pointer"
-};
-
-char *subtype_Names[] = {
-    "subtype 0",
-    "bignum",
-    "ratio",
-    "single float",
-    "double float",
-    "complex",
-    "simple-array",
-    "simple-string",
-    "simple-bit-vector",
-    "simple-vector",
-    "(simple-array (unsigned-byte 2) (*))",
-    "(simple-array (unsigned-byte 4) (*))",
-    "(simple-array (unsigned-byte 8) (*))",
-    "(simple-array (unsigned-byte 16) (*))",
-    "(simple-array (unsigned-byte 32) (*))",
-    "(simple-array single-float (*))",
-    "(simple-array double-float (*))",
-    "complex-string",
-    "complex-bit-vector",
-    "(array * (*))",
-    "array",
-    "code header",
-    "function header",
-    "closure function header",
-    "return PC header",
-    "closure header",
-    "value cell header",
-    "symbol header",
-    "character",
-    "SAP",
-    "unbound marker"
-};
-
-static void indent(in)
-int in;
-{
-    static char *spaces = "                                                                ";
-
-    while (in > 64) {
-        fputs(spaces, stdout);
-        in -= 64;
-    }
-    if (in != 0)
-        fputs(spaces + 64 - in, stdout);
-}
-
-static boolean continue_p()
-{
-    char buffer[256];
-
-    if (cur_depth >= max_depth || dont_decend)
-        return FALSE;
-
-    if (skip_newline)
-        skip_newline = FALSE;
-    else
-        putchar('\n');
-
-    if (cur_lines >= max_lines) {
-        printf("More? [y] ");
-        fflush(stdout);
-
-        gets(buffer);
-
-        if (buffer[0] == 'n' || buffer[0] == 'N')
-            throw_to_monitor();
-        else
-            cur_lines = 0;
-    }
-
-    return TRUE;
-}
-
-static void newline(label)
-char *label;
-{
-    cur_lines++;
-    if (label != NULL)
-        fputs(label, stdout);
-    putchar('\t');
-    indent(cur_depth * 2);
-}
-
-static void print_fixnum(obj)
-lispobj obj;
-{
-    printf(": %d", obj>>2);
-}
-
-static void print_otherimm(obj)
-lispobj obj;
-{
-    int c;
-
-    printf(", %s", subtype_Names[TypeOf(obj)>>3]);
-
-    switch (TypeOf(obj)) {
-        case type_BaseCharacter:
-            printf(": font=0x%x, bits=0x%x, char=0x%x", (obj>>24)&0xff, (obj>>16)&0xff, c = ((obj>>8)&0xff));
-            if (c >= ' ' && c <= '~')
-                printf(" (%c)", c);
-            break;
-
-        case type_Sap:
-        case type_UnboundMarker:
-            break;
-
-        default:
-            printf(": data=%d", (obj>>8)&0xffffff);
-            break;
-    }
-}
-
-static void print_list(obj)
-lispobj obj;
-{
-    if (!valid_addr(obj))
-        printf(" (invalid address)");
-    else if (obj == NIL)
-        printf(" (NIL)");
-    else {
-        struct cons *cons = (struct cons *)PTR(obj);
-
-        print_obj("car: ", cons->car);
-        print_obj("cdr: ", cons->cdr);
-    }
-}
-
-static void print_struct(obj)
-lispobj obj;
-{
-}
-
-static void print_unused(obj)
-lispobj obj;
-{
-}
-
-static void print_slots(slots, count, ptr)
-char **slots;
-int count;
-long *ptr;
-{
-    while (count-- > 0)
-        if (*slots)
-            print_obj(*slots++, *ptr++);
-        else
-            print_obj("???: ", *ptr++);
-}
-
-static char *symbol_slots[] = {"value: ", "function: ", "plist: ", "name: ", "package: ", NULL};
-static char *ratio_slots[] = {"numer: ", "denom: ", NULL};
-static char *complex_slots[] = {"real: ", "imag: ", NULL};
-static char *code_slots[] = {"words: ", "entry: ", "debug: ", NULL};
-static char *fn_slots[] = {"self: ", "next: ", "name: ", "arglist: ", "type: ", NULL};
-static char *closure_slots[] = {"fn: ", NULL};
-
-static void print_otherptr(obj)
-lispobj obj;
-{
-    if (!valid_addr(obj))
-        printf(" (invalid address)");
-    else {
-        unsigned long *ptr = (unsigned long *)PTR(obj);
-        unsigned long header = *ptr++;
-        unsigned long length = (*ptr) >> 2;
-        int count = header>>8, type = TypeOf(header), index;
-        boolean raw;
-        char *cptr, buffer[16];
-
-        print_obj("header: ", header);
-        if (LowtagOf(header) != type_OtherImmediate0 && LowtagOf(header) != type_OtherImmediate1) {
-            NEWLINE;
-            printf("(invalid header object)");
-            return;
-        }
-
-        switch (type) {
-            case type_Bignum:
-                ptr += count;
-                NEWLINE;
-                printf("0x");
-                while (count-- > 0)
-                    printf("%08x", *--ptr);
-                break;
-
-            case type_Ratio:
-                print_slots(ratio_slots, count, ptr);
-                break;
-
-            case type_Complex:
-                print_slots(complex_slots, count, ptr);
-                break;
-
-            case type_SymbolHeader:
-                print_slots(symbol_slots, count, ptr);
-                break;
-
-            case type_SingleFloat:
-                NEWLINE;
-                printf("%f", *(float *)ptr);
-                break;
-
-            case type_DoubleFloat:
-                NEWLINE;
-                printf("%lf", *(double *)ptr);
-                break;
-
-            case type_SimpleString:
-                NEWLINE;
-                cptr = (char *)(ptr+1);
-                putchar('\"');
-                while (length-- > 0)
-                    putchar(*cptr++);
-                putchar('\"');
-                break;
-
-            case type_SimpleVector:
-                NEWLINE;
-                printf("length = %d", length);
-                ptr++;
-                index = 0;
-                while (length-- > 0) {
-                    sprintf(buffer, "%d: ", index++);
-                    print_obj(buffer, *ptr++);
-                }
-                break;
-
-            case type_SimpleArray:
-            case type_SimpleBitVector:
-            case type_SimpleArrayUnsignedByte2:
-            case type_SimpleArrayUnsignedByte4:
-            case type_SimpleArrayUnsignedByte8:
-            case type_SimpleArrayUnsignedByte16:
-            case type_SimpleArrayUnsignedByte32:
-            case type_SimpleArraySingleFloat:
-            case type_SimpleArrayDoubleFloat:
-            case type_ComplexString:
-            case type_ComplexBitVector:
-            case type_ComplexVector:
-            case type_ComplexArray:
-                break;
-
-            case type_CodeHeader:
-                print_slots(code_slots, count-1, ptr);
-                break;
-
-            case type_FunctionHeader:
-            case type_ClosureFunctionHeader:
-                print_slots(fn_slots, 5, ptr);
-                break;
-
-            case type_ReturnPcHeader:
-                break;
-
-            case type_ClosureHeader:
-                print_slots(closure_slots, count, ptr);
-                break;
-
-            case type_Sap:
-                NEWLINE;
-                printf("0x%08x", *ptr);
-                break;
-
-            case type_BaseCharacter:
-            case type_UnboundMarker:
-                NEWLINE;
-                printf("pointer to an immediate?\n");
-                break;
-        }
-    }
-}
-
-static void print_obj(prefix, obj)
-char *prefix;
-lispobj obj;
-{
-    static void (*Fns[])() = {print_fixnum, print_otherptr, print_otherimm, print_list, print_fixnum, print_struct, print_unused, print_otherptr};
-    int type = LowtagOf(obj);
-    struct var *var = lookup_by_obj(obj);
-    char buffer[256];
-
-    if (!continue_p())
-        return;
-
-    if (var != NULL && var_clock(var) == cur_clock)
-        dont_decend = TRUE;
-
-    if (var == NULL && (obj & type_FunctionPointer & type_ListPointer & type_StructurePointer & type_OtherPointer) != 0)
-        var = define_var(NULL, obj, FALSE);
-
-    if (var != NULL) {
-        var_setclock(var, cur_clock);
-        sprintf(buffer, "$%s=", var_name(var));
-        newline(buffer);
-    }
-    else
-        newline(NULL);
-
-    printf("%s0x%x: %s", prefix, obj, lowtag_Names[type]);
-    cur_depth++;
-    (*Fns[type])(obj);
-    cur_depth--;
-    dont_decend = FALSE;
-}
-
-void print(obj)
-lispobj obj;
-{
-    cur_clock++;
-    cur_depth = 0;
-    cur_lines = 0;
-    dont_decend = FALSE;
-    skip_newline = TRUE;
-
-    print_obj("", obj);
-
-    putchar('\n');
-}
diff --git a/ldb/print.h b/ldb/print.h
deleted file mode 100644
index c66202e00c3f976117f1a8f66b79529411ae7b80..0000000000000000000000000000000000000000
--- a/ldb/print.h
+++ /dev/null
@@ -1,5 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/print.h,v 1.1 1990/02/24 19:37:30 wlott Exp $ */
-
-extern char *lowtag_Names[], *subtype_Names[];
-
-extern void print();
diff --git a/ldb/test.c b/ldb/test.c
deleted file mode 100644
index 59330dddc04d01d538ae49a8c34c28d171b947c6..0000000000000000000000000000000000000000
--- a/ldb/test.c
+++ /dev/null
@@ -1,62 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/test.c,v 1.1 1990/02/24 19:37:31 wlott Exp $ */
-/* Extra random routines for testing stuff. */
-
-#include <signal.h>
-#include <mips/cpu.h>
-
-#include "lisp.h"
-#include "ldb.h"
-
-static char *signames[] = {
-    "<Unused>", "SIGHUP", "SIGINT", "SIGQUIT", "SIGILL", "SIGTRAP",
-    "SIGIOT", "SIGEMT", "SIGFPE", "SIGKILL", "SIGBUS", "SIGSEGV",
-    "SIGSYS", "SIGPIPE", "SIGALRM", "SIGTERM", "SIGURG", "SIGSTOP",
-    "SIGTSTP", "SIGCONT", "SIGCHLD", "SIGTTIN", "SIGTTOU", "SIGIO",
-    "SIGXCPU", "SIGXFSZ", "SIGVTALRM", "SIGPROF", "SIGWINCH",
-    "SIGUSR1", "SIGUSR2"
-};
-
-
-signal_handler(signal, code, context)
-int signal, code;
-struct sigcontext *context;
-{
-    int mask;
-    unsigned long bad_inst;
-
-    printf("Hit with %s, code = %d, context = 0x%x\n", signames[signal], code, context);
-
-    if (context->sc_cause & CAUSE_BD)
-        bad_inst = *(unsigned long *)(context->sc_pc + 4);
-    else
-        bad_inst = *(unsigned long *)(context->sc_pc);
-
-    if ((bad_inst >> 26) == 0 && (bad_inst & 0x3f) == 0xd) {
-        printf("Hit a break.  Use ``exit'' to continue.\n");
-        if (context->sc_cause & CAUSE_BD)
-            emulate_branch(context, *(unsigned long *)context->sc_pc);
-        else
-            context->sc_pc += 4;
-    }
-
-    mask = sigsetmask(0);
-
-    monitor();
-
-    sigsetmask(mask);
-}
-
-test_init()
-{
-    extern int throw_to_top(), throw_to_monitor();
-
-    install_handler(SIGINT, signal_handler);
-    install_handler(SIGQUIT, throw_to_top);
-    install_handler(SIGTRAP, signal_handler);
-}
-
-
-cacheflush()
-{
-    /* This is supposed to be defined, but is not. */
-}
diff --git a/ldb/vars.c b/ldb/vars.c
deleted file mode 100644
index d7b689d15e2116427bc27e96ad69b3da73ce02f0..0000000000000000000000000000000000000000
--- a/ldb/vars.c
+++ /dev/null
@@ -1,184 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/vars.c,v 1.1 1990/02/24 19:37:32 wlott Exp $ */
-#include <stdio.h>
-
-#include "ldb.h"
-#include "lisp.h"
-#include "vars.h"
-
-#define NAME_BUCKETS 31
-#define OBJ_BUCKETS 31
-
-static struct var *NameHash[NAME_BUCKETS], *ObjHash[OBJ_BUCKETS];
-static int tempcntr = 1;
-
-struct var {
-    lispobj obj, (*update_fn)();
-    char *name;
-    long clock;
-    boolean map_back, permanent;
-
-    struct var *nnext; /* Next in name list */
-    struct var *onext; /* Next in object list */
-};
-
-static int hash_name(name)
-unsigned char *name;
-{
-    unsigned long value = 0;
-
-    while (*name != '\0') {
-        value = (value << 1) ^ *name++;
-        value = (value & (1-(1<<24))) ^ (value >> 24);
-    }
-
-    return value % NAME_BUCKETS;
-}
-
-static int hash_obj(obj)
-lispobj obj;
-{
-    return (long)obj % OBJ_BUCKETS;
-}
-
-
-void flush_vars()
-{
-    int index;
-    struct var *var, *next, *perm = NULL;
-
-    /* Note: all vars in the object hash table also appear in the name hash table, so if we free everything in the name hash table, we free everything in the object hash table. */
-
-    for (index = 0; index < NAME_BUCKETS; index++)
-        for (var = NameHash[index]; var != NULL; var = next) {
-            next = var->nnext;
-            if (var->permanent) {
-                var->nnext = perm;
-                perm = var;
-            }
-            else {
-                free(var->name);
-                free(var);
-            }
-        }
-    bzero(NameHash, sizeof(NameHash));
-    bzero(ObjHash, sizeof(ObjHash));
-    tempcntr = 1;
-
-    for (var = perm; var != NULL; var = next) {
-        next = var->nnext;
-        index = hash_name(var->name);
-        var->nnext = NameHash[index];
-        NameHash[index] = var;
-        if (var->map_back) {
-            index = hash_obj(var->obj);
-            var->onext = ObjHash[index];
-            ObjHash[index] = var;
-        }
-    }
-}
-
-struct var *lookup_by_name(name)
-char *name;
-{
-    struct var *var;
-
-    for (var = NameHash[hash_name(name)]; var != NULL; var = var->nnext)
-        if (strcmp(var->name, name) == 0)
-            return var;
-    return NULL;
-}
-
-struct var *lookup_by_obj(obj)
-lispobj obj;
-{
-    struct var *var;
-
-    for (var = ObjHash[hash_obj(obj)]; var != NULL; var = var->onext)
-        if (var->obj == obj)
-            return var;
-    return NULL;
-}
-
-static struct var *make_var(name, perm)
-char *name;
-boolean perm;
-{
-    struct var *var = (struct var *)malloc(sizeof(struct var));
-    char buffer[256];
-    int index;
-
-    if (name == NULL) {
-        sprintf(buffer, "%d", tempcntr++);
-        name = buffer;
-    }
-    var->name = (char *)malloc(strlen(name)+1);
-    strcpy(var->name, name);
-    var->clock = 0;
-    var->permanent = perm;
-    var->map_back = FALSE;
-    
-    index = hash_name(name);
-    var->nnext = NameHash[index];
-    NameHash[index] = var;
-
-    return var;
-}    
-
-struct var *define_var(name, obj, perm)
-char *name;
-lispobj obj;
-boolean perm;
-{
-    struct var *var = make_var(name, perm);
-    int index;
-
-    var->obj = obj;
-
-    if (lookup_by_obj(obj) == NULL) {
-        var->map_back = TRUE;
-        index = hash_obj(obj);
-        var->onext = ObjHash[index];
-        ObjHash[index] = var;
-    }
-
-    return var;
-}
-
-struct var *define_dynamic_var(name, updatefn, perm)
-char *name;
-lispobj (*updatefn)();
-boolean perm;
-{
-    struct var *var = make_var(name, perm);
-
-    var->update_fn = updatefn;
-
-    return var;
-}
-
-char *var_name(var)
-struct var *var;
-{
-    return var->name;
-}
-
-lispobj var_value(var)
-struct var *var;
-{
-    if (var->update_fn != NULL)
-        var->obj = (*var->update_fn)(var);
-    return var->obj;
-}
-
-long var_clock(var)
-struct var *var;
-{
-    return var->clock;
-}
-
-void var_setclock(var, val)
-struct var *var;
-long val;
-{
-    var->clock = val;
-}
diff --git a/ldb/vars.h b/ldb/vars.h
deleted file mode 100644
index c83eb90a176282715251c704ed27315b41f6c475..0000000000000000000000000000000000000000
--- a/ldb/vars.h
+++ /dev/null
@@ -1,13 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/vars.h,v 1.1 1990/02/24 19:37:33 wlott Exp $ */
-
-
-extern void flush_vars();
-extern struct var *lookup_by_name(/* name */);
-extern struct var *lookup_by_obj(/* obj */);
-extern struct var *define_var(/* name, obj, perm */);
-extern struct var *define_dynamic_var(/* name, update_fn, perm */);
-
-extern char *var_name();
-extern lispobj var_value();
-extern long var_clock();
-extern void var_setclock();
diff --git a/ldb/version.c b/ldb/version.c
deleted file mode 100644
index 6ecb66060a5d9b93c6e2e9b9624d3be5258ece42..0000000000000000000000000000000000000000
--- a/ldb/version.c
+++ /dev/null
@@ -1,2 +0,0 @@
-/* $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/ldb/Attic/version.c,v 1.1 1990/02/24 19:37:34 wlott Exp $ */
-int version = VERSION;
diff --git a/tools/comcom.lisp b/tools/comcom.lisp
deleted file mode 100644
index 53fbad82c90631a5774f581473ec0ab48ab2d076..0000000000000000000000000000000000000000
--- a/tools/comcom.lisp
+++ /dev/null
@@ -1,151 +0,0 @@
-;;; -*- Package: User -*-
-;;;
-(in-package "USER")
-
-(with-compiler-log-file ("c:compile-compiler.log")
-
-(unless *new-compile*
-  (comf "ncode:fdefinition")
-  (load "ncode:extensions.lisp")
-  (comf "c:globaldb" :load t)
-  (unless (boundp 'ext::*info-environment*)
-    (c::globaldb-init))
-
-  (comf "c:patch")
-
-  (comf "ncode:macros" :load t)
-  (comf "ncode:extensions" :bootstrap-macros :both)
-  (load "ncode:extensions.fasl")
-  (comf "ncode:struct" :load t)
-  (comf "c:macros" :load t :bootstrap-macros :both))
-
-(when *new-compile*
-  (comf "ncode:globals" :always-once t) ; For global variables.
-  (comf "ncode:struct" :always-once t) ; For structures.
-  (comf "c:globals" :always-once t)
-  (comf "c:proclaim" :always-once t)) ; For COOKIE structure.
-
-(comf "c:type" :always-once *new-compile*)
-(comf "c:rt/vm-type")
-(comf "c:type-init")
-(comf "c:sset" :always-once *new-compile*)
-(comf "c:node" :always-once *new-compile*)
-(comf "c:ctype")
-#-new-compiler
-(comf "c:knownfun" :always-once *new-compile*)
-(comf "c:fndb")
-(comf "c:main")
-
-#-new-compiler
-(unless *new-compile*
-  (comf "c:proclaim" :load t))
-
-(comf "c:ir1tran")
-(comf "c:ir1util" :bootstrap-macros :both)
-(comf "c:ir1opt")
-(comf "c:ir1final")
-(comf "c:srctran")
-(comf "c:seqtran")
-(comf "c:typetran")
-(comf "c:locall")
-(comf "c:dfo")
-(comf "c:checkgen")
-(comf "c:constraint")
-(comf "c:envanal")
-(comf "c:rt/parms")
-(comf "c:vop" :always-once *new-compile*)
-
-(comf "c:vmdef" :load t :bootstrap-macros :both)
-
-(comf "c:tn" :bootstrap-macros :both)
-(comf "c:bit-util")
-(comf "c:life")
-
-(comf "c:assembler"
-      :load t
-      :bootstrap-macros :both
-      :always-once *new-compile*)
-
-(comf "ncode:debug-info"
-      :load t
-      :bootstrap-macros :both
-      :always-once *new-compile*)
-
-(comf "c:rt/assem-insts" :load t)
-
-#+new-compiler
-(when *new-compile*
-  (comf "c:eval-comp")
-  (comf "c:eval" :bootstrap-macros :both)
-  (let ((c:*compile-time-define-macros* nil))
-    (comf "c:macros" :load t)))
-
-
-(comf "c:aliencomp")
-(comf "c:debug-dump")
-
-(unless *new-compile*
-  (comf "ncode:constants" :load t :proceed t)
-  (comf "assem:rompconst" :load t :proceed t)
-  (comf "assem:assembler")
-  (comf "c:fop"))
-
-(comf "c:rt/assem-macs" :load t :bootstrap-macros :both)
-
-(comf "c:rt/dump")
-
-(when *new-compile*
-  (comf "c:rt/core"))
-
-(comf "c:rt/vm" :always-once *new-compile*)
-(comf "c:rt/miscop")
-(comf "c:rt/move")
-(comf "c:rt/subprim")
-(comf "c:rt/values")
-(comf "c:rt/memory")
-(comf "c:rt/cell")
-(comf "c:rt/call")
-(comf "c:rt/nlx")
-(comf "c:rt/print")
-(comf "c:rt/array")
-(comf "c:rt/pred")
-(comf "c:rt/type-vops")
-(comf "c:rt/arith")
-(comf "c:rt/system")
-(comf "c:rt/char")
-(comf "c:gtn")
-(comf "c:ltn")
-(comf "c:stack")
-(comf "c:control")
-(comf "c:entry")
-(comf "c:ir2tran")
-(comf "c:rt/vm-tran")
-(comf "c:pack")
-(comf "c:codegen")
-(comf "c:debug")
-
-#-new-compiler
-(unless *new-compile* 
-  (comf "c:rt/genesis"))
-
-#+new-compiler
-(comf "c:rt/genesis")
-
-(unless *new-compile*
-  (comf "ncode:defstruct")
-  (comf "ncode:error")
-  (comf "ncode:defrecord")
-  (comf "ncode:defmacro")
-  (comf "ncode:alieneval")
-  (comf "ncode:c-call")
-  (comf "ncode:salterror")
-  (comf "ncode:sysmacs")
-  (comf "ncode:machdef")
-  (comf "ncode:mmlispdefs")
-  (comf "nicode:machdefs")
-  (comf "nicode:netnamedefs")
-  (comf "c:globaldb" :output-file "c:boot-globaldb.fasl"
-	:bootstrap-macros :both))
-
-
-); with-compiler-error-log
diff --git a/tools/setup.lisp b/tools/setup.lisp
deleted file mode 100644
index 0c50463428c9bee9dc14aa0b12c51fa0930c474f..0000000000000000000000000000000000000000
--- a/tools/setup.lisp
+++ /dev/null
@@ -1,245 +0,0 @@
-;;; -*- Package: USER -*-
-;;;
-;;;    Set up package environment and search lists for compiler.  Also some
-;;; compilation utilities.
-;;;
-(in-package "USER")
-
-(in-package "EVAL")
-(export '(internal-eval interpreted-function-p
-			interpreted-function-lambda-expression
-			interpreted-function-closure
-			interpreted-function-name
-			interpreted-function-arglist
-			make-interpreted-function))
-#-new-compiler
-(import '*eval-stack-top* (find-package "LISP"))
-
-#-new-compiler
-(defmacro indirect-value (value-cell)
-  `(car ,value-cell))
-
-#-new-compiler
-(defmacro eval-stack-local (fp offset)
-  `(svref *eval-stack* (+ ,fp ,offset)))
-
-#-new-compiler
-(in-package "C" :use '("EXTENSIONS" "SYSTEM" "LISP"))
-
-#-new-compiler
-(export '(compile-for-eval lambda-eval-info-frame-size
-	  lambda-eval-info-args-passed lambda-eval-info-entries
-	  entry-node-info-st-top entry-node-info-nlx-tag))
-
-#-new-compiler
-(setq clc::*peep-enable* t)
-#-new-compiler
-(setq clc::*inline-enable* t)
-#-new-compiler
-(setq ext:*safe-defstruct-accessors* nil)
-
-#-new-compiler
-(import '(lisp::boolean lisp::enumeration))
-
-;;; ### system patch...
-#-new-compiler
-(load "/../fred/usr/ram/hash.fasl")
-
-(defun zap-sym (name pkg)
-  (let ((found (find-symbol name (find-package pkg))))
-    (when (and found
-	       (eq (symbol-package found) (find-package pkg)))
-      (unintern found pkg))))
-
-#-new-compiler
-(progn
-  (zap-sym "ABORT" "C")
-  (zap-sym "CONCAT-PNAMES" "LISP")
-  (zap-sym "ONCE-ONLY" "COMPILER")
-  (zap-sym "UNIX-PIPE" "COMPILER")
-  (zap-sym "MAKE-UNIX-PIPE" "MACH")
-  (zap-sym "UNIX-PIPE-P" "MACH"))
-  
-#-new-compiler
-(let ((sym (find-symbol "%CHARACTER-TYPE" (find-package "SYSTEM"))))
-  (when sym
-    (makunbound sym)
-    (unintern sym (find-package "SYSTEM"))))
-
-
-#-new-compiler
-(in-package "EXTENSIONS")
-#-new-compiler
-(export '(info clear-info define-info-class define-info-type))
-#-new-compiler
-(export '(ignorable truly-the maybe-inline))
-#-new-compiler
-(export '(unix-pipe make-unix-pipe unix-pipe-p))
-#-new-compiler
-(export '(lisp::with-compilation-unit lisp::debug-info) "LISP")
-
-#-new-compiler
-(export '(system::%g-vector-structure-name-slot
-	  system::find-if-in-closure
-	  system::*file-input-handlers*)
-	"SYSTEM")
-
-#-new-compiler
-(let ((found (find-symbol "CONCAT-PNAMES" (find-package "LISP"))))
-  (when found
-    (unintern found (find-package "LISP"))))
-
-#-new-compiler
-(in-package "LISP")
-#-new-compiler
-(import '(
-	  ct-a-val-sap ct-a-val-type ct-a-val-offset ct-a-val-size
-	  ct-a-val-p ct-a-val make-ct-a-val ct-a-val-alien
-	  check<= check= %alien-indirect %bind-aligned-sap
-	  naturalize-integer deport-integer naturalize-boolean deport-boolean
-	  sap-ref-8 sap-ref-16 sap-ref-32
-	  signed-sap-ref-8 signed-sap-ref-16 signed-sap-ref-32 int-sap sap-int
-	  %set-sap-ref-8 %set-sap-ref-16 %set-sap-ref-32
-	  %set-alien-access %standard-char-p %string-char-p
-	  
-	  *alien-eval-when* make-alien alien-type alien-size alien-address
-	  copy-alien dispose-alien defalien alien-value
-	  alien-bind defoperator alien-index alien-indirect
-	  bits bytes words long-words port perq-string
-	  boolean defenumeration enumeration
-	  system-area-pointer pointer alien alien-access
-	  alien-assign alien-sap define-alien-stack
-	  with-stack-alien null-terminated-string c-procedure
-	  unstructured record-size
-	  )
-	(find-package "C"))
-
-(export 'function-lambda-expression)
-
-;;; Hack to prevent SETF from expanding these macros out of the environment,
-;;; since these are functions in the new system.
-;;;
-#-new-compiler
-(dolist (x '(sap-ref-8 sap-ref-16 sap-ref-32))
-  (fmakunbound x))
-
-(in-package "USER")
-
-;;; Hack until real definition exists:
-;;;
-#-new-compiler
-(defmacro with-compilation-unit (glue &rest body)
-  (declare (ignore glue))
-  `(let ((lisp::*in-compilation-unit* t))
-     (declare (special lisp::*in-compilation-unit*))
-     ,@body))
-;;;
-;;; So the real WCU won't die in bootstrap env.
-#-new-compiler
-(defvar lisp::*in-compilation-unit* nil)
-#-new-compiler
-(defun c::print-summary (a b)
-  (declare (ignore a b)))
-
-
-#-new-compiler
-(setq lisp::*maximum-interpreter-error-checking* nil)
-
-
-(setq *bytes-consed-between-gcs* 1500000)
-
-(setq *gc-notify-before*
-      #'(lambda (&rest foo)
-	  (declare (ignore foo))
-	  (write-char #\. *terminal-io*)
-	  (force-output *terminal-io*)))
-
-(setq *gc-notify-after* #'list)
-
-(setf (ext:search-list "lisp:") '("/afs/cs/project/clisp/new-compiler/"))
-(setf (ext:search-list "c:") '("lisp:compiler/" "lisp:compiler/rt/"))
-(setf (ext:search-list "ncode:") '("lisp:ncode/" "lisp:code/"))
-(setf (ext:search-list "assem:") '("lisp:assembler/"))
-(setf (ext:search-list "nmiscops:") '("lisp:nmiscops/" "lisp:miscops/"))
-(setf (ext:search-list "nicode:") '("lisp:nicode/" "lisp:icode/"))
-
-
-;;;; Compile utility:
-
-;;; Switches:
-;;;
-(defvar *interactive* nil) ; Batch compilation mode?
-(defvar *new-compile* t) ; Use new compiler?
-
-(defvar *log-file* nil)
-(defvar *compiled-files* (make-hash-table :test #'equal))
-
-
-(defmacro with-compiler-log-file ((name) &body forms)
-  `(if *interactive*
-       (with-compilation-unit ()
-	 ,@forms)
-       (let ((*log-file* (open ,name :direction :output
-			       :if-exists :append
-			       :if-does-not-exist :create)))
-	 (unwind-protect
-	     (let ((*error-output* *log-file*))
-	       (with-compilation-unit ()
-		 ,@forms))
-	   (close *log-file*)))))
-
-
-(proclaim '(special lisp::*bootstrap-defmacro*))
-
-(defun comf (name &key always-once proceed load output-file
-		  ((:bootstrap-macros lisp::*bootstrap-defmacro*) nil))
-  #+new-compiler
-  (declare (ignore always-once))
-
-  (let* ((src (pathname (concatenate 'string name ".lisp")))
-	 (obj (if output-file
-		  (pathname output-file)
-		  (make-pathname :defaults src
-				 :type (if *new-compile* "nfasl" "fasl"))))
-	 (compiler #+new-compiler #'compile-file
-		   #-new-compiler (if *new-compile*
-				      #'c::ncompile-file
-				      #'compile-file)))
-
-    (unless (and (probe-file obj)
-		 (>= (file-write-date obj) (file-write-date src))
-		 #-new-compiler
-		 (or (gethash src *compiled-files*)
-		     (not always-once)))
-      (write-line name)
-      (format *error-output* "~2&Start time: ~A, compiling ~A.~%"
-	      (ext:format-universal-time nil (get-universal-time))
-	      name)
-      (cond
-       (*interactive*
-	(funcall compiler src  :error-file nil  :output-file obj)
-	(when load
-	  (load name :verbose t)))
-       (t
-	(handler-bind ((error #'(lambda (condition)
-				  (format *error-output* "~2&~A~2&"
-					  condition)
-				  (when proceed
-				    (format *error-output* "Proceeding...~%")
-				    (continue))
-				  (format *error-output* "Aborting...~%")
-				  (handler-case
-				      (let ((*debug-io* *error-output*))
-					(debug:backtrace))
-				    (error (condition)
-				      (declare (ignore condition))
-				      (format t "Error in backtrace!~%")))
-				  (format t "Error abort.~%")
-				  (return-from comf))))
-	  (funcall compiler src  :error-file nil  :output-file obj)
-	  (when load
-	    (load name :verbose t)))))
-      (setf (gethash src *compiled-files*) t))
-
-    ;; Only set after compilation so that it can be bound around the call.
-    (setq lisp::*bootstrap-defmacro* nil)))
diff --git a/tools/worldcom.lisp b/tools/worldcom.lisp
deleted file mode 100644
index 838495b98c9ac6f57ba611d4726ee84003cb9d2c..0000000000000000000000000000000000000000
--- a/tools/worldcom.lisp
+++ /dev/null
@@ -1,132 +0,0 @@
-;;; -*- Package: User; Log: code.log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; Spice Lisp is currently incomplete and under active development.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-
-(in-package "USER")
-
-(with-compiler-log-file ("ncode:compile-lisp.log")
-
-;;; these guys need to be first.
-
-(comf "ncode:globals" :always-once t) ; For global variables.
-(comf "ncode:struct" :always-once t) ; For structures.
-
-;;; these guys can supposedly come in any order, but not really.
-;;; some are put at the end so macros don't run interpreted and stuff.
-
-(comf "ncode:lispinit")
-(comf "ncode:error")
-(comf "ncode:alieneval")
-(comf "ncode:stream")
-(comf "ncode:arith")
-(comf "ncode:array")
-(comf "ncode:backq")
-(comf "ncode:c-call")
-(comf "ncode:char")
-(comf "ncode:list")
-;(comf "ncode:clx-ext")
-(comf "ncode:commandline")
-(comf "ncode:eval")
-(comf "ncode:debug")
-(comf "ncode:trace")
-(comf "ncode:extensions")
-(comf "ncode:fd-stream")
-(comf "ncode:fdefinition")
-(comf "ncode:filesys")
-(comf "ncode:format")
-(comf "ncode:hash")
-(comf "ncode:lfloatcon")
-(comf "ncode:load")
-(comf "ncode:miscop")
-(comf "ncode:package")
-(comf "ncode:rompstrops")
-(comf "ncode:pred")
-(comf "ncode:print")
-(comf "ncode:provide")
-(comf "ncode:query")
-(comf "ncode:rand")
-(comf "ncode:reader")
-(comf "ncode:rompnum")
-(comf "ncode:salterror")
-(comf "ncode:save")
-(comf "ncode:search-list")
-(comf "ncode:seq")
-(comf "ncode:serve-event")
-(comf "ncode:sharpm")
-(comf "ncode:sort")
-(comf "ncode:run-program")
-(comf "ncode:spirrat")
-(comf "ncode:xp")
-(comf "ncode:xp-patch")
-(comf "ncode:pprint")
-(comf "ncode:string")
-(comf "ncode:subtypep")
-(comf "ncode:symbol")
-(comf "ncode:syscall")
-(comf "ncode:sysmacs")
-(comf "ncode:time")
-(comf "ncode:foreign")
-(comf "c:proclaim")
-(comf "c:knownfun")
-(comf "ncode:debug-info")
-
-;;; Later so that miscellaneous structures are defined (not crucial, but nice.)
-(comf "ncode:describe")
-;(comf "ncode:inspect")
-(comf "ncode:tty-inspect")
-
-(comf "ncode:purify")
-(comf "ncode:gc")
-(comf "ncode:misc")
-(comf "ncode:format-time")
-(comf "ncode:parse-time")
-
-(comf "ncode:internet")
-(comf "ncode:wire")
-(comf "ncode:remote")
-
-(comf "assem:ropdefs")
-(comf "assem:rompconst")
-(comf "assem:disassemble")
-#+new-compiler
-(comf "assem:assem")
-#+new-compiler
-(comf "assem:assembler")
-
-(comf "ncode:machdef")
-(comf "ncode:mmlispdefs")
-(comf "nicode:machdefs")
-(comf "nicode:netnamedefs")
-
-(let ((system:*alien-eval-when* '(compile)))
-  (unless (probe-file "nicode:machuser.nfasl")
-    (load "nicode:machmsgdefs.lisp")
-    (comf "nicode:machuser"))
-  
-  (unless (probe-file "nicode:netnameuser.nfasl")
-    (load "nicode:netnamemsgdefs.lisp")
-    (comf "nicode:netnameuser")))
-
-;;; Compile basic macros that we assume are already in the compilation
-;;; environment.  We inhibit compile-time definition to prevent these functions
-;;; from becoming interpreted.  In some cases, this is necessary for
-;;; compilation to work at all, since the expander functions are lazily
-;;; converted: we could go into an infinite recursion trying to convert the
-;;; definition of a macro which uses itself.
-;;;
-(let ((c:*compile-time-define-macros* nil))
-  (comf "ncode:defstruct")
-  (comf "ncode:defmacro")
-  (comf "ncode:macros")
-  (comf "ncode:defrecord")
-  (comf "ncode:constants")
-  
-  (comf "c:globaldb"))
-
-); with-compiler-log-file
diff --git a/tools/worldload.lisp b/tools/worldload.lisp
deleted file mode 100644
index 4b782e4cce021fa3a8a75084c1cc80a301a63fb3..0000000000000000000000000000000000000000
--- a/tools/worldload.lisp
+++ /dev/null
@@ -1,163 +0,0 @@
-;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
-;;;
-;;; **********************************************************************
-;;; This code was written as part of the Spice Lisp project at
-;;; Carnegie-Mellon University, and has been placed in the public domain.
-;;; Spice Lisp is currently incomplete and under active development.
-;;; If you want to use this code or any part of Spice Lisp, please contact
-;;; Scott Fahlman (FAHLMAN@CMUC). 
-;;; **********************************************************************
-;;;
-;;; This file loads the parts of the system that aren't cold loaded and saves
-;;; the resulting core image.  It writes "lisp.core" in the DEFAULT-DIRECTORY.
-;;;
-
-
-#| Can't eval conditionals now...
-;;; Setup some packages.
-;;;
-(unless (eq *package* (find-package "USER"))
-  (error "Set *package* to the User package and try again."))
-|#
-
-(in-package "CLOS" :nicknames '("PCL"))
-(in-package "USER" :use '("LISP" "EXTENSIONS" "CONDITIONS" "DEBUG" "CLOS"))
-(in-package "HEMLOCK")
-(in-package "LISP")
-#|
-;;; Must load this here, instead of before loading this file, otherwise
-;;; SEARCH-LIST is unknown.
-;;;
-(load "/afs/cs/project/clisp/new-compiler/logical-names.lisp")
-|#
-;;; Get some data on this core.
-;;;
-(write-string "What is the current lisp-implementation-version? ")
-(set '*lisp-implementation-version* (read-line))
-(write-string "What is the compiler version? ")
-(set 'compiler-version (read-line))
-(write-string "What is the Hemlock version? ")
-(set '*hemlock-version* (read-line))
-
-;;;
-;;; Keep us entertained...
-(setq *load-verbose* t)
-
-(export 'ed)
-
-(load "code:run-program")
-(load "code:lfloatcon")
-(load "code:spirrat")
-(load "code:foreign")
-(load "code:format-time")
-(load "code:parse-time")
-;(load "code:xp-patch")
-(load "assem:ropdefs")
-(load "assem:rompconst")
-(load "assem:disassemble")
-
-
-(load "c:loadcom.lisp")
-
-(setq lisp::original-lisp-environment NIL)
-
-
-;;; Load the symbol table information for the Lisp start up code.
-;;; Used by CLX for the C routine to connect to the X11 server.
-;;;
-(load-foreign nil)
-
-#|
-;;; CLX.
-;;;
-(load "clx:defsystem")
-(load-clx (pathname "clx:"))
-
-;;; A hack to fix a bug in the X11 R3 server.  This should go away when
-;;; the server is fixed.
-;;;
-(load "/afs/cs/project/clisp/systems-work/font-patch")
-|#
-
-;;; Stick these after LOAD-FORIEGN but before Hemlock.
-;;;
-(load "code:internet")
-(load "code:wire")
-(load "code:remote")
-
-#|
-;;; Hemlock.
-;;;
-(load "hem:rompsite") ;Contains site-init stuff called at load time.
-(load "hem:load-hem.lisp")
-(hi::build-hemlock)
-
-;;; Setup definition editing defaults to look in the stable AFS directory.
-;;; The first translation says what we want most clearly, but we require
-;;; the others due to symbol links.
-;;;
-(ed::add-definition-dir-translation "/afs/cs/project/clisp/systems-work/"
-				    "/afs/cs/project/clisp/systems/")
-(ed::add-definition-dir-translation "/afs/cs/project/clisp-1/systems-work/"
-				    "/afs/cs/project/clisp/systems/")
-(ed::add-definition-dir-translation
- "/afs/cs.cmu.edu/project/clisp-1/systems-work/"
- "/afs/cs/project/clisp/systems/")
-(ed::add-definition-dir-translation
- "/afs/cs.cmu.edu/project/clisp/systems-work/"
- "/afs/cs/project/clisp/systems/")
-
-;;; For some interim time, translate old compilation directories to the new
-;;; working directories.  Do it for symbolic links and actual paths.
-;;;
-(ed::add-definition-dir-translation "/usr/lisp/"
-				    "/afs/cs/project/clisp/systems/")
-(ed::add-definition-dir-translation "/usr1/lisp/"
-				    "/afs/cs/project/clisp/systems/")
-(ed::add-definition-dir-translation "/usr2/lisp/"
-				    "/afs/cs/project/clisp/systems/")
-
-
-;;; PCL.
-;;;
-(load "pcl:defsys")
-(pcl::load-pcl)
-
-|#
-
-;;; Load these after PCL.
-;;;
-;(load "code:inspect")
-(load "code:tty-inspect")
-
-
-;;; There should be no search lists defined in a full core.
-;;;
-(clrhash lisp::*search-list-table*)
-
-
-;;; Okay, build the thing!
-;;;
-(in-package "USER")
-(progn 
-  (setq + NIL)
-  (setq * NIL)
-  (setq ++ NIL)
-  (setq ** NIL)
-  (setq +++ NIL)
-  (setq *** NIL)
-  (setq *load-verbose* nil)
-  (setq *info-environment*
-	(list (make-info-environment :name "Working")
-	      (compact-info-environment (car *info-environment*))))
-  (save-lisp (namestring (merge-pathnames "lisp.core" (default-directory)))
-	     :purify t
-	     :root-structures `(ed
-				#|,hi::*global-command-table*|#
-				lisp::%top-level
-				extensions:save-lisp
-				,lisp::fop-codes
-				compile-file)
-	     :init-function #'(lambda ()
-				(gc-on)
-				(abort))))